diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +2021-08-23 v1.1 + * Add support for GHC 9.2 rc1, and this version drops support for + prior GHC versions. 2021-02-24 v0.6.4 * Add support for GHC 9.0.1 2021-02-01 v0.6.3.4 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,27 +1,13 @@ name: ghc-exactprint -version: 0.6.4 +version: 1.1.0 synopsis: ExactPrint for GHC -description: Using the API Annotations available from GHC 7.10.2, this +description: Using the API Annotations available from GHC 9.2.1, this library provides a means to round trip any code that can be compiled by GHC, currently excluding lhs files. . - It does this with a phased approach - . - * Delta - converts GHC API Annotations into relative - offsets, indexed by SrcSpan - . - * Transform - functions to facilitate changes to - the AST, adjusting the annotations generated in the - Delta phase to suit the changes. - . - * 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 9.2 or later. For GHC versions from + 7.10.2 to 9.0.* see this library with versions < 1.1 . - Note: requires GHC 7.10.2 or later license: BSD3 license-file: LICENSE @@ -29,25 +15,9 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 7.10.3 - , GHC == 8.0.2 - , GHC == 8.2.2 - , GHC == 8.4.2 - , GHC == 8.4.3 - , GHC == 8.4.4 - , GHC == 8.6.1 - , GHC == 8.6.2 - , GHC == 8.6.4 - , GHC == 8.6.5 - , GHC == 8.8.1 - , GHC == 8.8.2 - , GHC == 8.8.3 - , GHC == 8.8.4 - , GHC == 8.10.1 - , GHC == 8.10.2 - , GHC == 9.0.1 +-- tested-with: GHC == 9.2.1 +tested-with: GHC == 9.2.0.20210821 extra-source-files: ChangeLog - src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs tests/examples/failing/*.hs tests/examples/ghc710-only/*.hs tests/examples/ghc710/*.hs @@ -58,6 +28,7 @@ tests/examples/ghc86/*.hs tests/examples/ghc88/*.hs tests/examples/ghc90/*.hs + tests/examples/ghc92/*.hs tests/examples/pre-ghc810/*.hs tests/examples/pre-ghc86/*.hs tests/examples/pre-ghc90/*.hs @@ -85,32 +56,24 @@ 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.ExactPrint , 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 - if impl (ghc <= 8.0.2) - exposed-modules: Language.Haskell.GHC.ExactPrint.GhcInterim + hs-source-dirs: src -- other-modules: -- other-extensions: - if impl (ghc >= 8.0.1) - GHC-Options: -Wall -Wredundant-constraints - else - GHC-Options: -Wall + GHC-Options: -Wall -Wredundant-constraints -- GHC-Options: -Weverything - build-depends: base >=4.8 && <4.16 + build-depends: base >=4.16 && <4.18 , bytestring >= 0.10.6 , containers >= 0.5 + , ordered-containers , directory >= 1.2 , filepath >= 1.4 , ghc >= 7.10.2 @@ -118,40 +81,12 @@ , mtl >= 2.2.1 , syb >= 0.5 , free >= 4.12 + , fail >= 4.9 && <4.10 + , ghc-boot - if !impl (ghc >= 8.0) - build-depends: - fail >= 4.9 && <4.10 - if impl (ghc >= 7.11) - build-depends: ghc-boot - hs-source-dirs: src - - if impl (ghc > 8.10.9) - hs-source-dirs: src-ghc90 - else - if impl (ghc > 8.8.4) - hs-source-dirs: src-ghc810 - else - if impl (ghc > 8.6.5) - hs-source-dirs: src-ghc88 - else - if impl (ghc > 8.4.4) - hs-source-dirs: src-ghc86 - else - if impl (ghc > 8.2.2) - hs-source-dirs: src-ghc84 - else - 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) + if impl (ghc < 9.2) buildable: False Test-Suite test @@ -162,46 +97,20 @@ else hs-source-dirs: tests - if impl (ghc > 8.10.9) - hs-source-dirs: src-ghc90 - else - if impl (ghc > 8.8.4) - hs-source-dirs: src-ghc810 - else - if impl (ghc > 8.6.5) - hs-source-dirs: src-ghc88 - else - if impl (ghc > 8.4.4) - hs-source-dirs: src-ghc86 - else - if impl (ghc > 8.2.2) - hs-source-dirs: src-ghc84 - else - 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.CommonUtils - , Test.Consistency , Test.NoAnnotations , Test.Transform - if impl (ghc >= 8.0.1) - GHC-Options: -threaded -Wall -Wredundant-constraints - else - GHC-Options: -threaded -Wall + GHC-Options: -threaded -Wall -Wredundant-constraints Default-language: Haskell2010 - if impl (ghc < 7.10.2) + if impl (ghc < 9.2) buildable: False Build-depends: HUnit >= 1.2 - , base < 4.16 + , base < 4.18 , bytestring , containers >= 0.5 + , ordered-containers , Diff , directory >= 1.2 , filepath >= 1.4 @@ -212,25 +121,21 @@ , silently >= 1.2 , filemanip >= 0.3 -- for the lib only - if !impl (ghc >= 8.0) - build-depends: - fail >= 4.9 && <4.10 + , fail >= 4.9 && <4.10 + , ghc-boot if flag (dev) build-depends: free else build-depends: ghc-exactprint - if impl (ghc >= 7.11) - build-depends: ghc-boot - executable roundtrip main-is: Roundtrip.hs hs-source-dirs: tests other-modules: Test.Common Test.CommonUtils - Test.Consistency + -- Test.Consistency default-language: Haskell2010 - if impl (ghc >= 7.10.2) && flag (roundtrip) + if impl (ghc >= 9.2) && flag (roundtrip) build-depends: HUnit , base @@ -244,15 +149,11 @@ , syb , temporary , time - if impl (ghc >= 7.11) - build-depends: ghc-boot + , ghc-boot buildable: True else buildable: False - if impl (ghc >= 8.0.1) - GHC-Options: -threaded -Wall -Wredundant-constraints - else - GHC-Options: -threaded -Wall + GHC-Options: -threaded -Wall -Wredundant-constraints executable static main-is: Static.hs @@ -265,15 +166,11 @@ , filepath , ghc , Diff + , ghc-boot buildable: True - if impl (ghc >= 7.11) - build-depends: ghc-boot else buildable: False - if impl (ghc >= 8.0.1) - GHC-Options: -threaded -Wall -Wredundant-constraints - else - GHC-Options: -threaded -Wall + GHC-Options: -threaded -Wall -Wredundant-constraints executable prepare-hackage main-is: PrepareHackage.hs @@ -285,17 +182,13 @@ , directory , filemanip , filepath - , ghc >= 7.10.2 + , ghc >= 9.2 , ghc-paths >= 0.1 , HUnit , text >= 1.2.2 , turtle >= 1.3.0 + , ghc-boot buildable: True - if impl (ghc >= 7.11) - build-depends: ghc-boot else buildable: False - if impl (ghc >= 8.0.1) - GHC-Options: -threaded -Wall -Wredundant-constraints - else - GHC-Options: -threaded -Wall + GHC-Options: -threaded -Wall -Wredundant-constraints diff --git a/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs deleted file mode 100644 --- a/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2556 +0,0 @@ -{-# 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 - markManyOptional GHC.AnnOpenP - 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 deleted file mode 100644 --- a/src-ghc80/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2750 +0,0 @@ -{-# 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 - markInstead GHC.AnnAt AnnTypeApp - 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-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs deleted file mode 100644 --- a/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2949 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} - - --- | 'annotate' is a function which given a GHC AST fragment, constructs --- a syntax tree which indicates which annotations belong to each specific --- part of the fragment. --- --- "Delta" and "Print" provide two interpreters for this structure. You --- should probably use those unless you know what you're doing! --- --- The functor 'AnnotationF' has a number of constructors which correspond --- to different sitations which annotations can arise. It is hoped that in --- future versions of GHC these can be simplified by making suitable --- modifications to the AST. - -module Language.Haskell.GHC.ExactPrint.Annotater - ( - annotate - , AnnotationF(..) - , Annotated - , Annotate(..) - , withSortKeyContextsHelper - ) where - - -import Language.Haskell.GHC.ExactPrint.AnnotateTypes -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified BooleanFormula as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC --- import qualified HsDoc as GHC -import qualified Name as GHC -import qualified RdrName as GHC -import qualified Outputable as GHC -import qualified SrcLoc as GHC - -import Control.Monad.Identity -import Data.Data -import Data.Maybe - -import qualified Data.Set as Set - -import Debug.Trace - - -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} --- --------------------------------------------------------------------- - -class Data ast => Annotate ast where - markAST :: GHC.SrcSpan -> ast -> Annotated () - --- --------------------------------------------------------------------- - --- | Construct a syntax tree which represent which KeywordIds must appear --- where. -annotate :: (Annotate ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated () -annotate = markLocated - --- instance Annotate (GHC.SrcSpanLess ast) where --- markAST s ast = undefined -instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where - markAST l (GHC.L _ ast) = markAST l ast - --- --------------------------------------------------------------------- - --- | Constructs a syntax tree which contains information about which --- annotations are required by each element. -markLocated :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => ast -> Annotated () -markLocated ast = - case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of - Just d -> markLHsDecl d - Nothing -> withLocated ast markAST - --- --------------------------------------------------------------------- - --- |When adding missing annotations, do not put a preceding space in front of a list -markListNoPrecedingSpace :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => Bool -> [ast] -> Annotated () -markListNoPrecedingSpace intercal ls = - case ls of - [] -> return () - (l:ls') -> do - if intercal - then do - if null ls' - then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l - else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l - markListIntercalate ls' - else do - setContext (Set.singleton NoPrecedingSpace) $ markLocated l - mapM_ markLocated ls' - --- --------------------------------------------------------------------- - - --- |Mark a list, with the given keyword as a list item separator -markListIntercalate :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => [ast] -> Annotated () -markListIntercalate ls = markListIntercalateWithFun markLocated ls - --- --------------------------------------------------------------------- - -markListWithContexts :: Annotate ast - => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () -markListWithContexts ctxInitial ctxRest ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxInitial 2 $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial 2 $ markLocated x - setContextLevel ctxRest 2 $ mapM_ markLocated xs - --- --------------------------------------------------------------------- - --- Context for only if just one, else first item, middle ones, and last one -markListWithContexts' :: Annotate ast - => ListContexts - -> [GHC.Located ast] -> Annotated () -markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxOnly level $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial level $ markLocated x - go xs - where - level = 2 - go [] = return () - go [x] = setContextLevel ctxLast level $ markLocated x - go (x:xs) = do - setContextLevel ctxMiddle level $ markLocated x - go xs - - --- --------------------------------------------------------------------- - -markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () -markListWithLayout ls = - setLayoutFlag $ markList ls - --- --------------------------------------------------------------------- - -markList :: Annotate ast => [GHC.Located ast] -> Annotated () -markList ls = - setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts' ls - -markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markLocalBindsWithLayout binds = markHsLocalBinds binds - --- --------------------------------------------------------------------- - --- |This function is used to get around shortcomings in the GHC AST for 7.10.1 -markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () -markLocatedFromKw kw (GHC.L l a) = do - -- Note: l is needed so that the pretty printer can make something up - ss <- getSrcSpanForKw l kw - AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) - markLocated (GHC.L ss' a) - --- --------------------------------------------------------------------- - -markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () -markMaybe Nothing = return () -markMaybe (Just ast) = markLocated ast - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] -prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsModule GHC.GhcPs) where - markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do - - case mmn of - Nothing -> return () - Just (GHC.L ln mn) -> do - mark GHC.AnnModule - markExternal ln GHC.AnnVal (GHC.moduleNameString mn) - - forM_ mdepr markLocated - forM_ mexp markLocated - - mark GHC.AnnWhere - - markOptional GHC.AnnOpenC -- Possible '{' - markManyOptional GHC.AnnSemi -- possible leading semis - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps - - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs - - markOptional GHC.AnnCloseC -- Possible '}' - - markEOF - --- --------------------------------------------------------------------- - -instance Annotate GHC.WarningTxt where - markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# WARNING" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# DEPRECATED" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate GHC.StringLiteral where - markAST l (GHC.StringLiteral src fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SourceText,GHC.FastString) where - markAST l (src,fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LIE GHC.GhcPs] where - markAST _ ls = do - inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl - mark GHC.AnnOpenP -- '(' - -- Can't use markListIntercalate, there can be trailing commas, but only in imports. - markListIntercalateWithFunLevel markLocated 2 ls - - mark GHC.AnnCloseP -- ')' - -instance Annotate (GHC.IE GHC.GhcPs) where - markAST _ ie = do - - case ie of - GHC.IEVar _ ln -> markLocated ln - - GHC.IEThingAbs _ ln -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - - GHC.IEThingWith _ ln wc ns _lfs -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnOpenP - case wc of - GHC.NoIEWildcard -> - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns - GHC.IEWildcard n -> do - setContext (Set.fromList [PrefixOp,Intercalate]) - $ mapM_ markLocated (take n ns) - mark GHC.AnnDotdot - case drop n ns of - [] -> return () - ns' -> do - mark GHC.AnnComma - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns' - mark GHC.AnnCloseP - - (GHC.IEThingAll _ ln) -> do - setContext (Set.fromList [PrefixOp]) $ markLocated ln - mark GHC.AnnOpenP - mark GHC.AnnDotdot - mark GHC.AnnCloseP - - (GHC.IEModuleContents _ (GHC.L lm mn)) -> do - mark GHC.AnnModule - markExternal lm GHC.AnnVal (GHC.moduleNameString mn) - - -- Only used in Haddock mode so we can ignore them. - (GHC.IEGroup {}) -> return () - - (GHC.IEDoc {}) -> return () - - (GHC.IEDocNamed {}) -> return () - GHC.XIE x -> error $ "got XIE for :" ++ showGhc x - ifInContext (Set.fromList [Intercalate]) - (mark GHC.AnnComma) - (markOptional GHC.AnnComma) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IEWrappedName GHC.RdrName) where - markAST _ (GHC.IEName ln) = do - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEPattern ln) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEType ln) = do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -isSymRdr :: GHC.RdrName -> Bool -isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." - -instance Annotate GHC.RdrName where - markAST l n = do - let - str = rdrName2String n - isSym = isSymRdr n - doNormalRdrName = do - let str' = case str of - -- TODO: unicode support? - "forall" -> if spanLength l == 1 then "∀" else str - _ -> str - - let - markParen :: GHC.AnnKeywordId -> Annotated () - markParen pa = do - if isSym - then ifInContext (Set.fromList [PrefixOp,PrefixOpDollar]) - (mark pa) -- '(' - (markOptional pa) - else markOptional pa - - markOptional GHC.AnnSimpleQuote - markParen GHC.AnnOpenP - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 - cnt <- countAnns GHC.AnnVal - case cnt of - 0 -> markExternal l GHC.AnnVal str' - 1 -> markWithString GHC.AnnVal str' - _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 - markParen GHC.AnnCloseP - - case n of - GHC.Unqual _ -> doNormalRdrName - GHC.Qual _ _ -> doNormalRdrName - GHC.Orig _ _ -> if str == "~" - then doNormalRdrName - -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen) - else markExternal l GHC.AnnVal str - -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str - -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]" - GHC.Exact n' -> do - case str of - -- Special handling for Exact RdrNames, which are built-in Names - "[]" -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnCloseS -- ']' - "()" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnCloseP -- ')' - ('(':'#':_) -> do - markWithString GHC.AnnOpen "(#" -- '(#' - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - markWithString GHC.AnnClose "#)"-- '#)' - "[::]" -> do - markWithString GHC.AnnOpen "[:" -- '[:' - markWithString GHC.AnnClose ":]" -- ':]' - "->" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnRarrow - mark GHC.AnnCloseP -- ')' - -- "~#" -> do - -- mark GHC.AnnOpenP -- '(' - -- mark GHC.AnnTildehsh - -- mark GHC.AnnCloseP - "~" -> do - doNormalRdrName - "*" -> do - markExternal l GHC.AnnVal str - "★" -> do -- Note: unicode star - markExternal l GHC.AnnVal str - ":" -> do - -- Note: The OccName for ":" has the following attributes (via occAttributes) - -- (d, Data DataSym Sym Val ) - -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - doNormalRdrName - -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName - ('(':',':_) -> do - mark GHC.AnnOpenP - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - mark GHC.AnnCloseP -- ')' - _ -> do - let isSym' = isSymRdr (GHC.nameRdrName n') - when isSym' $ mark GHC.AnnOpenP -- '(' - markWithString GHC.AnnVal str - when isSym $ mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ImportDecl GHC.GhcPs) where - markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do - - -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - mark GHC.AnnImport - - -- "{-# SOURCE" and "#-}" - case msrc of - GHC.SourceText _txt -> do - markAnnOpen msrc "{-# SOURCE" - markWithString GHC.AnnClose "#-}" - GHC.NoSourceText -> return () - when safeflag (mark GHC.AnnSafe) - case qualFlag of - GHC.QualifiedPre -- 'qualified' appears in prepositive position. - -> (unsetContext TopLevel $ mark GHC.AnnQualified) - _ -> return () - case mpkg of - Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> - markWithString GHC.AnnPackageName srcPkg - _ -> return () - - markLocated modname - - case qualFlag of - GHC.QualifiedPost -- 'qualified' appears in postpositive position. - -> (unsetContext TopLevel $ mark GHC.AnnQualified) - _ -> return () - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - mark GHC.AnnAs - markLocated mn - - case hiding of - Nothing -> return () - Just (isHiding,lie) -> do - if isHiding - then setContext (Set.singleton HasHiding) $ - markLocated lie - else markLocated lie - markTrailingSemi - - - markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.ModuleName where - markAST l mname = - markExternal l GHC.AnnVal (GHC.moduleNameString mname) - --- --------------------------------------------------------------------- - -markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () -markLHsDecl (GHC.L l decl) = - case decl of - GHC.TyClD _ d -> markLocated (GHC.L l d) - GHC.InstD _ d -> markLocated (GHC.L l d) - GHC.DerivD _ d -> markLocated (GHC.L l d) - GHC.ValD _ d -> markLocated (GHC.L l d) - GHC.SigD _ d -> markLocated (GHC.L l d) - GHC.KindSigD _ d -> markLocated (GHC.L l d) - GHC.DefD _ d -> markLocated (GHC.L l d) - GHC.ForD _ d -> markLocated (GHC.L l d) - GHC.WarningD _ d -> markLocated (GHC.L l d) - GHC.AnnD _ d -> markLocated (GHC.L l d) - GHC.RuleD _ d -> markLocated (GHC.L l d) - GHC.SpliceD _ d -> markLocated (GHC.L l d) - GHC.DocD _ d -> markLocated (GHC.L l d) - GHC.RoleAnnotD _ d -> markLocated (GHC.L l d) - GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x - -instance Annotate (GHC.HsDecl GHC.GhcPs) where - markAST l d = markLHsDecl (GHC.L l d) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where - markAST _ (GHC.RoleAnnotDecl _ ln mr) = do - mark GHC.AnnType - mark GHC.AnnRole - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated mr - markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x - -instance Annotate (Maybe GHC.Role) where - markAST l Nothing = markExternal l GHC.AnnVal "_" - markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SpliceDecl GHC.GhcPs) where - markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do - markLocated e - markTrailingSemi - markAST _ (GHC.SpliceDecl _ e _flag) = do - markLocated e - markTrailingSemi - - markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecls GHC.GhcPs) where - markAST _ (GHC.HsRules _ src rules) = do - markAnnOpen src "{-# RULES" - setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules - markWithString GHC.AnnClose "#-}" - markTrailingSemi - markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecl GHC.GhcPs) where - markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do - markLocated ln - setContext (Set.singleton ExplicitNeverActive) $ markActivation l act - - case mtybndrs of - Nothing -> return () - Just bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - mark GHC.AnnForall - mapM_ markLocated termbndrs - mark GHC.AnnDot - - markLocated lhs - mark GHC.AnnEqual - markLocated rhs - inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi - markTrailingSemi -{- - = HsRule -- Source rule - { rd_ext :: XHsRule pass - -- ^ After renamer, free-vars from the LHS and RHS - , rd_name :: Located (SourceText,RuleName) - -- ^ Note [Pragma source text] in BasicTypes - , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] - -- ^ Forall'd type vars - , rd_tmvs :: [LRuleBndr pass] - -- ^ Forall'd term vars, before typechecking; after typechecking - -- this includes all forall'd vars - , rd_lhs :: Located (HsExpr pass) - , rd_rhs :: Located (HsExpr pass) - } - --} - - markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () -markActivation _ act = do - case act of - GHC.ActiveBefore src phase -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.ActiveAfter src phase -> do - mark GHC.AnnOpenS -- '[' - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.NeverActive -> do - inContext (Set.singleton ExplicitNeverActive) $ do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - mark GHC.AnnCloseS -- ']' - _ -> return () - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleBndr GHC.GhcPs) where - markAST _ (GHC.RuleBndr _ ln) = markLocated ln - markAST _ (GHC.RuleBndrSig _ ln st) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLHsSigWcType st - mark GHC.AnnCloseP -- ")" - markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x - --- --------------------------------------------------------------------- - -markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () -markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do - markLocated ty -markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit" -markLHsSigWcType (GHC.XHsWildCardBndrs _) = error "markLHsSigWcType extension hit" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.AnnDecl GHC.GhcPs) where - markAST _ (GHC.HsAnnotation _ src prov e) = do - markAnnOpen src "{-# ANN" - case prov of - (GHC.ValueAnnProvenance n) -> markLocated n - (GHC.TypeAnnProvenance n) -> do - mark GHC.AnnType - markLocated n - GHC.ModuleAnnProvenance -> mark GHC.AnnModule - - markLocated e - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecls GHC.GhcPs) where - markAST _ (GHC.Warnings _ src warns) = do - markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED - mapM_ markLocated warns - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecl GHC.GhcPs) where - markAST _ (GHC.Warning _ lns txt) = do - markListIntercalate lns - mark GHC.AnnOpenS -- "[" - case txt of - GHC.WarningTxt _src ls -> markListIntercalate ls - GHC.DeprecatedTxt _src ls -> markListIntercalate ls - mark GHC.AnnCloseS -- "]" - - markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x - -instance Annotate GHC.FastString where - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - markAST l fs = do - markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ForeignDecl GHC.GhcPs) where - markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnImport - markLocated cconv - unless (ll == GHC.noSrcSpan) $ markLocated safety - markExternalSourceText ls src "" - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnExport - markLocated spec - markExternal ls GHC.AnnVal (sourceTextToString src "") - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLocated typ - - - markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" - markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" - markAST _ (GHC.XForeignDecl _) = error "markAST ForeignDecl hit extenstion" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CExportSpec) where - markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CCallConv) where - markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" - markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" - markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" - markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" - markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.Safety) where - markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" - markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" - markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivDecl GHC.GhcPs) where - - markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do - mark GHC.AnnDeriving - markMaybe ms - mark GHC.AnnInstance - markMaybe mov - markLocated typ - markTrailingSemi - -{- -data DerivDecl pass = DerivDecl - { deriv_ext :: XCDerivDecl pass - , deriv_type :: LHsSigWcType pass - -- ^ The instance type to derive. - -- - -- It uses an 'LHsSigWcType' because the context is allowed to be a - -- single wildcard: - -- - -- > deriving instance _ => Eq (Foo a) - -- - -- Which signifies that the context should be inferred. - - -- See Note [Inferring the instance context] in TcDerivInfer. - - , deriv_strategy :: Maybe (LDerivStrategy pass) - , deriv_overlap_mode :: Maybe (Located OverlapMode) - -type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both - -data HsWildCardBndrs pass thing - -- See Note [HsType binders] - -- See Note [The wildcard story for types] - = HsWC { hswc_ext :: XHsWC pass thing - -- after the renamer - -- Wild cards, both named and anonymous - - , hswc_body :: thing - -- Main payload (type or list of types) - -- If there is an extra-constraints wildcard, - -- it's still there in the hsc_body. - } - - --} - - - markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension" - markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _) = error "markAST DerivDecl hit extension" - markAST _ (GHC.XDerivDecl _) = error "markAST DerivDecl hit extension" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivStrategy GHC.GhcPs) where - - markAST _ GHC.StockStrategy = mark GHC.AnnStock - markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass - markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype - markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do - mark GHC.AnnVia - markLocated ty - markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _)) - = error $ "got XHsImplicitBndrs in AnnDerivStrategy" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DefaultDecl GHC.GhcPs) where - - markAST _ (GHC.DefaultDecl _ typs) = do - mark GHC.AnnDefault - mark GHC.AnnOpenP -- '(' - markListIntercalate typs - mark GHC.AnnCloseP -- ')' - markTrailingSemi - - markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InstDecl GHC.GhcPs) where - - markAST l (GHC.ClsInstD _ cid) = markAST l cid - markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid - markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid - markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.OverlapMode where - - -- NOTE: NoOverlap is only used in the typechecker - markAST _ (GHC.NoOverlap src) = do - markAnnOpen src "{-# NO_OVERLAP" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlappable src) = do - markAnnOpen src "{-# OVERLAPPABLE" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlapping src) = do - markAnnOpen src "{-# OVERLAPPING" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlaps src) = do - markAnnOpen src "{-# OVERLAPS" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Incoherent src) = do - markAnnOpen src "{-# INCOHERENT" - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where - - markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do - mark GHC.AnnInstance - markMaybe mov - markLocated poly - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - - applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ++ prepareListAnnotation tyfams - ++ prepareListAnnotation datafams - ) - - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl" - markAST _ (GHC.XClsInstDecl _) = error "extension hit for ClsInstDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where -{- -newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } - -type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) - -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) - - --} - markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do - mark GHC.AnnType - mark GHC.AnnInstance -- Note: this keyword is optional - markFamEqn eqn - markTrailingSemi - - markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl" - --- --------------------------------------------------------------------- - --- markFamEqn :: (GHC.HasOccName (GHC.IdP pass), --- Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) --- => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) --- -> Annotated () --- markFamEqn :: GHC.FamEqn GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs) -markFamEqn :: GHC.FamEqn GhcPs (GHC.LHsType GHC.GhcPs) - -> Annotated () -markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do - markTyClassArgs bndrs fixity ln pats - mark GHC.AnnEqual - markLocated rhs -{- -data FamEqn pass pats rhs - = FamEqn - { feqn_ext :: XCFamEqn pass pats rhs - , feqn_tycon :: Located (IdP pass) - , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars - , feqn_pats :: pats - , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , feqn_rhs :: rhs - } --} - -markFamEqn (GHC.XFamEqn _) = error "got XFamEqn" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where - - markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs pats fixity - defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do - case GHC.dd_ND defn of - GHC.NewType -> mark GHC.AnnNewtype - GHC.DataType -> mark GHC.AnnData - mark GHC.AnnInstance - - markLocated ctx - - markTyClassArgs bndrs fixity ln pats - - case (GHC.dd_kindSig defn) of - Just s -> do - mark GHC.AnnDcolon - markLocated s - Nothing -> return () - if isGadt $ GHC.dd_cons defn - then mark GHC.AnnWhere - else unless (null cons) $ mark GHC.AnnEqual - markDataDefn l (GHC.HsDataDefn GHC.NoExtField nd (GHC.noLoc []) typ _mk cons mderivs) - markOptional GHC.AnnWhere - markTrailingSemi - - markAST _ - (GHC.DataFamInstDecl - (GHC.HsIB _ (GHC.FamEqn _ _ _ _ _ (GHC.XHsDataDefn _)))) - = error "extension hit for DataFamInstDecl" - markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _))) - = error "extension hit for DataFamInstDecl" - markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _)) - = error "extension hit for DataFamInstDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsBind GHC.GhcPs) where - markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do - -- Note: from a layout perspective a FunBind should not exist, so the - -- current context is passed through unchanged to the matches. - -- TODO: perhaps bring the edp from the first match up to the annotation for - -- the FunBind. - let - tlFun = - ifInContext (Set.fromList [CtxOnly,CtxFirst]) - (markListWithContexts' listContexts matches) - (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) - ifInContext (Set.singleton TopLevel) - (setContextLevel (Set.singleton TopLevel) 2 tlFun) - tlFun - - -- ----------------------------------- - - markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do - markLocated lhs - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards - _ -> return () - markListIntercalateWithFunLevel markLocated 2 grhs - - -- TODO: extract this common code - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.VarBind _ _n rhse _) = - -- Note: this bind is introduced by the typechecker - markLocated rhse - - -- ----------------------------------- - - -- Introduced after renaming. - markAST _ (GHC.AbsBinds {}) = - traceM "warning: AbsBinds introduced after renaming" - - -- ----------------------------------- - - markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do - mark GHC.AnnPattern - case args of - GHC.InfixCon la lb -> do - markLocated la - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated lb - GHC.PrefixCon ns -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated ns - GHC.RecCon fs -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs - mark GHC.AnnCloseC -- '}' - case dir of - GHC.ImplicitBidirectional -> mark GHC.AnnEqual - _ -> mark GHC.AnnLarrow - - markLocated def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markMatchGroup l mg - mark GHC.AnnCloseC -- '}' - - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _) - = error "extension hit for HsBind" - markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _) - = error "extension hit for HsBind" - markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _)) - = error "extension hit for HsBind" - markAST _ (GHC.XHsBindsLR _) - = error "extension hit for HsBind" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IPBind GHC.GhcPs) where - markAST _ (GHC.IPBind _ en e) = do - case en of - Left n -> markLocated n - Right _i -> return () - mark GHC.AnnEqual - markLocated e - markTrailingSemi - - -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x - markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsIPName where - markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do - let - get_infix (GHC.FunRhs _ f _) = f - get_infix _ = GHC.Prefix - - isFunBind GHC.FunRhs{} = True - isFunBind _ = False - case (get_infix mln,pats) of - (GHC.Infix, a:b:xs) -> do - if null xs - then markOptional GHC.AnnOpenP - else mark GHC.AnnOpenP - markLocated a - case mln of - GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n - _ -> return () - markLocated b - if null xs - then markOptional GHC.AnnCloseP - else mark GHC.AnnCloseP - mapM_ markLocated xs - _ -> do - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam - case mln of - GHC.FunRhs n _ s -> do - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do - when (s == GHC.SrcStrict) $ mark GHC.AnnBang - markLocated n - mapM_ markLocated pats - _ -> markListNoPrecedingSpace False pats - - -- TODO: The AnnEqual annotation actually belongs in the first GRHS value - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards - _ -> return () - inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam - mapM_ markLocated grhs - - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _)) - = error "hit extension for Match" - markAST _ (GHC.XMatch _) - = error "hit extension for Match" - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where - markAST _ (GHC.GRHS _ guards expr) = do - case guards of - [] -> return () - (_:_) -> do - mark GHC.AnnVbar - unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) - $ markListIntercalate guards - ifInContext (Set.fromList [CaseAlt]) - (return ()) - (mark GHC.AnnEqual) - - markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test - - inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam - setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr - - markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Sig GHC.GhcPs) where - - markAST _ (GHC.TypeSig _ lns st) = do - setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns - mark GHC.AnnDcolon - markLHsSigWcType st - markTrailingSemi - tellContext (Set.singleton FollowingLine) - - markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do - when isDefault $ mark GHC.AnnDefault - setContext (Set.singleton PrefixOp) $ markListIntercalate ns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.IdSig {}) = - traceM "warning: Introduced after renaming" - - markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do - let fixstr = case fdir of - GHC.InfixL -> "infixl" - GHC.InfixR -> "infixr" - GHC.InfixN -> "infix" - markWithString GHC.AnnInfix fixstr - markSourceText src (show v) - setContext (Set.singleton InfixOp) $ markListIntercalate lns - markTrailingSemi - - markAST l (GHC.InlineSig _ ln inl) = do - markAnnOpen (GHC.inl_src inl) "{-# INLINE" - markActivation l (GHC.inl_act inl) - setContext (Set.singleton PrefixOp) $ markLocated ln - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - markAST l (GHC.SpecSig _ ln typs inl) = do - markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE - markActivation l (GHC.inl_act inl) - markLocated ln - mark GHC.AnnDcolon -- '::' - markListIntercalateWithFunLevel markLHsSigType 2 typs - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.SpecInstSig _ src typ) = do - markAnnOpen src "{-# SPECIALISE" - mark GHC.AnnInstance - markLHsSigType typ - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.MinimalSig _ src formula) = do - markAnnOpen src "{-# MINIMAL" - markLocated formula - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.SCCFunSig _ src ln ml) = do - markAnnOpen src "{-# SCC" - markLocated ln - markMaybe ml - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do - markAnnOpen src "{-# COMPLETE" - markListIntercalate ns - case mlns of - Nothing -> return () - Just _ -> do - mark GHC.AnnDcolon - markMaybe mlns - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - -- ----------------------------------- - markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _)) - = error "hit extension for Sig" - markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _)) - = error "hit extension for Sig" - markAST _ (GHC.FixSig _ (GHC.XFixitySig _)) - = error "hit extension for Sig" - markAST _ (GHC.XSig _) - = error "hit extension for Sig" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.StandaloneKindSig GHC.GhcPs) where - - markAST _ (GHC.StandaloneKindSig _ ln st) = do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLHsSigType st - markTrailingSemi - tellContext (Set.singleton FollowingLine) - - markAST _ (GHC.XStandaloneKindSig _) - = error "hit extension for StandaloneKindSig" - --- -------------------------------------------------------------------- - -markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () -markLHsSigType (GHC.HsIB _ typ) = markLocated typ -markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - -instance Annotate [GHC.LHsSigType GHC.GhcPs] where - markAST _ ls = do - -- mark GHC.AnnDeriving - -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it - -- is a HsTyVar. So for round trip pretty printing we need to take this into - -- account. - let marker = case ls of - [] -> markManyOptional - [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t) - then markMany - else markManyOptional - _ -> markMany -- Need parens if more than one entry - marker GHC.AnnOpenP - markListIntercalateWithFun markLHsSigType ls - marker GHC.AnnCloseP - --- -------------------------------------------------------------------- - -instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where - markAST _ (GHC.Var x) = do - setContext (Set.singleton PrefixOp) $ markLocated x - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls - markAST _ (GHC.And ls) = do - markListIntercalateWithFunLevel markLocated 2 ls - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Parens x) = do - mark GHC.AnnOpenP -- '(' - markLocated x - mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where - markAST _l (GHC.UserTyVar _ n) = do - markLocated n - - markAST _ (GHC.KindedTyVar _ n ty) = do - mark GHC.AnnOpenP -- '(' - markLocated n - mark GHC.AnnDcolon -- '::' - markLocated ty - mark GHC.AnnCloseP -- '(' - - markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsType GHC.GhcPs) where - markAST loc ty = do - inContext (Set.fromList [InTypeApp]) $ mark GHC.AnnAt - markType loc ty - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - where - - -- markType :: GHC.SrcSpan -> ast -> Annotated () - markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () - markType _ (GHC.HsForAllTy _ fvf tvs typ) = do - mark GHC.AnnForall - mapM_ markLocated tvs - case fvf of - GHC.ForallInvis -> mark GHC.AnnDot - GHC.ForallVis -> mark GHC.AnnRarrow - markLocated typ - - markType _ (GHC.HsQualTy _ cxt typ) = do - markLocated cxt - markLocated typ - - markType _ (GHC.HsTyVar _ promoted name) = do - when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote - unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name - - markType _ (GHC.HsAppTy _ t1 t2) = do - setContext (Set.singleton PrefixOp) $ markLocated t1 - markLocated t2 - - markType _ (GHC.HsAppKindTy l t k) = do - setContext (Set.singleton PrefixOp) $ markLocated t - markTypeApp l - markLocated k - - markType _ (GHC.HsFunTy _ t1 t2) = do - markLocated t1 - mark GHC.AnnRarrow - markLocated t2 - -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT - - markType _ (GHC.HsListTy _ t) = do - mark GHC.AnnOpenS -- '[' - markLocated t - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsTupleTy _ tt ts) = do - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' - _ -> markWithString GHC.AnnOpen "(#" -- '(#' - markListIntercalateWithFunLevel markLocated 2 ts - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' - _ -> markWithString GHC.AnnClose "#)" -- '#)' - - markType _ (GHC.HsSumTy _ tys) = do - markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys - markWithString GHC.AnnClose "#)" - - markType _ (GHC.HsOpTy _ t1 lo t2) = do - markLocated t1 - if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) - then do - markOptional GHC.AnnSimpleQuote - else do - mark GHC.AnnSimpleQuote - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo - markLocated t2 - - markType _ (GHC.HsParTy _ t) = do - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnCloseP -- ')' - - markType _ (GHC.HsIParamTy _ n t) = do - markLocated n - mark GHC.AnnDcolon - markLocated t - - markType l (GHC.HsStarTy _ isUnicode) = do - if isUnicode - then markExternal l GHC.AnnVal "\x2605" -- Unicode star - else markExternal l GHC.AnnVal "*" - - markType _ (GHC.HsKindSig _ t k) = do - markOptional GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnDcolon -- '::' - markLocated k - markOptional GHC.AnnCloseP -- ')' - - markType l (GHC.HsSpliceTy _ s) = do - markAST l s - - markType _ (GHC.HsDocTy _ t ds) = do - markLocated t - markLocated ds - - markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do - case mt of - GHC.NoSourceText -> return () - GHC.SourceText src -> do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - case str of - GHC.SrcLazy -> mark GHC.AnnTilde - GHC.SrcStrict -> mark GHC.AnnBang - GHC.NoSrcStrict -> return () - - markLocated t - - markType _ (GHC.HsRecTy _ cons) = do - mark GHC.AnnOpenC -- '{' - markListIntercalate cons - mark GHC.AnnCloseC -- '}' - - markType _ (GHC.HsExplicitListTy _ promoted ts) = do - when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote - mark GHC.AnnOpenS -- "[" - markListIntercalate ts - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsExplicitTupleTy _ ts) = do - mark GHC.AnnSimpleQuote - mark GHC.AnnOpenP - markListIntercalate ts - mark GHC.AnnCloseP - - markType l (GHC.HsTyLit _ lit) = do - case lit of - (GHC.HsNumTy s v) -> - markExternalSourceText l s (show v) - (GHC.HsStrTy s v) -> - markExternalSourceText l s (show v) - - markType l (GHC.HsWildCardTy _) = do - markExternal l GHC.AnnVal "_" - - markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x - - --- --------------------------------------------------------------------- - --- instance Annotate (GHC.HsAppType GHC.GhcPs) where --- markAST _ (GHC.HsAppInfix _ n) = do --- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote --- setContext (Set.singleton InfixOp) $ markLocated n --- markAST _ (GHC.HsAppPrefix _ t) = do --- markOptional GHC.AnnTilde --- setContext (Set.singleton PrefixOp) $ markLocated t - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsSplice GHC.GhcPs) where - markAST l c = - case c of - GHC.HsQuasiQuote _ _ n _pos fs -> do - markExternal l GHC.AnnVal - -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") - - GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsTypedSplice _ hasParens _n b -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - -- ------------------------------- - - GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsUntypedSplice _ hasParens _n b -> do - case hasParens of - GHC.HasParens -> mark GHC.AnnOpenPE - GHC.HasDollar -> mark GHC.AnnThIdSplice - GHC.NoParens -> return () - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" - GHC.HsSplicedT{} -> error "HsSplicedT only exists between renamer and typechecker in GHC" - - -- ------------------------------- - - (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDeclField GHC.GhcPs) where - markAST _ (GHC.ConDeclField _ ns ty mdoc) = do - unsetContext Intercalate $ do - markListIntercalate ns - mark GHC.AnnDcolon - markLocated ty - markMaybe mdoc - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FieldOcc GHC.GhcPs) where - markAST _ (GHC.FieldOcc _ rn) = do - markLocated rn - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsDocString where - markAST l s = do - markExternal l GHC.AnnVal (GHC.unpackHDS s) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Pat GHC.GhcPs) where - markAST loc typ = do - markPat loc typ - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") - where - markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" - markPat l (GHC.VarPat _ n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is - -- resolved, particularly for pretty printing where annotations are added. - let pun_RDR = "pun-right-hand-side" - when (showGhc n /= pun_RDR) $ - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) - -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n - markPat _ (GHC.LazyPat _ p) = do - mark GHC.AnnTilde - markLocated p - - markPat _ (GHC.AsPat _ ln p) = do - markLocated ln - mark GHC.AnnAt - markLocated p - - markPat _ (GHC.ParPat _ p) = do - mark GHC.AnnOpenP - markLocated p - mark GHC.AnnCloseP - - markPat _ (GHC.BangPat _ p) = do - mark GHC.AnnBang - markLocated p - - markPat _ (GHC.ListPat _ ps) = do - mark GHC.AnnOpenS - markListIntercalateWithFunLevel markLocated 2 ps - mark GHC.AnnCloseS - - markPat _ (GHC.TuplePat _ pats b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevel markLocated 2 pats - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markPat _ (GHC.SumPat _ pat alt arity) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated pat - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markPat _ (GHC.ConPatIn n dets) = do - markHsConPatDetails n dets - - markPat _ GHC.ConPatOut {} = - traceM "warning: ConPatOut Introduced after renaming" - - markPat _ (GHC.ViewPat _ e pat) = do - markLocated e - mark GHC.AnnRarrow - markLocated pat - - markPat l (GHC.SplicePat _ s) = do - markAST l s - - markPat l (GHC.LitPat _ lp) = markAST l lp - - markPat _ (GHC.NPat _ ol mn _) = do - when (isJust mn) $ mark GHC.AnnMinus - markLocated ol - - markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do - markLocated ln - markWithString GHC.AnnVal "+" -- "+" - markLocated ol - - - markPat _ (GHC.SigPat _ pat ty) = do - markLocated pat - mark GHC.AnnDcolon - markLHsSigWcType ty - - markPat _ GHC.CoPat {} = - traceM "warning: CoPat introduced after renaming" - - -- markPat _ (GHC.XPat (GHC.L l p)) = markPat l p - markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x - --- --------------------------------------------------------------------- - -hsLit2String :: GHC.HsLit GHC.GhcPs -> String -hsLit2String lit = - case lit of - GHC.HsChar src v -> toSourceTextWithSuffix src v "" - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" - GHC.HsString src v -> toSourceTextWithSuffix src v "" - GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" - GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" - GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" - GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" - GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" - (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x - -toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String -toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix - --- -------------------------------------------------------------------- - -markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () -markHsConPatDetails ln dets = do - case dets of - GHC.PrefixCon args -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated args - GHC.RecCon (GHC.HsRecFields fs dd) -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - case dd of - Nothing -> markListIntercalateWithFunLevel markLocated 2 fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- '}' - GHC.InfixCon a1 a2 -> do - markLocated a1 - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln - markLocated a2 - -markHsConDeclDetails :: - Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () - -markHsConDeclDetails isDeprecated inGadt lns dets = do - case dets of - GHC.PrefixCon args -> - setContext (Set.singleton PrefixOp) $ mapM_ markLocated args - -- GHC.RecCon fs -> markLocated fs - GHC.RecCon fs -> do - mark GHC.AnnOpenC - if inGadt - then do - if isDeprecated - then setContext (Set.fromList [InGadt]) $ markLocated fs - else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs - else do - if isDeprecated - then markLocated fs - else setContext (Set.fromList [InRecCon]) $ markLocated fs - GHC.InfixCon a1 a2 -> do - markLocated a1 - setContext (Set.singleton InfixOp) $ mapM_ markLocated lns - markLocated a2 - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LConDeclField GHC.GhcPs] where - markAST _ fs = do - markOptional GHC.AnnOpenC -- '{' - markListIntercalate fs - markOptional GHC.AnnDotdot - inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' - inContext (Set.singleton InGadt) $ do - mark GHC.AnnRarrow - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsOverLit GHC.GhcPs) where - markAST l ol = - let str = case GHC.ol_val ol of - GHC.HsIntegral (GHC.IL src _ _) -> src - GHC.HsFractional (GHC.FL src _ _) -> src - GHC.HsIsString src _ -> src - in - markExternalSourceText l str "" - --- --------------------------------------------------------------------- - -instance (Annotate arg) - => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where - markAST _ (GHC.HsIB _ thing) = do - markLocated thing - markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.LastStmt _ body _ _) - = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - markAST _ (GHC.BindStmt _ pat body _ _) = do - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat - mark GHC.AnnLarrow - unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST _ GHC.ApplicativeStmt{} - = error "ApplicativeStmt should not appear in ParsedSource" - - markAST _ (GHC.BodyStmt _ body _ _) = do - unsetContext Intercalate $ markLocated body - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST l (GHC.ParStmt _ pbs _ _) = do - -- Within a given parallel list comprehension,one of the sections to be done - -- in parallel. It is a normal list comprehension, so has a list of - -- ParStmtBlock, one for each part of the sub- list comprehension - - - ifInContext (Set.singleton Intercalate) - ( - - unsetContext Intercalate $ - markListWithContextsFunction - (LC (Set.singleton Intercalate) -- only - Set.empty -- first - Set.empty -- middle - (Set.singleton Intercalate) -- last - ) (markAST l) pbs - ) - ( - unsetContext Intercalate $ - markListWithContextsFunction - (LC Set.empty -- only - (Set.fromList [AddVbar]) -- first - (Set.fromList [AddVbar]) -- middle - Set.empty -- last - ) (markAST l) pbs - ) - markTrailingSemi - - markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do - setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts - case form of - GHC.ThenForm -> do - mark GHC.AnnThen - unsetContext Intercalate $ markLocated using - case by of - Just b -> do - mark GHC.AnnBy - unsetContext Intercalate $ markLocated b - Nothing -> return () - GHC.GroupForm -> do - mark GHC.AnnThen - mark GHC.AnnGroup - case by of - Just b -> mark GHC.AnnBy >> markLocated b - Nothing -> return () - mark GHC.AnnUsing - markLocated using - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do - mark GHC.AnnRec - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - markListWithLayout stmts - markOptional GHC.AnnCloseC - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- Note: We never have a located ParStmtBlock, so have nothing to hang the --- annotation on. This means there is no pushing of context from the parent ParStmt. -instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where - markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do - markListIntercalate stmts - markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where - markAST _ lb = markHsLocalBinds lb - --- --------------------------------------------------------------------- - -markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) = - applyListAnnotationsLayout - (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ) -markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds -markHsLocalBinds GHC.EmptyLocalBinds{} = return () - -markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension" -markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension" -markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension" - --- --------------------------------------------------------------------- - -markMatchGroup :: (Annotate body) - => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) - -> Annotated () -markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _) - = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsExpr GHC.GhcPs) where - markAST loc expr = do - markExpr loc expr - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - -- TODO: If the AnnComma is not needed, revert to markAST - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - where - markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do - ifInContext (Set.singleton PrefixOp) - (setContext (Set.singleton PrefixOp) $ markLocated n) - (ifInContext (Set.singleton InfixOp) - (setContext (Set.singleton InfixOp) $ markLocated n) - (markLocated n) - ) - - markExpr l (GHC.HsUnboundVar {}) = do - ifInContext (Set.fromList [InfixOp]) - (do mark GHC.AnnBackquote - markWithString GHC.AnnVal "_" - mark GHC.AnnBackquote) - (markExternal l GHC.AnnVal "_") - - markExpr l (GHC.HsRecFld _ f) = markAST l f - - markExpr l (GHC.HsOverLabel _ _ fs) - = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) - - - markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) = - markAST l n - markExpr l (GHC.HsOverLit _ ov) = markAST l ov - markExpr l (GHC.HsLit _ lit) = markAST l lit - - markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do - setContext (Set.singleton LambdaExpr) $ do - -- TODO: Change this, HsLam binds do not need obey layout rules. - -- And will only ever have a single match - markLocated match - markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match" - - markExpr l (GHC.HsLamCase _ match) = do - mark GHC.AnnLam - mark GHC.AnnCase - markOptional GHC.AnnSemi - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l match - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsApp _ e1 e2) = do - setContext (Set.singleton PrefixOp) $ markLocated e1 - setContext (Set.singleton PrefixOp) $ markLocated e2 - - -- ------------------------------- - - markExpr _ (GHC.OpApp _ e1 e2 e3) = do - let - isInfix = case e2 of - -- TODO: generalise this. Is it a fixity thing? - GHC.L _ (GHC.HsVar{}) -> True - _ -> False - - normal = - -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context - ifInContext (Set.singleton LeftMost) - (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) - (markLocated e1) - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - else normal - - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 - else markLocated e3 - - -- ------------------------------- - - markExpr _ (GHC.NegApp _ e _) = do - mark GHC.AnnMinus - markLocated e - - markExpr _ (GHC.HsPar _ e) = do - mark GHC.AnnOpenP -- '(' - markLocated e - mark GHC.AnnCloseP -- ')' - - markExpr _ (GHC.SectionL _ e1 e2) = do - markLocated e1 - setContext (Set.singleton InfixOp) $ markLocated e2 - - markExpr _ (GHC.SectionR _ e1 e2) = do - setContext (Set.singleton InfixOp) $ markLocated e1 - markLocated e2 - - markExpr _ (GHC.ExplicitTuple _ args b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args - - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markExpr _ (GHC.ExplicitSum _ alt arity e) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated e - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do - mark GHC.AnnCase - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - setContext (Set.singleton CaseAlt) $ markMatchGroup l matches - markOptional GHC.AnnCloseC - - -- We set the layout for HsIf even though it need not obey layout rules as - -- when moving these expressions it's useful that they maintain "internal - -- integrity", that is to say the subparts remain indented relative to each - -- other. - markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do - -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do - mark GHC.AnnIf - markLocated e1 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen - mark GHC.AnnThen - setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse - mark GHC.AnnElse - setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 - - markExpr _ (GHC.HsMultiIf _ rhs) = do - mark GHC.AnnIf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - -- mapM_ markLocated rhs - markListWithLayout rhs - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do - setLayoutFlag (do -- Make sure the 'in' gets indented too - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e) - - -- ------------------------------- - - markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do - case cts of - GHC.DoExpr -> mark GHC.AnnDo - GHC.MDoExpr -> mark GHC.AnnMdo - _ -> return () - let (ostr,cstr) = - if isListComp cts - then ("[", "]") - else ("{", "}") - - when (isListComp cts) $ markWithString GHC.AnnOpen ostr - markOptional GHC.AnnOpenS - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - if isListComp cts - then do - markLocated (last es) - mark GHC.AnnVbar - setLayoutFlag (markListIntercalate (init es)) - else do - markListWithLayout es - markOptional GHC.AnnCloseS - markOptional GHC.AnnCloseC - when (isListComp cts) $ markWithString GHC.AnnClose cstr - - -- ------------------------------- - - markExpr _ (GHC.ExplicitList _ _ es) = do - mark GHC.AnnOpenS - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es - mark GHC.AnnCloseS - - markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do - markLocated n - mark GHC.AnnOpenC - case dd of - Nothing -> markListIntercalate fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC - - markExpr _ (GHC.RecordUpd _ e fs) = do - markLocated e - mark GHC.AnnOpenC - markListIntercalate fs - mark GHC.AnnCloseC - - markExpr _ (GHC.ExprWithTySig _ e typ) = do - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e - mark GHC.AnnDcolon - markLHsSigWcType typ - - markExpr _ (GHC.ArithSeq _ _ seqInfo) = do - mark GHC.AnnOpenS -- '[' - case seqInfo of - GHC.From e -> do - markLocated e - mark GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - markLocated e1 - mark GHC.AnnDotdot - markLocated e2 - GHC.FromThen e1 e2 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - markLocated e3 - mark GHC.AnnCloseS -- ']' - - markExpr _ (GHC.HsSCC _ src csFStr e) = do - markAnnOpen src "{-# SCC" - let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - markWithStringOptional GHC.AnnVal txt - markWithString GHC.AnnValStr txt - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do - -- markWithString GHC.AnnOpen src -- "{-# CORE" - markAnnOpen src "{-# CORE" - -- markWithString GHC.AnnVal (GHC.sl_st csFStr) - markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - markWithString GHC.AnnClose "#-}" - markLocated e - -- TODO: make monomorphic - markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do - mark GHC.AnnSimpleQuote - setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do - mark GHC.AnnThTyQuote - markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do - markWithString GHC.AnnOpen "[d|" - markOptional GHC.AnnOpenC - setContext (Set.singleton NoAdvanceLine) - $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds - markOptional GHC.AnnCloseC - mark GHC.AnnCloseQ -- "|]" - -- Introduced after the renamer - markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) = - traceM "warning: DecBrG introduced after renamer" - markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do - mark GHC.AnnOpenEQ -- "[|" - markOptional GHC.AnnOpenE -- "[e|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do - markWithString GHC.AnnOpen "[||" - markWithStringOptional GHC.AnnOpenE "[e||" - markLocated e - markWithString GHC.AnnClose "||]" - markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do - markWithString GHC.AnnOpen "[t|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do - markWithString GHC.AnnOpen "[p|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - - markExpr _ (GHC.HsRnBracketOut {}) = - traceM "warning: HsRnBracketOut introduced after renamer" - markExpr _ (GHC.HsTcBracketOut {}) = - traceM "warning: HsTcBracketOut introduced after renamer" - - markExpr l (GHC.HsSpliceE _ e) = markAST l e - - markExpr _ (GHC.HsProc _ p c) = do - mark GHC.AnnProc - markLocated p - mark GHC.AnnRarrow - markLocated c - - markExpr _ (GHC.HsStatic _ e) = do - mark GHC.AnnStatic - markLocated e - - -- markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do - -- -- isRightToLeft True => right-to-left (f -< arg) - -- -- False => left-to-right (arg >- f) - -- if isRightToLeft - -- then do - -- markLocated e1 - -- case o of - -- GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - -- GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - -- else do - -- markLocated e2 - -- case o of - -- GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - -- GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - -- if isRightToLeft - -- then markLocated e2 - -- else markLocated e1 - - -- markExpr _ (GHC.HsArrForm _ e _ cs) = do - -- markWithString GHC.AnnOpenB "(|" - -- markLocated e - -- mapM_ markLocated cs - -- markWithString GHC.AnnCloseB "|)" - - markExpr _ (GHC.HsTick {}) = return () - markExpr _ (GHC.HsBinTick {}) = return () - - markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markAnnOpen src "{-# GENERATED" - markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING - - let - markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) - markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s - - markOne 1 v1 s1 -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOne 2 v2 s2 -- INTEGER - mark GHC.AnnMinus -- '-' - markOne 3 v3 s3 -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOne 4 v4 s4 -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e - - -- markExpr _ (GHC.EAsPat _ ln e) = do - -- markLocated ln - -- mark GHC.AnnAt - -- markLocated e - - -- markExpr _ (GHC.EViewPat _ e1 e2) = do - -- markLocated e1 - -- mark GHC.AnnRarrow - -- markLocated e2 - - -- markExpr _ (GHC.ELazyPat _ e) = do - -- mark GHC.AnnTilde - -- markLocated e - - markExpr _ (GHC.HsAppType _ e ty) = do - markLocated e - markInstead GHC.AnnAt AnnTypeApp - markLHsWcType ty - - markExpr _ (GHC.HsWrap {}) = - traceM "warning: HsWrap introduced after renaming" - - markExpr _ (GHC.HsConLikeOut{}) = - traceM "warning: HsConLikeOut introduced after type checking" - - markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension" - markExpr _ (GHC.XExpr _) = error "markExpr got extension" - --- --------------------------------------------------------------------- - -markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () -markLHsWcType (GHC.HsWC _ ty) = do - markLocated ty -markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLit GHC.GhcPs) where - markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where - markAST _ (GHC.HsRecField lbl expr punFlag) = do - unsetContext Intercalate $ markLocated lbl - when (punFlag == False) $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated expr - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - -instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where - markAST _ (GHC.Unambiguous _ n) = markLocated n - markAST _ (GHC.Ambiguous _ n) = markLocated n - markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- |Used for declarations that need to be aligned together, e.g. in a --- do or let .. in statement/expr -instance Annotate [GHC.ExprLStmt GHC.GhcPs] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTupArg GHC.GhcPs) where - markAST _ (GHC.Present _ (GHC.L l e)) = do - markLocated (GHC.L l e) - inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) - - markAST _ (GHC.Missing _) = do - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsCmdTop GHC.GhcPs) where - markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd - markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x - -instance Annotate (GHC.HsCmd GHC.GhcPs) where - markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do - -- The AnnOpen should be marked for a prefix usage, not for a postfix one, - -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm - - let isPrefixOp = case fixity of - GHC.Infix -> False - GHC.Prefix -> True - when isPrefixOp $ mark GHC.AnnOpenB -- "(|" - - -- This may be an infix operation - applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) - (Set.singleton InfixOp) (Set.singleton InfixOp)) - (prepareListAnnotation [e] - ++ prepareListAnnotation cs) - when isPrefixOp $ mark GHC.AnnCloseB -- "|)" - - markAST _ (GHC.HsCmdApp _ e1 e2) = do - markLocated e1 - markLocated e2 - - markAST l (GHC.HsCmdLam _ match) = do - setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match - - markAST _ (GHC.HsCmdPar _ e) = do - mark GHC.AnnOpenP - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsCmdCase _ e1 matches) = do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l matches - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do - mark GHC.AnnIf - markLocated e1 - markOffset GHC.AnnSemi 0 - mark GHC.AnnThen - markLocated e2 - markOffset GHC.AnnSemi 1 - mark GHC.AnnElse - markLocated e3 - - markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e - - markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do - mark GHC.AnnDo - markOptional GHC.AnnOpenC - markListWithLayout es - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdWrap {}) = - traceM "warning: HsCmdWrap introduced after renaming" - - markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyClDecl GHC.GhcPs) where - - markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi -{- - SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs - , tcdLName :: Located (IdP pass) -- ^ Type constructor - , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an - -- associated type these - -- include outer binders - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType pass } -- ^ RHS of type declaration - --} - markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do - -- There may be arbitrary parens around parts of the constructor that are - -- infix. - -- Turn these into comments so that they feed into the right place automatically - -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - mark GHC.AnnType - - markTyClass Nothing fixity ln tyvars - mark GHC.AnnEqual - markLocated typ - markTrailingSemi - - markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity - (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do - if nd == GHC.DataType - then mark GHC.AnnData - else mark GHC.AnnNewtype - markMaybe mctyp - markLocated ctx - markTyClass Nothing fixity ln tyVars - case mk of - Nothing -> return () - Just k -> do - mark GHC.AnnDcolon - markLocated k - if isGadt cons - then mark GHC.AnnWhere - else unless (null cons) $ mark GHC.AnnEqual - markOptional GHC.AnnWhere - markOptional GHC.AnnOpenC - setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts cons - markOptional GHC.AnnCloseC - setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds - sigs meths ats atdefs docs) = do - mark GHC.AnnClass - markLocated ctx - - markTyClass Nothing fixity ln tyVars - - unless (null fds) $ do - mark GHC.AnnVbar - markListIntercalateWithFunLevel markLocated 2 fds - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - -- AZ:TODO: we end up with both the tyVars and the following body of the - -- class defn in annSortKey for the class. This could cause problems when - -- changing things. - setContext (Set.singleton InClassDecl) $ - applyListAnnotationsLayout - (prepareListAnnotation sigs - ++ prepareListAnnotation (GHC.bagToList meths) - ++ prepareListAnnotation ats - ++ prepareListAnnotation atdefs - ++ prepareListAnnotation docs - ) - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi -{- - | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdCtxt :: LHsContext pass, -- ^ Context... - tcdLName :: Located (IdP pass), -- ^ Name of the class - tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables - tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [Located (FunDep (Located (IdP pass)))], - -- ^ Functional deps - tcdSigs :: [LSig pass], -- ^ Methods' signatures - tcdMeths :: LHsBinds pass, -- ^ Default methods - tcdATs :: [LFamilyDecl pass], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn pass], - -- ^ Associated type defaults - tcdDocs :: [LDocDecl] -- ^ Haddock docs - } - --} - - markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) - = error "extension hit for TyClDecl" - markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.XTyClDecl _) - = error "extension hit for TyClDecl" - --- --------------------------------------------------------------------- - -markTypeApp :: GHC.SrcSpan -> Annotated () -markTypeApp loc = do - let l = GHC.srcSpanFirstCharacter loc - markExternal l GHC.AnnVal "@" - --- --------------------------------------------------------------------- - -markTyClassArgs :: (Annotate a) - => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity - -- -> GHC.Located a -> [ast] -> Annotated () - -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated () -markTyClassArgs mbndrs fixity ln tyVars = do - let - cvt (GHC.HsValArg val) = markLocated val - cvt (GHC.HsTypeArg loc typ) = do - markTypeApp loc - -- let l = GHC.srcSpanFirstCharacter loc - -- markExternal l GHC.AnnVal "@" - markLocated typ - cvt (GHC.HsArgPar _ss) = undefined - markTyClassWorker cvt mbndrs fixity ln tyVars - {- -type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) - -data HsArg tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg ty -- Argument is a visible type application (f @ty) - | HsArgPar SrcSpan -- See Note [HsArgPar] --} - --- TODO:AZ: simplify -markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, Annotate ast,GHC.HasSrcSpan ast) - => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity - -> GHC.Located a -> [ast] -> Annotated () -markTyClass = markTyClassWorker markLocated - -markTyClassWorker :: (Annotate a) - => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity - -- -> GHC.Located a -> [ast] -> Annotated () - -> GHC.Located a -> [b] -> Annotated () -markTyClassWorker markFn mbndrs fixity ln tyVars = do - let processBinders = - case mbndrs of - Nothing -> return () - Just bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - -- There may be arbitrary parens around parts of the constructor - -- Turn these into comments so that they feed into the right place automatically - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - let markParens = if fixity == GHC.Infix && length tyVars > 2 - then markMany - else markManyOptional - if fixity == GHC.Prefix - then do - markManyOptional GHC.AnnOpenP - processBinders - setContext (Set.singleton PrefixOp) $ markLocated ln - -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars - setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars - when (length tyVars >= 2) $ do - markParens GHC.AnnCloseP - setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars - markManyOptional GHC.AnnCloseP - else do - case tyVars of - (x:y:xs) -> do - markParens GHC.AnnOpenP - processBinders - markFn x - setContext (Set.singleton InfixOp) $ markLocated ln - markFn y - markParens GHC.AnnCloseP - mapM_ markFn xs - markManyOptional GHC.AnnCloseP - _ -> error $ "markTyClass: Infix op without operands" - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where - markAST _ ds = mapM_ markLocated ds - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where - markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do - mark GHC.AnnDeriving - case mstrategy of - Nothing -> return () - Just (GHC.L _ (GHC.ViaStrategy{})) -> return () - Just s -> markLocated s - markLocated typs - case mstrategy of - Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s - _ -> return () - - markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x - -{- - = HsDerivingClause - { deriv_clause_ext :: XCHsDerivingClause pass - , deriv_clause_strategy :: Maybe (LDerivStrategy pass) - -- ^ The user-specified strategy (if any) to use when deriving - -- 'deriv_clause_tys'. - , deriv_clause_tys :: Located [LHsSigType pass] - -- ^ The types to derive. - -- - -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, - -- we can mention type variables that aren't bound by the datatype, e.g. - -- - -- > data T b = ... deriving (C [a]) - -- - -- should produce a derived instance for @C [a] (T b)@. - } - --} - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyDecl GHC.GhcPs) where - markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do - case info of - GHC.DataFamily -> mark GHC.AnnData - _ -> mark GHC.AnnType - - mark GHC.AnnFamily - - markTyClass Nothing fixity ln tyvars - case GHC.unLoc rsig of - GHC.NoSig _ -> return () - GHC.KindSig _ _ -> do - mark GHC.AnnDcolon - markLocated rsig - GHC.TyVarSig _ _ -> do - mark GHC.AnnEqual - markLocated rsig - (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x - case minj of - Nothing -> return () - Just inj -> do - mark GHC.AnnVbar - markLocated inj - case info of - GHC.ClosedTypeFamily (Just eqns) -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- { - markListWithLayout eqns - markOptional GHC.AnnCloseC -- } - GHC.ClosedTypeFamily Nothing -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- { - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- } - _ -> return () - markTrailingSemi - - markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _) - = error "got extension for FamilyDecl" - markAST _ (GHC.XFamilyDecl _) - = error "got extension for FamilyDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where - markAST _ (GHC.NoSig _) = return () - markAST _ (GHC.KindSig _ k) = markLocated k - markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv - markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where - markAST _ (GHC.InjectivityAnn ln lns) = do - markLocated ln - mark GHC.AnnRarrow - mapM_ markLocated lns - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where -{- -type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) - -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) - -type HsTyPats pass = [LHsTypeArg pass] - --} - markAST _ (GHC.HsIB _ eqn) = do - markFamEqn eqn - markTrailingSemi - markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where - --- markAST _ (GHC.FamEqn _ ln mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do --- mark GHC.AnnType --- mark GHC.AnnInstance --- markTyClass mbndrs fixity ln bndrs --- mark GHC.AnnEqual --- markLocated typ - - -- markAST _ (GHC.FamEqn _ _ _ (GHC.XLHsQTyVars _) _ _) - -- = error "TyFamDefltEqn hit extension point" - -- markAST _ (GHC.XFamEqn _) - -- = error "TyFamDefltEqn hit extension point" - --- --------------------------------------------------------------------- - --- TODO: modify lexer etc, in the meantime to not set haddock flag -instance Annotate GHC.DocDecl where - markAST l v = - let str = - case v of - (GHC.DocCommentNext ds) -> GHC.unpackHDS ds - (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds - (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds - (GHC.DocGroup _i ds) -> GHC.unpackHDS ds - in - markExternal l GHC.AnnVal str >> markTrailingSemi -{- -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - --} - --- --------------------------------------------------------------------- - -markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () -markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do - markLocated ctx - markMaybe typ - if isGadt cons - then markListWithLayout cons - else markListIntercalateWithFunLevel markLocated 2 cons - setContext (Set.singleton Deriving) $ markLocated derivs -markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance Annotate [GHC.LHsType GHC.GhcPs] where - markAST l ts = do - -- Note: A single item in parens in a standalone deriving clause - -- is parsed as a HsSigType, which is always a HsForAllTy or - -- HsQualTy. Without parens it is always a HsVar. So for round - -- trip pretty printing we need to take this into account. - let - parenIfNeeded' pa = - case ts of - [] -> if l == GHC.noSrcSpan - then markManyOptional pa - else markMany pa - [GHC.L _ GHC.HsForAllTy{}] -> markMany pa - [GHC.L _ GHC.HsQualTy{}] -> markMany pa - [_] -> markManyOptional pa - _ -> markMany pa - - parenIfNeeded'' pa = - ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set? - (markMany pa) - (parenIfNeeded' pa) - - parenIfNeeded pa = - case ts of - [GHC.L _ GHC.HsParTy{}] -> markOptional pa - _ -> parenIfNeeded'' pa - - -- ------------- - - parenIfNeeded GHC.AnnOpenP - - unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts - - parenIfNeeded GHC.AnnCloseP - - ifInContext (Set.singleton NoDarrow) - (return ()) - (if null ts && (l == GHC.noSrcSpan) - then markOptional GHC.AnnDarrow - else mark GHC.AnnDarrow) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDecl GHC.GhcPs) where - markAST _ (GHC.ConDeclH98 _ ln (GHC.L _ fa) mqtvs mctx - dets _) = do - when fa $ do - mark GHC.AnnForall - mapM_ markLocated mqtvs - mark GHC.AnnDot - - case mctx of - Just ctx -> do - setContext (Set.fromList [NoDarrow]) $ markLocated ctx - mark GHC.AnnDarrow - Nothing -> return () - - case dets of - GHC.InfixCon _ _ -> return () - _ -> setContext (Set.singleton PrefixOp) $ markLocated ln - - markHsConDeclDetails False False [ln] dets - - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar - markTrailingSemi -{- - | ConDeclH98 - { con_ext :: XConDeclH98 pass - , con_name :: Located (IdP pass) - - , con_forall :: Bool -- ^ True <=> explicit user-written forall - -- e.g. data T a = forall b. MkT b (b->a) - -- con_ex_tvs = {b} - -- False => con_ex_tvs is empty - , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - --} - markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - annotationsToComments [GHC.AnnOpenP] - markLocated (GHC.L l (ResTyGADTHook forall qvars)) - markMaybe mbCxt - markHsConDeclDetails False True lns args - markLocated typ - markManyOptional GHC.AnnCloseP - markTrailingSemi -{- - = ConDeclGADT - { con_g_ext :: XConDeclGADT pass - , con_names :: [Located (IdP pass)] - - -- The next four fields describe the type after the '::' - -- See Note [GADT abstract syntax] - , con_forall :: Located Bool -- ^ True <=> explicit forall - -- False => hsq_explicit is empty - , con_qvars :: LHsQTyVars pass - -- Whether or not there is an /explicit/ forall, we still - -- need to capture the implicitly-bound type/kind variables - - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon - , con_res_ty :: LHsType pass -- ^ Result type - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - --} - - markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _) - = error "hit extension point in ConDecl" - markAST _ (GHC.XConDecl _) - = error "hit extension point in ConDecl" - --- ResTyGADT has a SrcSpan for the original sigtype, we need to create --- a type for exactPC and annotatePC -data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs] - deriving (Typeable) -deriving instance Data (ResTyGADTHook) - -instance GHC.Outputable ResTyGADTHook where - ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs - - --- WildCardAnon exists because the GHC anonymous wildcard type is defined as --- = AnonWildCard (PostRn name Name) --- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but --- the instance doing this is parameterised on name, so we cannot put a value in --- for the (PostRn name Name) field. This is used instead. -data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable) - -instance Annotate WildCardAnon where - markAST l WildCardAnon = do - markExternal l GHC.AnnVal "_" - --- --------------------------------------------------------------------- - -instance Annotate ResTyGADTHook where - markAST _ (ResTyGADTHook forall bndrs) = do - when forall $ mark GHC.AnnForall - mapM_ markLocated bndrs - when forall $ mark GHC.AnnDot - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.Located (GHC.Pat GHC.GhcPs))) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - --- instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where --- markAST _ (GHC.HsRecField n e punFlag) = do --- unsetContext Intercalate $ markLocated n --- unless punFlag $ do --- mark GHC.AnnEqual --- unsetContext Intercalate $ markLocated e --- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - - markAST _ (ls,rs') = do - mapM_ markLocated ls - mark GHC.AnnRarrow - mapM_ markLocated rs' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate GHC.CType where - markAST _ (GHC.CType src mh f) = do - -- markWithString GHC.AnnOpen src - markAnnOpen src "" - case mh of - Nothing -> return () - Just (GHC.Header srcH _h) -> - -- markWithString GHC.AnnHeader srcH - markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") - -- markWithString GHC.AnnVal (fst f) - markSourceText (fst f) (GHC.unpackFS $ snd f) - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -stringLiteralToString :: GHC.StringLiteral -> String -stringLiteralToString (GHC.StringLiteral st fs) = - case st of - GHC.NoSourceText -> GHC.unpackFS fs - GHC.SourceText src -> src diff --git a/src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs deleted file mode 100644 --- a/src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2662 +0,0 @@ -{-# 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 _ s -> do - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do - when (s == GHC.SrcStrict) $ mark GHC.AnnBang - markLocated n - mapM_ markLocated pats - _ -> markListNoPrecedingSpace False pats - - -- TODO: The AnnEqual annotation actually belongs in the first GRHS value - case grhs of - (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards - _ -> return () - inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam - mapM_ markLocated grhs - - case lb of - GHC.EmptyLocalBinds -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -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 - markInstead GHC.AnnAt AnnTypeApp - 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-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs deleted file mode 100644 --- a/src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2606 +0,0 @@ -{-# 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.GhcPs) of - Just d -> markLHsDecl d - Nothing -> withLocated ast markAST - --- --------------------------------------------------------------------- - --- |When adding missing annotations, do not put a preceding space in front of a list -markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () -markListNoPrecedingSpace intercal ls = - case ls of - [] -> return () - (l:ls') -> do - if intercal - then do - if null ls' - then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l - else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l - markListIntercalate ls' - else do - setContext (Set.singleton NoPrecedingSpace) $ markLocated l - mapM_ markLocated ls' - --- --------------------------------------------------------------------- - - --- |Mark a list, with the given keyword as a list item separator -markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () -markListIntercalate ls = markListIntercalateWithFun markLocated ls - --- --------------------------------------------------------------------- - -markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () -markListWithContexts ctxInitial ctxRest ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxInitial 2 $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial 2 $ markLocated x - setContextLevel ctxRest 2 $ mapM_ markLocated xs - --- --------------------------------------------------------------------- - --- Context for only if just one, else first item, middle ones, and last one -markListWithContexts' :: Annotate ast - => ListContexts - -> [GHC.Located ast] -> Annotated () -markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxOnly level $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial level $ markLocated x - go xs - where - level = 2 - go [] = return () - go [x] = setContextLevel ctxLast level $ markLocated x - go (x:xs) = do - setContextLevel ctxMiddle level $ markLocated x - go xs - - --- --------------------------------------------------------------------- - -markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () -markListWithLayout ls = - setLayoutFlag $ markList ls - --- --------------------------------------------------------------------- - -markList :: Annotate ast => [GHC.Located ast] -> Annotated () -markList ls = - setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts' ls - -markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markLocalBindsWithLayout binds = markHsLocalBinds binds - --- --------------------------------------------------------------------- - --- |This function is used to get around shortcomings in the GHC AST for 7.10.1 -markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () -markLocatedFromKw kw (GHC.L l a) = do - -- Note: l is needed so that the pretty printer can make something up - ss <- getSrcSpanForKw l kw - AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) - markLocated (GHC.L ss' a) - --- --------------------------------------------------------------------- - -markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () -markMaybe Nothing = return () -markMaybe (Just ast) = markLocated ast - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] -prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsModule GHC.GhcPs) where - markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do - - case mmn of - Nothing -> return () - Just (GHC.L ln mn) -> do - mark GHC.AnnModule - markExternal ln GHC.AnnVal (GHC.moduleNameString mn) - - forM_ mdepr markLocated - forM_ mexp markLocated - - mark GHC.AnnWhere - - markOptional GHC.AnnOpenC -- Possible '{' - markManyOptional GHC.AnnSemi -- possible leading semis - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps - - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs - - markOptional GHC.AnnCloseC -- Possible '}' - - markEOF - --- --------------------------------------------------------------------- - -instance Annotate GHC.WarningTxt where - markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# WARNING" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# DEPRECATED" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate GHC.StringLiteral where - markAST l (GHC.StringLiteral src fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SourceText,GHC.FastString) where - markAST l (src,fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LIE GHC.GhcPs] where - markAST _ ls = do - inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl - mark GHC.AnnOpenP -- '(' - -- Can't use markListIntercalate, there can be trailing commas, but only in imports. - markListIntercalateWithFunLevel markLocated 2 ls - - mark GHC.AnnCloseP -- ')' - -instance Annotate (GHC.IE GHC.GhcPs) where - markAST _ ie = do - - case ie of - GHC.IEVar ln -> markLocated ln - - GHC.IEThingAbs ln -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - - GHC.IEThingWith ln wc ns _lfs -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnOpenP - case wc of - GHC.NoIEWildcard -> - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns - GHC.IEWildcard n -> do - setContext (Set.fromList [PrefixOp,Intercalate]) - $ mapM_ markLocated (take n ns) - mark GHC.AnnDotdot - case drop n ns of - [] -> return () - ns' -> do - mark GHC.AnnComma - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns' - mark GHC.AnnCloseP - - (GHC.IEThingAll ln) -> do - setContext (Set.fromList [PrefixOp]) $ markLocated ln - mark GHC.AnnOpenP - mark GHC.AnnDotdot - mark GHC.AnnCloseP - - (GHC.IEModuleContents (GHC.L lm mn)) -> do - mark GHC.AnnModule - markExternal lm GHC.AnnVal (GHC.moduleNameString mn) - - -- Only used in Haddock mode so we can ignore them. - (GHC.IEGroup _ _) -> return () - - (GHC.IEDoc _) -> return () - - (GHC.IEDocNamed _) -> return () - ifInContext (Set.fromList [Intercalate]) - (mark GHC.AnnComma) - (markOptional GHC.AnnComma) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IEWrappedName GHC.RdrName) where - markAST _ (GHC.IEName ln) = do - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEPattern ln) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEType ln) = do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -isSymRdr :: GHC.RdrName -> Bool -isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." - -instance Annotate GHC.RdrName where - markAST l n = do - let - str = rdrName2String n - isSym = isSymRdr n - canParen = isSym - doNormalRdrName = do - let str' = case str of - -- TODO: unicode support? - "forall" -> if spanLength l == 1 then "∀" else str - _ -> str - - let - markParen :: GHC.AnnKeywordId -> Annotated () - markParen pa = do - if canParen - then ifInContext (Set.singleton PrefixOp) - (mark pa) -- '(' - (markOptional pa) - else if isSym - then ifInContext (Set.singleton PrefixOpDollar) - (mark pa) - (markOptional pa) - else markOptional pa - - 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") - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ImportDecl GHC.GhcPs) where - markAST _ imp@(GHC.ImportDecl msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do - - -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - mark GHC.AnnImport - - -- "{-# SOURCE" and "#-}" - case msrc of - GHC.SourceText _txt -> do - markAnnOpen msrc "{-# SOURCE" - markWithString GHC.AnnClose "#-}" - GHC.NoSourceText -> return () - when safeflag (mark GHC.AnnSafe) - when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) - case mpkg of - Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> - markWithString GHC.AnnPackageName srcPkg - _ -> return () - - markLocated modname - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - mark GHC.AnnAs - markLocated mn - - case hiding of - Nothing -> return () - Just (isHiding,lie) -> do - if isHiding - then setContext (Set.singleton HasHiding) $ - markLocated lie - else markLocated lie - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate GHC.ModuleName where - markAST l mname = - markExternal l GHC.AnnVal (GHC.moduleNameString mname) - --- --------------------------------------------------------------------- - -markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () -markLHsDecl (GHC.L l decl) = - case decl of - GHC.TyClD d -> markLocated (GHC.L l d) - GHC.InstD d -> markLocated (GHC.L l d) - GHC.DerivD d -> markLocated (GHC.L l d) - GHC.ValD d -> markLocated (GHC.L l d) - GHC.SigD d -> markLocated (GHC.L l d) - GHC.DefD d -> markLocated (GHC.L l d) - GHC.ForD d -> markLocated (GHC.L l d) - GHC.WarningD d -> markLocated (GHC.L l d) - GHC.AnnD d -> markLocated (GHC.L l d) - GHC.RuleD d -> markLocated (GHC.L l d) - GHC.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.GhcPs) where - markAST l d = markLHsDecl (GHC.L l d) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where - markAST _ (GHC.RoleAnnotDecl ln mr) = do - mark GHC.AnnType - mark GHC.AnnRole - markLocated ln - mapM_ markLocated mr - -instance Annotate (Maybe GHC.Role) where - markAST l Nothing = markExternal l GHC.AnnVal "_" - markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SpliceDecl GHC.GhcPs) where - markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do - markLocated e - markTrailingSemi - markAST _ (GHC.SpliceDecl e _flag) = do - markLocated e - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.VectDecl GHC.GhcPs) 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.GhcPs) where - markAST _ (GHC.HsRules src rules) = do - markAnnOpen src "{-# RULES" - setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecl GHC.GhcPs) where - markAST l (GHC.HsRule ln act 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.GhcPs) where - markAST _ (GHC.RuleBndr ln) = markLocated ln - markAST _ (GHC.RuleBndrSig ln st) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLHsSigWcType st - mark GHC.AnnCloseP -- ")" - --- --------------------------------------------------------------------- - -markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () -markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty _)) = do - markLocated ty - --- --------------------------------------------------------------------- - -instance Annotate (GHC.AnnDecl GHC.GhcPs) where - markAST _ (GHC.HsAnnotation src prov e) = do - markAnnOpen src "{-# ANN" - case prov of - (GHC.ValueAnnProvenance n) -> markLocated n - (GHC.TypeAnnProvenance n) -> do - mark GHC.AnnType - markLocated n - GHC.ModuleAnnProvenance -> mark GHC.AnnModule - - markLocated e - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecls GHC.GhcPs) where - markAST _ (GHC.Warnings src warns) = do - markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED - mapM_ markLocated warns - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecl GHC.GhcPs) where - markAST _ (GHC.Warning lns txt) = do - markListIntercalate lns - mark GHC.AnnOpenS -- "[" - case txt of - GHC.WarningTxt _src ls -> markListIntercalate ls - GHC.DeprecatedTxt _src ls -> markListIntercalate ls - mark GHC.AnnCloseS -- "]" - -instance Annotate GHC.FastString where - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - markAST l fs = do - markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ForeignDecl GHC.GhcPs) where - markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ _) _ - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnImport - markLocated cconv - unless (ll == GHC.noSrcSpan) $ markLocated safety - markExternalSourceText ls src "" - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - - markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ _) _ (GHC.CExport spec (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnExport - markLocated spec - markExternal ls GHC.AnnVal (sourceTextToString src "") - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLocated typ - - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CExportSpec) where - markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CCallConv) where - markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" - markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" - markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" - markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" - markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.Safety) where - markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" - markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" - markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivDecl GHC.GhcPs) where - - markAST _ (GHC.DerivDecl typ ms mov) = do - mark GHC.AnnDeriving - markMaybe ms - mark GHC.AnnInstance - markMaybe mov - markLHsSigType typ - markTrailingSemi - --- --------------------------------------------------------------------- - -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.GhcPs) where - - markAST _ (GHC.DefaultDecl typs) = do - mark GHC.AnnDefault - mark GHC.AnnOpenP -- '(' - markListIntercalate typs - mark GHC.AnnCloseP -- ')' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InstDecl GHC.GhcPs) where - - markAST l (GHC.ClsInstD cid) = markAST l cid - markAST l (GHC.DataFamInstD dfid) = markAST l dfid - markAST l (GHC.TyFamInstD tfid) = markAST l tfid - --- --------------------------------------------------------------------- - -instance Annotate GHC.OverlapMode where - - -- NOTE: NoOverlap is only used in the typechecker - markAST _ (GHC.NoOverlap src) = do - markAnnOpen src "{-# NO_OVERLAP" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlappable src) = do - markAnnOpen src "{-# OVERLAPPABLE" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlapping src) = do - markAnnOpen src "{-# OVERLAPPING" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlaps src) = do - markAnnOpen src "{-# OVERLAPS" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Incoherent src) = do - markAnnOpen src "{-# INCOHERENT" - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where - - markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly _) binds sigs tyfams datafams mov) = do - mark GHC.AnnInstance - markMaybe mov - markLocated poly - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - - applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ++ prepareListAnnotation tyfams - ++ prepareListAnnotation datafams - ) - - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where - - markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn _)) = do - mark GHC.AnnType - mark GHC.AnnInstance -- Note: this keyword is optional - markFamEqn eqn - markTrailingSemi - --- --------------------------------------------------------------------- - -markFamEqn :: (Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) - => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) - -> Annotated () -markFamEqn (GHC.FamEqn ln pats fixity rhs) = do - markTyClass fixity ln pats - mark GHC.AnnEqual - markLocated rhs - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where - - markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn ln pats fixity - defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) ) _ )) = do - case GHC.dd_ND defn of - GHC.NewType -> mark GHC.AnnNewtype - GHC.DataType -> mark GHC.AnnData - mark GHC.AnnInstance - - markLocated ctx - - markTyClass fixity ln pats - - case (GHC.dd_kindSig defn) of - Just s -> do - mark GHC.AnnDcolon - markLocated s - Nothing -> return () - if isGadt $ GHC.dd_cons defn - then mark GHC.AnnWhere - else mark GHC.AnnEqual - markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsBind GHC.GhcPs) where - markAST _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do - -- Note: from a layout perspective a FunBind should not exist, so the - -- current context is passed through unchanged to the matches. - -- TODO: perhaps bring the edp from the first match up to the annotation for - -- the FunBind. - let - tlFun = - ifInContext (Set.fromList [CtxOnly,CtxFirst]) - (markListWithContexts' listContexts matches) - (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) - ifInContext (Set.singleton TopLevel) - (setContextLevel (Set.singleton TopLevel) 2 tlFun) - tlFun - - -- ----------------------------------- - - markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _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 - - -- ----------------------------------- - - -- Introduced after renaming. - markAST _ (GHC.AbsBinds {}) = - traceM "warning: AbsBinds introduced after renaming" - - -- ----------------------------------- - - markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do - mark GHC.AnnPattern - case args of - GHC.InfixCon la lb -> do - markLocated la - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated lb - GHC.PrefixCon ns -> do - markLocated ln - mapM_ markLocated ns - GHC.RecCon fs -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs - mark GHC.AnnCloseC -- '}' - case dir of - GHC.ImplicitBidirectional -> mark GHC.AnnEqual - _ -> mark GHC.AnnLarrow - - markLocated def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markMatchGroup l mg - mark GHC.AnnCloseC -- '}' - - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IPBind GHC.GhcPs) where - markAST _ (GHC.IPBind en e) = do - case en of - Left n -> markLocated n - Right _i -> return () - mark GHC.AnnEqual - markLocated e - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsIPName where - markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.Match mln pats (GHC.GRHSs grhs (GHC.L _ lb))) = do - let - get_infix (GHC.FunRhs _ f _) = f - get_infix _ = GHC.Prefix - - isFunBind GHC.FunRhs{} = True - isFunBind _ = False - case (get_infix mln,pats) of - (GHC.Infix, a:b:xs) -> do - if null xs - then markOptional GHC.AnnOpenP - else mark GHC.AnnOpenP - markLocated a - case mln of - GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n - _ -> return () - markLocated b - if null xs - then markOptional GHC.AnnCloseP - else mark GHC.AnnCloseP - mapM_ markLocated xs - _ -> do - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam - case mln of - GHC.FunRhs n _ s -> do - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do - when (s == GHC.SrcStrict) $ mark GHC.AnnBang - markLocated n - mapM_ markLocated pats - _ -> markListNoPrecedingSpace False pats - - -- TODO: The AnnEqual annotation actually belongs in the first GRHS value - case grhs of - (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards - _ -> return () - inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam - mapM_ markLocated grhs - - case lb of - GHC.EmptyLocalBinds -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where - markAST _ (GHC.GRHS guards expr) = do - case guards of - [] -> return () - (_:_) -> do - mark GHC.AnnVbar - unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) - $ markListIntercalate guards - ifInContext (Set.fromList [CaseAlt]) - (return ()) - (mark GHC.AnnEqual) - - markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test - - inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam - setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Sig GHC.GhcPs) where - - markAST _ (GHC.TypeSig lns st) = do - setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns - mark GHC.AnnDcolon - markLHsSigWcType st - markTrailingSemi - tellContext (Set.singleton FollowingLine) - - markAST _ (GHC.PatSynSig lns (GHC.HsIB _ typ _)) = do - mark GHC.AnnPattern - 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.GhcPs -> Annotated () -markLHsSigType (GHC.HsIB _ typ _) = markLocated typ - -instance Annotate [GHC.LHsSigType GHC.GhcPs] where - markAST _ ls = do - mark GHC.AnnDeriving - -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it - -- is a HsTyVar. So for round trip pretty printing we need to take this into - -- account. - 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.GhcPs) where - markAST _l (GHC.UserTyVar n) = do - markLocated n - - markAST _ (GHC.KindedTyVar n ty) = do - mark GHC.AnnOpenP -- '(' - markLocated n - mark GHC.AnnDcolon -- '::' - markLocated ty - mark GHC.AnnCloseP -- '(' - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsType GHC.GhcPs) 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.GhcPs) where - markAST _ (GHC.HsAppInfix n) = do - when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote - setContext (Set.singleton InfixOp) $ markLocated n - markAST _ (GHC.HsAppPrefix t) = do - markOptional GHC.AnnTilde - setContext (Set.singleton PrefixOp) $ markLocated t - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsSplice GHC.GhcPs) where - markAST l c = - case c of - GHC.HsQuasiQuote _ n _pos fs -> do - markExternal l GHC.AnnVal - -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") - - GHC.HsTypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsTypedSplice hasParens _n b -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - -- ------------------------------- - - GHC.HsUntypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsUntypedSplice hasParens _n b -> do - case hasParens of - GHC.HasParens -> mark GHC.AnnOpenPE - GHC.HasDollar -> mark GHC.AnnThIdSplice - GHC.NoParens -> return () - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDeclField GHC.GhcPs) where - markAST _ (GHC.ConDeclField ns ty mdoc) = do - unsetContext Intercalate $ do - markListIntercalate ns - mark GHC.AnnDcolon - markLocated ty - markMaybe mdoc - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance (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.GhcPs) where - markAST loc typ = do - markPat loc typ - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") - where - markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" - markPat l (GHC.VarPat n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is - -- resolved, particularly for pretty printing where annotations are added. - let pun_RDR = "pun-right-hand-side" - when (showGhc n /= pun_RDR) $ - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) - markPat _ (GHC.LazyPat p) = do - mark GHC.AnnTilde - markLocated p - - markPat _ (GHC.AsPat ln p) = do - markLocated ln - mark GHC.AnnAt - markLocated p - - markPat _ (GHC.ParPat p) = do - mark GHC.AnnOpenP - markLocated p - mark GHC.AnnCloseP - - markPat _ (GHC.BangPat p) = do - mark GHC.AnnBang - markLocated p - - markPat _ (GHC.ListPat ps _ _) = do - mark GHC.AnnOpenS - markListIntercalateWithFunLevel markLocated 2 ps - mark GHC.AnnCloseS - - markPat _ (GHC.TuplePat pats b _) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevel markLocated 2 pats - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markPat _ (GHC.SumPat pat alt arity _) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated pat - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markPat _ (GHC.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 GHC.GhcPs -> String -hsLit2String lit = - case lit of - GHC.HsChar src v -> toSourceTextWithSuffix src v "" - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" - GHC.HsString src v -> toSourceTextWithSuffix src v "" - GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" - GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" - GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" - GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" - GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" - -toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String -toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix - --- -------------------------------------------------------------------- - -markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () -markHsConPatDetails ln dets = do - case dets of - GHC.PrefixCon args -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated args - GHC.RecCon (GHC.HsRecFields fs dd) -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - case dd of - Nothing -> markListIntercalateWithFunLevel markLocated 2 fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- '}' - GHC.InfixCon a1 a2 -> do - markLocated a1 - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln - markLocated a2 - -markHsConDeclDetails :: - Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () - -markHsConDeclDetails isDeprecated inGadt lns dets = do - case dets of - GHC.PrefixCon args -> - setContext (Set.singleton PrefixOp) $ mapM_ markLocated args - GHC.RecCon fs -> do - mark GHC.AnnOpenC - if inGadt - then do - if isDeprecated - then setContext (Set.fromList [InGadt]) $ markLocated fs - else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs - else do - if isDeprecated - then markLocated fs - else setContext (Set.fromList [InRecCon]) $ markLocated fs - GHC.InfixCon a1 a2 -> do - markLocated a1 - setContext (Set.singleton InfixOp) $ mapM_ markLocated lns - markLocated a2 - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LConDeclField GHC.GhcPs] where - markAST _ fs = do - markOptional GHC.AnnOpenC -- '{' - markListIntercalate fs - markOptional GHC.AnnDotdot - inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' - inContext (Set.singleton InGadt) $ do - mark GHC.AnnRarrow - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsOverLit GHC.GhcPs) where - markAST l ol = - let str = case GHC.ol_val ol of - GHC.HsIntegral (GHC.IL src _ _) -> src - GHC.HsFractional (GHC.FL src _ _) -> src - GHC.HsIsString src _ -> src - in - markExternalSourceText l str "" - --- --------------------------------------------------------------------- - -instance (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.GhcPs (GHC.Located body)) where - - markAST _ (GHC.LastStmt body _ _) - = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - markAST _ (GHC.BindStmt pat body _ _ _) = do - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat - mark GHC.AnnLarrow - unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST _ GHC.ApplicativeStmt{} - = error "ApplicativeStmt should not appear in ParsedSource" - - markAST _ (GHC.BodyStmt body _ _ _) = do - unsetContext Intercalate $ markLocated body - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.LetStmt (GHC.L _ lb)) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST l (GHC.ParStmt pbs _ _ _) = do - -- Within a given parallel list comprehension,one of the sections to be done - -- in parallel. It is a normal list comprehension, so has a list of - -- ParStmtBlock, one for each part of the sub- list comprehension - - - ifInContext (Set.singleton Intercalate) - ( - - unsetContext Intercalate $ - markListWithContextsFunction - (LC (Set.singleton Intercalate) -- only - Set.empty -- first - Set.empty -- middle - (Set.singleton Intercalate) -- last - ) (markAST l) pbs - ) - ( - unsetContext Intercalate $ - markListWithContextsFunction - (LC Set.empty -- only - (Set.fromList [AddVbar]) -- first - (Set.fromList [AddVbar]) -- middle - Set.empty -- last - ) (markAST l) pbs - ) - markTrailingSemi - - markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do - setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts - case form of - GHC.ThenForm -> do - mark GHC.AnnThen - unsetContext Intercalate $ markLocated using - case by of - Just b -> do - mark GHC.AnnBy - unsetContext Intercalate $ markLocated b - Nothing -> return () - GHC.GroupForm -> do - mark GHC.AnnThen - mark GHC.AnnGroup - case by of - Just b -> mark GHC.AnnBy >> markLocated b - Nothing -> return () - mark GHC.AnnUsing - markLocated using - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do - mark GHC.AnnRec - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - mapM_ markLocated stmts - markOptional GHC.AnnCloseC - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - --- --------------------------------------------------------------------- - --- Note: We never have a located ParStmtBlock, so have nothing to hang the --- annotation on. This means there is no pushing of context from the parent ParStmt. -instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where - markAST _ (GHC.ParStmtBlock stmts _ns _) = do - markListIntercalate stmts - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where - markAST _ lb = markHsLocalBinds lb - --- --------------------------------------------------------------------- - -markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markHsLocalBinds (GHC.HsValBinds (GHC.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.GhcPs (GHC.Located body) - -> Annotated () -markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) - = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsExpr GHC.GhcPs) where - markAST loc expr = do - markExpr loc expr - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - -- TODO: If the AnnComma is not needed, revert to markAST - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - where - markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do - ifInContext (Set.singleton PrefixOp) - (setContext (Set.singleton PrefixOp) $ markLocated n) - (ifInContext (Set.singleton InfixOp) - (setContext (Set.singleton InfixOp) $ markLocated n) - (markLocated n) - ) - - markExpr l (GHC.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.AnnOpenB "(|" - markLocated e - mapM_ markLocated cs - markWithString GHC.AnnCloseB "|)" - - markExpr _ (GHC.HsTick _ _) = return () - markExpr _ (GHC.HsBinTick _ _ _) = return () - - markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markAnnOpen src "{-# GENERATED" - markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING - - let - markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) - markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s - - markOne 1 v1 s1 -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOne 2 v2 s2 -- INTEGER - mark GHC.AnnMinus -- '-' - markOne 3 v3 s3 -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOne 4 v4 s4 -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr l GHC.EWildPat = do - ifInContext (Set.fromList [InfixOp]) - (do mark GHC.AnnBackquote - markWithString GHC.AnnVal "_" - mark GHC.AnnBackquote) - (markExternal l GHC.AnnVal "_") - - markExpr _ (GHC.EAsPat ln e) = do - markLocated ln - mark GHC.AnnAt - markLocated e - - markExpr _ (GHC.EViewPat e1 e2) = do - markLocated e1 - mark GHC.AnnRarrow - markLocated e2 - - markExpr _ (GHC.ELazyPat e) = do - mark GHC.AnnTilde - markLocated e - - markExpr _ (GHC.HsAppType e ty) = do - markLocated e - markInstead GHC.AnnAt AnnTypeApp - 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.GhcPs -> Annotated () -markLHsWcType (GHC.HsWC _ ty) = do - markLocated ty - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLit GHC.GhcPs) where - markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where - markAST _ (GHC.HsRecField lbl expr punFlag) = do - unsetContext Intercalate $ markLocated lbl - when (punFlag == False) $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated expr - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - -instance (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.GhcPs] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTupArg GHC.GhcPs) where - markAST _ (GHC.Present (GHC.L l e)) = do - markLocated (GHC.L l e) - inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) - - markAST _ (GHC.Missing _) = do - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsCmdTop GHC.GhcPs) where - markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd - -instance Annotate (GHC.HsCmd GHC.GhcPs) where - markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markAST _ (GHC.HsCmdArrForm e fixity _mf cs) = do - -- The AnnOpen should be marked for a prefix usage, not for a postfix one, - -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm - - let isPrefixOp = case fixity of - GHC.Infix -> False - GHC.Prefix -> True - when isPrefixOp $ mark GHC.AnnOpenB -- "(|" - - -- This may be an infix operation - applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) - (Set.singleton InfixOp) (Set.singleton InfixOp)) - (prepareListAnnotation [e] - ++ prepareListAnnotation cs) - when isPrefixOp $ mark GHC.AnnCloseB -- "|)" - - markAST _ (GHC.HsCmdApp e1 e2) = do - markLocated e1 - markLocated e2 - - markAST l (GHC.HsCmdLam match) = do - setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match - - markAST _ (GHC.HsCmdPar e) = do - mark GHC.AnnOpenP - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsCmdCase e1 matches) = do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l matches - markOptional GHC.AnnCloseC - - markAST _ (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.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyClDecl GHC.GhcPs) where - - markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi - - markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) fixity typ _) = do - -- There may be arbitrary parens around parts of the constructor that are - -- infix. - -- Turn these into comments so that they feed into the right place automatically - -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - mark GHC.AnnType - - markTyClass fixity ln tyvars - mark GHC.AnnEqual - markLocated typ - markTrailingSemi - - markAST _ (GHC.DataDecl ln (GHC.HsQTvs _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.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () -markTyClass fixity ln tyVars = do - -- There may be arbitrary parens around parts of the constructor - -- Turn these into comments so that they feed into the right place automatically - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - let markParens = if fixity == GHC.Infix && length tyVars > 2 - then markMany - else markManyOptional - if fixity == GHC.Prefix - then do - markManyOptional GHC.AnnOpenP - setContext (Set.singleton PrefixOp) $ markLocated ln - -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars - setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars - when (length tyVars >= 2) $ do - markParens GHC.AnnCloseP - setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars - markManyOptional GHC.AnnCloseP - else do - case tyVars of - (x:y:xs) -> do - markParens GHC.AnnOpenP - markLocated x - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated y - markParens GHC.AnnCloseP - mapM_ markLocated xs - markManyOptional GHC.AnnCloseP - _ -> error $ "markTyClass: Infix op without operands" - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where - markAST _ ds = mapM_ markLocated ds - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where - markAST _ (GHC.HsDerivingClause mstrategy (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.GhcPs) where - markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) fixity rsig minj) = do - case info of - GHC.DataFamily -> mark GHC.AnnData - _ -> mark GHC.AnnType - - mark GHC.AnnFamily - - markTyClass fixity ln tyvars - case GHC.unLoc rsig of - GHC.NoSig -> return () - GHC.KindSig _ -> do - mark GHC.AnnDcolon - markLocated rsig - GHC.TyVarSig _ -> do - mark GHC.AnnEqual - markLocated rsig - case minj of - Nothing -> return () - Just inj -> do - mark GHC.AnnVbar - markLocated inj - case info of - GHC.ClosedTypeFamily (Just eqns) -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- { - markListWithLayout eqns - markOptional GHC.AnnCloseC -- } - GHC.ClosedTypeFamily Nothing -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- { - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- } - _ -> return () - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where - markAST _ (GHC.NoSig) = return () - markAST _ (GHC.KindSig k) = markLocated k - markAST _ (GHC.TyVarSig ltv) = markLocated ltv - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where - markAST _ (GHC.InjectivityAnn ln lns) = do - markLocated ln - mark GHC.AnnRarrow - mapM_ markLocated lns - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where - - markAST _ (GHC.HsIB _ eqn _) = do - markFamEqn eqn - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where - - markAST _ (GHC.FamEqn 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.GhcPs -> Annotated () -markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons derivs) = do - markLocated ctx - markMaybe typ - if isGadt cons - then markListWithLayout cons - else markListIntercalateWithFunLevel markLocated 2 cons - setContext (Set.singleton Deriving) $ markLocated derivs - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance Annotate [GHC.LHsType GHC.GhcPs] where - markAST l ts = do - -- 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.GhcPs) 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.Outputable (ResTyGADTHook GHC.GhcPs) 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.GhcPs) where - markAST _ (ResTyGADTHook bndrs) = do - unless (null bndrs) $ do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - - markAST _ (ls,rs') = do - mapM_ markLocated ls - mark GHC.AnnRarrow - mapM_ markLocated rs' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate GHC.CType where - markAST _ (GHC.CType src mh f) = do - -- markWithString GHC.AnnOpen src - markAnnOpen src "" - case mh of - Nothing -> return () - Just (GHC.Header srcH _h) -> - -- markWithString GHC.AnnHeader srcH - markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") - -- markWithString GHC.AnnVal (fst f) - markSourceText (fst f) (GHC.unpackFS $ snd f) - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -stringLiteralToString :: GHC.StringLiteral -> String -stringLiteralToString (GHC.StringLiteral st fs) = - case st of - GHC.NoSourceText -> GHC.unpackFS fs - GHC.SourceText src -> src diff --git a/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs deleted file mode 100644 --- a/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2796 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - --- | 'annotate' is a function which given a GHC AST fragment, constructs --- a syntax tree which indicates which annotations belong to each specific --- part of the fragment. --- --- "Delta" and "Print" provide two interpreters for this structure. You --- should probably use those unless you know what you're doing! --- --- The functor 'AnnotationF' has a number of constructors which correspond --- to different sitations which annotations can arise. It is hoped that in --- future versions of GHC these can be simplified by making suitable --- modifications to the AST. - -module Language.Haskell.GHC.ExactPrint.Annotater - ( - annotate - , AnnotationF(..) - , Annotated - , Annotate(..) - , withSortKeyContextsHelper - ) where - - -import Language.Haskell.GHC.ExactPrint.AnnotateTypes -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified BooleanFormula as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC --- import qualified HsDoc as GHC -import qualified Name as GHC -import qualified RdrName as GHC -import qualified Outputable as GHC - -import Control.Monad.Identity -import Data.Data -import Data.Maybe - -import qualified Data.Set as Set - -import Debug.Trace - - -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} --- --------------------------------------------------------------------- - -class Data ast => Annotate ast where - markAST :: GHC.SrcSpan -> ast -> Annotated () - --- --------------------------------------------------------------------- - --- | Construct a syntax tree which represent which KeywordIds must appear --- where. -annotate :: (Annotate ast) => GHC.Located ast -> Annotated () -annotate = markLocated - --- --------------------------------------------------------------------- - --- | Constructs a syntax tree which contains information about which --- annotations are required by each element. -markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () -markLocated ast = - case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of - Just d -> markLHsDecl d - Nothing -> withLocated ast markAST - --- --------------------------------------------------------------------- - --- |When adding missing annotations, do not put a preceding space in front of a list -markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () -markListNoPrecedingSpace intercal ls = - case ls of - [] -> return () - (l:ls') -> do - if intercal - then do - if null ls' - then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l - else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l - markListIntercalate ls' - else do - setContext (Set.singleton NoPrecedingSpace) $ markLocated l - mapM_ markLocated ls' - --- --------------------------------------------------------------------- - - --- |Mark a list, with the given keyword as a list item separator -markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () -markListIntercalate ls = markListIntercalateWithFun markLocated ls - --- --------------------------------------------------------------------- - -markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () -markListWithContexts ctxInitial ctxRest ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxInitial 2 $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial 2 $ markLocated x - setContextLevel ctxRest 2 $ mapM_ markLocated xs - --- --------------------------------------------------------------------- - --- Context for only if just one, else first item, middle ones, and last one -markListWithContexts' :: Annotate ast - => ListContexts - -> [GHC.Located ast] -> Annotated () -markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxOnly level $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial level $ markLocated x - go xs - where - level = 2 - go [] = return () - go [x] = setContextLevel ctxLast level $ markLocated x - go (x:xs) = do - setContextLevel ctxMiddle level $ markLocated x - go xs - - --- --------------------------------------------------------------------- - -markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () -markListWithLayout ls = - setLayoutFlag $ markList ls - --- --------------------------------------------------------------------- - -markList :: Annotate ast => [GHC.Located ast] -> Annotated () -markList ls = - setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts' ls - -markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markLocalBindsWithLayout binds = markHsLocalBinds binds - --- --------------------------------------------------------------------- - --- |This function is used to get around shortcomings in the GHC AST for 7.10.1 -markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () -markLocatedFromKw kw (GHC.L l a) = do - -- Note: l is needed so that the pretty printer can make something up - ss <- getSrcSpanForKw l kw - AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) - markLocated (GHC.L ss' a) - --- --------------------------------------------------------------------- - -markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () -markMaybe Nothing = return () -markMaybe (Just ast) = markLocated ast - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] -prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsModule GHC.GhcPs) where - markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do - - case mmn of - Nothing -> return () - Just (GHC.L ln mn) -> do - mark GHC.AnnModule - markExternal ln GHC.AnnVal (GHC.moduleNameString mn) - - forM_ mdepr markLocated - forM_ mexp markLocated - - mark GHC.AnnWhere - - markOptional GHC.AnnOpenC -- Possible '{' - markManyOptional GHC.AnnSemi -- possible leading semis - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps - - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs - - markOptional GHC.AnnCloseC -- Possible '}' - - markEOF - --- --------------------------------------------------------------------- - -instance Annotate GHC.WarningTxt where - markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# WARNING" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# DEPRECATED" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate GHC.StringLiteral where - markAST l (GHC.StringLiteral src fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SourceText,GHC.FastString) where - markAST l (src,fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LIE GHC.GhcPs] where - markAST _ ls = do - inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl - mark GHC.AnnOpenP -- '(' - -- Can't use markListIntercalate, there can be trailing commas, but only in imports. - markListIntercalateWithFunLevel markLocated 2 ls - - mark GHC.AnnCloseP -- ')' - -instance Annotate (GHC.IE GHC.GhcPs) where - markAST _ ie = do - - case ie of - GHC.IEVar _ ln -> markLocated ln - - GHC.IEThingAbs _ ln -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - - GHC.IEThingWith _ ln wc ns _lfs -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnOpenP - case wc of - GHC.NoIEWildcard -> - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns - GHC.IEWildcard n -> do - setContext (Set.fromList [PrefixOp,Intercalate]) - $ mapM_ markLocated (take n ns) - mark GHC.AnnDotdot - case drop n ns of - [] -> return () - ns' -> do - mark GHC.AnnComma - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns' - mark GHC.AnnCloseP - - (GHC.IEThingAll _ ln) -> do - setContext (Set.fromList [PrefixOp]) $ markLocated ln - mark GHC.AnnOpenP - mark GHC.AnnDotdot - mark GHC.AnnCloseP - - (GHC.IEModuleContents _ (GHC.L lm mn)) -> do - mark GHC.AnnModule - markExternal lm GHC.AnnVal (GHC.moduleNameString mn) - - -- Only used in Haddock mode so we can ignore them. - (GHC.IEGroup {}) -> return () - - (GHC.IEDoc {}) -> return () - - (GHC.IEDocNamed {}) -> return () - GHC.XIE x -> error $ "got XIE for :" ++ showGhc x - ifInContext (Set.fromList [Intercalate]) - (mark GHC.AnnComma) - (markOptional GHC.AnnComma) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IEWrappedName GHC.RdrName) where - markAST _ (GHC.IEName ln) = do - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEPattern ln) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEType ln) = do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -isSymRdr :: GHC.RdrName -> Bool -isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." - -instance Annotate GHC.RdrName where - markAST l n = do - let - str = rdrName2String n - isSym = isSymRdr n - canParen = isSym - doNormalRdrName = do - let str' = case str of - -- TODO: unicode support? - "forall" -> if spanLength l == 1 then "∀" else str - _ -> str - - let - markParen :: GHC.AnnKeywordId -> Annotated () - markParen pa = do - if canParen - then ifInContext (Set.singleton PrefixOp) - (mark pa) -- '(' - (markOptional pa) - else if isSym - then ifInContext (Set.singleton PrefixOpDollar) - (mark pa) - (markOptional pa) - else markOptional pa - - markOptional GHC.AnnSimpleQuote - markParen GHC.AnnOpenP - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 - cnt <- countAnns GHC.AnnVal - case cnt of - 0 -> markExternal l GHC.AnnVal str' - 1 -> markWithString GHC.AnnVal str' - _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 - markParen GHC.AnnCloseP - - case n of - GHC.Unqual _ -> doNormalRdrName - GHC.Qual _ _ -> doNormalRdrName - GHC.Orig _ _ -> if str == "~" - then doNormalRdrName - -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen) - else markExternal l GHC.AnnVal str - -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str - -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]" - GHC.Exact n' -> do - case str of - -- Special handling for Exact RdrNames, which are built-in Names - "[]" -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnCloseS -- ']' - "()" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnCloseP -- ')' - ('(':'#':_) -> do - markWithString GHC.AnnOpen "(#" -- '(#' - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - markWithString GHC.AnnClose "#)"-- '#)' - "[::]" -> do - markWithString GHC.AnnOpen "[:" -- '[:' - markWithString GHC.AnnClose ":]" -- ':]' - "->" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnRarrow - mark GHC.AnnCloseP -- ')' - -- "~#" -> do - -- mark GHC.AnnOpenP -- '(' - -- mark GHC.AnnTildehsh - -- mark GHC.AnnCloseP - "*" -> do - markExternal l GHC.AnnVal str - "★" -> do -- Note: unicode star - markExternal l GHC.AnnVal str - ":" -> do - -- Note: The OccName for ":" has the following attributes (via occAttributes) - -- (d, Data DataSym Sym Val ) - -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - doNormalRdrName - -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName - ('(':',':_) -> do - mark GHC.AnnOpenP - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - mark GHC.AnnCloseP -- ')' - _ -> do - let isSym' = isSymRdr (GHC.nameRdrName n') - when isSym' $ mark GHC.AnnOpenP -- '(' - markWithString GHC.AnnVal str - when isSym $ mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ImportDecl GHC.GhcPs) where - markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do - - -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - mark GHC.AnnImport - - -- "{-# SOURCE" and "#-}" - case msrc of - GHC.SourceText _txt -> do - markAnnOpen msrc "{-# SOURCE" - markWithString GHC.AnnClose "#-}" - GHC.NoSourceText -> return () - when safeflag (mark GHC.AnnSafe) - when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) - case mpkg of - Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> - markWithString GHC.AnnPackageName srcPkg - _ -> return () - - markLocated modname - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - mark GHC.AnnAs - markLocated mn - - case hiding of - Nothing -> return () - Just (isHiding,lie) -> do - if isHiding - then setContext (Set.singleton HasHiding) $ - markLocated lie - else markLocated lie - markTrailingSemi - - markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.ModuleName where - markAST l mname = - markExternal l GHC.AnnVal (GHC.moduleNameString mname) - --- --------------------------------------------------------------------- - -markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () -markLHsDecl (GHC.L l decl) = - case decl of - GHC.TyClD _ d -> markLocated (GHC.L l d) - GHC.InstD _ d -> markLocated (GHC.L l d) - GHC.DerivD _ d -> markLocated (GHC.L l d) - GHC.ValD _ d -> markLocated (GHC.L l d) - GHC.SigD _ d -> markLocated (GHC.L l d) - GHC.DefD _ d -> markLocated (GHC.L l d) - GHC.ForD _ d -> markLocated (GHC.L l d) - GHC.WarningD _ d -> markLocated (GHC.L l d) - GHC.AnnD _ d -> markLocated (GHC.L l d) - GHC.RuleD _ d -> markLocated (GHC.L l d) - GHC.SpliceD _ d -> markLocated (GHC.L l d) - GHC.DocD _ d -> markLocated (GHC.L l d) - GHC.RoleAnnotD _ d -> markLocated (GHC.L l d) - GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x - -instance Annotate (GHC.HsDecl GHC.GhcPs) where - markAST l d = markLHsDecl (GHC.L l d) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where - markAST _ (GHC.RoleAnnotDecl _ ln mr) = do - mark GHC.AnnType - mark GHC.AnnRole - markLocated ln - mapM_ markLocated mr - markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x - -instance Annotate (Maybe GHC.Role) where - markAST l Nothing = markExternal l GHC.AnnVal "_" - markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SpliceDecl GHC.GhcPs) where - markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do - markLocated e - markTrailingSemi - markAST _ (GHC.SpliceDecl _ e _flag) = do - markLocated e - markTrailingSemi - - markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecls GHC.GhcPs) where - markAST _ (GHC.HsRules _ src rules) = do - markAnnOpen src "{-# RULES" - setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules - markWithString GHC.AnnClose "#-}" - markTrailingSemi - markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecl GHC.GhcPs) where - markAST l (GHC.HsRule _ ln act bndrs lhs rhs) = do - markLocated ln - setContext (Set.singleton ExplicitNeverActive) $ markActivation l act - - unless (null bndrs) $ do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - markLocated lhs - mark GHC.AnnEqual - markLocated rhs - inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi - markTrailingSemi - - markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () -markActivation _ act = do - case act of - GHC.ActiveBefore src phase -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.ActiveAfter src phase -> do - mark GHC.AnnOpenS -- '[' - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.NeverActive -> do - inContext (Set.singleton ExplicitNeverActive) $ do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - mark GHC.AnnCloseS -- ']' - _ -> return () - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleBndr GHC.GhcPs) where - markAST _ (GHC.RuleBndr _ ln) = markLocated ln - markAST _ (GHC.RuleBndrSig _ ln st) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLHsSigWcType st - mark GHC.AnnCloseP -- ")" - markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x - --- --------------------------------------------------------------------- - -markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () -markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do - markLocated ty -markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit" -markLHsSigWcType (GHC.XHsWildCardBndrs _) = error "markLHsSigWcType extension hit" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.AnnDecl GHC.GhcPs) where - markAST _ (GHC.HsAnnotation _ src prov e) = do - markAnnOpen src "{-# ANN" - case prov of - (GHC.ValueAnnProvenance n) -> markLocated n - (GHC.TypeAnnProvenance n) -> do - mark GHC.AnnType - markLocated n - GHC.ModuleAnnProvenance -> mark GHC.AnnModule - - markLocated e - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecls GHC.GhcPs) where - markAST _ (GHC.Warnings _ src warns) = do - markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED - mapM_ markLocated warns - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecl GHC.GhcPs) where - markAST _ (GHC.Warning _ lns txt) = do - markListIntercalate lns - mark GHC.AnnOpenS -- "[" - case txt of - GHC.WarningTxt _src ls -> markListIntercalate ls - GHC.DeprecatedTxt _src ls -> markListIntercalate ls - mark GHC.AnnCloseS -- "]" - - markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x - -instance Annotate GHC.FastString where - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - markAST l fs = do - markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ForeignDecl GHC.GhcPs) where - markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnImport - markLocated cconv - unless (ll == GHC.noSrcSpan) $ markLocated safety - markExternalSourceText ls src "" - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnExport - markLocated spec - markExternal ls GHC.AnnVal (sourceTextToString src "") - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLocated typ - - - markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" - markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" - markAST _ (GHC.XForeignDecl _) = error "markAST ForeignDecl hit extenstion" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CExportSpec) where - markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CCallConv) where - markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" - markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" - markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" - markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" - markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.Safety) where - markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" - markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" - markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivDecl GHC.GhcPs) where - - markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do - mark GHC.AnnDeriving - markMaybe ms - mark GHC.AnnInstance - markMaybe mov - markLocated typ - markTrailingSemi - -{- -data DerivDecl pass = DerivDecl - { deriv_ext :: XCDerivDecl pass - , deriv_type :: LHsSigWcType pass - -- ^ The instance type to derive. - -- - -- It uses an 'LHsSigWcType' because the context is allowed to be a - -- single wildcard: - -- - -- > deriving instance _ => Eq (Foo a) - -- - -- Which signifies that the context should be inferred. - - -- See Note [Inferring the instance context] in TcDerivInfer. - - , deriv_strategy :: Maybe (LDerivStrategy pass) - , deriv_overlap_mode :: Maybe (Located OverlapMode) - -type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both - -data HsWildCardBndrs pass thing - -- See Note [HsType binders] - -- See Note [The wildcard story for types] - = HsWC { hswc_ext :: XHsWC pass thing - -- after the renamer - -- Wild cards, both named and anonymous - - , hswc_body :: thing - -- Main payload (type or list of types) - -- If there is an extra-constraints wildcard, - -- it's still there in the hsc_body. - } - - --} - - - markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension" - markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _) = error "markAST DerivDecl hit extension" - markAST _ (GHC.XDerivDecl _) = error "markAST DerivDecl hit extension" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivStrategy GHC.GhcPs) where - - markAST _ GHC.StockStrategy = mark GHC.AnnStock - markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass - markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype - markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do - mark GHC.AnnVia - markLocated ty - markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _)) - = error $ "got XHsImplicitBndrs in AnnDerivStrategy" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DefaultDecl GHC.GhcPs) where - - markAST _ (GHC.DefaultDecl _ typs) = do - mark GHC.AnnDefault - mark GHC.AnnOpenP -- '(' - markListIntercalate typs - mark GHC.AnnCloseP -- ')' - markTrailingSemi - - markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InstDecl GHC.GhcPs) where - - markAST l (GHC.ClsInstD _ cid) = markAST l cid - markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid - markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid - markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.OverlapMode where - - -- NOTE: NoOverlap is only used in the typechecker - markAST _ (GHC.NoOverlap src) = do - markAnnOpen src "{-# NO_OVERLAP" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlappable src) = do - markAnnOpen src "{-# OVERLAPPABLE" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlapping src) = do - markAnnOpen src "{-# OVERLAPPING" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlaps src) = do - markAnnOpen src "{-# OVERLAPS" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Incoherent src) = do - markAnnOpen src "{-# INCOHERENT" - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where - - markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do - mark GHC.AnnInstance - markMaybe mov - markLocated poly - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - - applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ++ prepareListAnnotation tyfams - ++ prepareListAnnotation datafams - ) - - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl" - markAST _ (GHC.XClsInstDecl _) = error "extension hit for ClsInstDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where - - markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do - mark GHC.AnnType - mark GHC.AnnInstance -- Note: this keyword is optional - markFamEqn eqn - markTrailingSemi - - markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl" - --- --------------------------------------------------------------------- - -markFamEqn :: (Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) - => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) - -> Annotated () -markFamEqn (GHC.FamEqn _ ln pats fixity rhs) = do - markTyClass fixity ln pats - mark GHC.AnnEqual - markLocated rhs -markFamEqn (GHC.XFamEqn _) = error "got XFamEqn" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where - - markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln pats fixity - defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do - case GHC.dd_ND defn of - GHC.NewType -> mark GHC.AnnNewtype - GHC.DataType -> mark GHC.AnnData - mark GHC.AnnInstance - - markLocated ctx - - markTyClass fixity ln pats - - case (GHC.dd_kindSig defn) of - Just s -> do - mark GHC.AnnDcolon - markLocated s - Nothing -> return () - if isGadt $ GHC.dd_cons defn - then mark GHC.AnnWhere - else mark GHC.AnnEqual - markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs) - markTrailingSemi - -{- -newtype DataFamInstDecl pass - = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } - -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) - -data FamEqn pass pats rhs - = FamEqn - { feqn_ext :: XCFamEqn pass pats rhs - , feqn_tycon :: Located (IdP pass) - , feqn_pats :: pats - , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , feqn_rhs :: rhs - } --} - - markAST _ - (GHC.DataFamInstDecl - (GHC.HsIB _ (GHC.FamEqn _ _ _ _ (GHC.XHsDataDefn _)))) - = error "extension hit for DataFamInstDecl" - markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _))) - = error "extension hit for DataFamInstDecl" - markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _)) - = error "extension hit for DataFamInstDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsBind GHC.GhcPs) where - markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do - -- Note: from a layout perspective a FunBind should not exist, so the - -- current context is passed through unchanged to the matches. - -- TODO: perhaps bring the edp from the first match up to the annotation for - -- the FunBind. - let - tlFun = - ifInContext (Set.fromList [CtxOnly,CtxFirst]) - (markListWithContexts' listContexts matches) - (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) - ifInContext (Set.singleton TopLevel) - (setContextLevel (Set.singleton TopLevel) 2 tlFun) - tlFun - - -- ----------------------------------- - - markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do - markLocated lhs - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards - _ -> return () - markListIntercalateWithFunLevel markLocated 2 grhs - - -- TODO: extract this common code - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.VarBind _ _n rhse _) = - -- Note: this bind is introduced by the typechecker - markLocated rhse - - -- ----------------------------------- - - -- Introduced after renaming. - markAST _ (GHC.AbsBinds {}) = - traceM "warning: AbsBinds introduced after renaming" - - -- ----------------------------------- - - markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do - mark GHC.AnnPattern - case args of - GHC.InfixCon la lb -> do - markLocated la - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated lb - GHC.PrefixCon ns -> do - markLocated ln - mapM_ markLocated ns - GHC.RecCon fs -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs - mark GHC.AnnCloseC -- '}' - case dir of - GHC.ImplicitBidirectional -> mark GHC.AnnEqual - _ -> mark GHC.AnnLarrow - - markLocated def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markMatchGroup l mg - mark GHC.AnnCloseC -- '}' - - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _) - = error "extension hit for HsBind" - markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _) - = error "extension hit for HsBind" - markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _)) - = error "extension hit for HsBind" - markAST _ (GHC.XHsBindsLR _) - = error "extension hit for HsBind" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IPBind GHC.GhcPs) where - markAST _ (GHC.IPBind _ en e) = do - case en of - Left n -> markLocated n - Right _i -> return () - mark GHC.AnnEqual - markLocated e - markTrailingSemi - - -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x - markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsIPName where - markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do - let - get_infix (GHC.FunRhs _ f _) = f - get_infix _ = GHC.Prefix - - isFunBind GHC.FunRhs{} = True - isFunBind _ = False - case (get_infix mln,pats) of - (GHC.Infix, a:b:xs) -> do - if null xs - then markOptional GHC.AnnOpenP - else mark GHC.AnnOpenP - markLocated a - case mln of - GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n - _ -> return () - markLocated b - if null xs - then markOptional GHC.AnnCloseP - else mark GHC.AnnCloseP - mapM_ markLocated xs - _ -> do - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam - case mln of - GHC.FunRhs n _ s -> do - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do - when (s == GHC.SrcStrict) $ mark GHC.AnnBang - markLocated n - mapM_ markLocated pats - _ -> markListNoPrecedingSpace False pats - - -- TODO: The AnnEqual annotation actually belongs in the first GRHS value - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards - _ -> return () - inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam - mapM_ markLocated grhs - - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _)) - = error "hit extension for Match" - markAST _ (GHC.XMatch _) - = error "hit extension for Match" - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where - markAST _ (GHC.GRHS _ guards expr) = do - case guards of - [] -> return () - (_:_) -> do - mark GHC.AnnVbar - unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) - $ markListIntercalate guards - ifInContext (Set.fromList [CaseAlt]) - (return ()) - (mark GHC.AnnEqual) - - markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test - - inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam - setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr - - markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Sig GHC.GhcPs) where - - markAST _ (GHC.TypeSig _ lns st) = do - setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns - mark GHC.AnnDcolon - markLHsSigWcType st - markTrailingSemi - tellContext (Set.singleton FollowingLine) - - markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do - mark GHC.AnnPattern - markListIntercalate lns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do - when isDefault $ mark GHC.AnnDefault - setContext (Set.singleton PrefixOp) $ markListIntercalate ns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.IdSig {}) = - traceM "warning: Introduced after renaming" - - markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do - let fixstr = case fdir of - GHC.InfixL -> "infixl" - GHC.InfixR -> "infixr" - GHC.InfixN -> "infix" - markWithString GHC.AnnInfix fixstr - markSourceText src (show v) - setContext (Set.singleton InfixOp) $ markListIntercalate lns - markTrailingSemi - - markAST l (GHC.InlineSig _ ln inl) = do - markAnnOpen (GHC.inl_src inl) "{-# INLINE" - markActivation l (GHC.inl_act inl) - setContext (Set.singleton PrefixOp) $ markLocated ln - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - markAST l (GHC.SpecSig _ ln typs inl) = do - markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE - markActivation l (GHC.inl_act inl) - markLocated ln - mark GHC.AnnDcolon -- '::' - markListIntercalateWithFunLevel markLHsSigType 2 typs - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.SpecInstSig _ src typ) = do - markAnnOpen src "{-# SPECIALISE" - mark GHC.AnnInstance - markLHsSigType typ - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.MinimalSig _ src formula) = do - markAnnOpen src "{-# MINIMAL" - markLocated formula - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.SCCFunSig _ src ln ml) = do - markAnnOpen src "{-# SCC" - markLocated ln - markMaybe ml - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do - markAnnOpen src "{-# COMPLETE" - markListIntercalate ns - case mlns of - Nothing -> return () - Just _ -> do - mark GHC.AnnDcolon - markMaybe mlns - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - -- ----------------------------------- - markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _)) - = error "hit extension for Sig" - markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _)) - = error "hit extension for Sig" - markAST _ (GHC.FixSig _ (GHC.XFixitySig _)) - = error "hit extension for Sig" - markAST _ (GHC.XSig _) - = error "hit extension for Sig" - --- -------------------------------------------------------------------- - -markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () -markLHsSigType (GHC.HsIB _ typ) = markLocated typ -markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - -instance Annotate [GHC.LHsSigType GHC.GhcPs] where - markAST _ ls = do - -- mark GHC.AnnDeriving - -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it - -- is a HsTyVar. So for round trip pretty printing we need to take this into - -- account. - let marker = case ls of - [] -> markManyOptional - [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t) - then markMany - else markManyOptional - _ -> markMany -- Need parens if more than one entry - marker GHC.AnnOpenP - markListIntercalateWithFun markLHsSigType ls - marker GHC.AnnCloseP - --- -------------------------------------------------------------------- - -instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where - markAST _ (GHC.Var x) = do - setContext (Set.singleton PrefixOp) $ markLocated x - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls - markAST _ (GHC.And ls) = do - markListIntercalateWithFunLevel markLocated 2 ls - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Parens x) = do - mark GHC.AnnOpenP -- '(' - markLocated x - mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where - markAST _l (GHC.UserTyVar _ n) = do - markLocated n - - markAST _ (GHC.KindedTyVar _ n ty) = do - mark GHC.AnnOpenP -- '(' - markLocated n - mark GHC.AnnDcolon -- '::' - markLocated ty - mark GHC.AnnCloseP -- '(' - - markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsType GHC.GhcPs) where - markAST loc ty = do - markType loc ty - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - where - - -- markType :: GHC.SrcSpan -> ast -> Annotated () - markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () - markType _ (GHC.HsForAllTy _ tvs typ) = do - mark GHC.AnnForall - mapM_ markLocated tvs - mark GHC.AnnDot - markLocated typ - - markType _ (GHC.HsQualTy _ cxt typ) = do - markLocated cxt - markLocated typ - - markType _ (GHC.HsTyVar _ promoted name) = do - when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote - unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name - - markType _ (GHC.HsAppTy _ t1 t2) = do - setContext (Set.singleton PrefixOp) $ markLocated t1 - markLocated t2 - - markType _ (GHC.HsFunTy _ t1 t2) = do - markLocated t1 - mark GHC.AnnRarrow - markLocated t2 - -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT - - markType _ (GHC.HsListTy _ t) = do - mark GHC.AnnOpenS -- '[' - markLocated t - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsTupleTy _ tt ts) = do - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' - _ -> markWithString GHC.AnnOpen "(#" -- '(#' - markListIntercalateWithFunLevel markLocated 2 ts - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' - _ -> markWithString GHC.AnnClose "#)" -- '#)' - - markType _ (GHC.HsSumTy _ tys) = do - markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys - markWithString GHC.AnnClose "#)" - - markType _ (GHC.HsOpTy _ t1 lo t2) = do - markLocated t1 - if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) - then do - markOptional GHC.AnnSimpleQuote - else do - mark GHC.AnnSimpleQuote - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo - markLocated t2 - - markType _ (GHC.HsParTy _ t) = do - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnCloseP -- ')' - - markType _ (GHC.HsIParamTy _ n t) = do - markLocated n - mark GHC.AnnDcolon - markLocated t - - markType l (GHC.HsStarTy _ isUnicode) = do - if isUnicode - then markExternal l GHC.AnnVal "\x2605" -- Unicode star - else markExternal l GHC.AnnVal "*" - - markType _ (GHC.HsKindSig _ t k) = do - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnDcolon -- '::' - markLocated k - mark GHC.AnnCloseP -- ')' - - markType l (GHC.HsSpliceTy _ s) = do - markAST l s - - markType _ (GHC.HsDocTy _ t ds) = do - markLocated t - markLocated ds - - markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do - case mt of - GHC.NoSourceText -> return () - GHC.SourceText src -> do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - case str of - GHC.SrcLazy -> mark GHC.AnnTilde - GHC.SrcStrict -> mark GHC.AnnBang - GHC.NoSrcStrict -> return () - - markLocated t - - markType _ (GHC.HsRecTy _ cons) = do - mark GHC.AnnOpenC -- '{' - markListIntercalate cons - mark GHC.AnnCloseC -- '}' - - markType _ (GHC.HsExplicitListTy _ promoted ts) = do - when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote - mark GHC.AnnOpenS -- "[" - markListIntercalate ts - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsExplicitTupleTy _ ts) = do - mark GHC.AnnSimpleQuote - mark GHC.AnnOpenP - markListIntercalate ts - mark GHC.AnnCloseP - - markType l (GHC.HsTyLit _ lit) = do - case lit of - (GHC.HsNumTy s v) -> - markExternalSourceText l s (show v) - (GHC.HsStrTy s v) -> - markExternalSourceText l s (show v) - - markType l (GHC.HsWildCardTy _) = do - markExternal l GHC.AnnVal "_" - - markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x - - --- --------------------------------------------------------------------- - --- instance Annotate (GHC.HsAppType GHC.GhcPs) where --- markAST _ (GHC.HsAppInfix _ n) = do --- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote --- setContext (Set.singleton InfixOp) $ markLocated n --- markAST _ (GHC.HsAppPrefix _ t) = do --- markOptional GHC.AnnTilde --- setContext (Set.singleton PrefixOp) $ markLocated t - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsSplice GHC.GhcPs) where - markAST l c = - case c of - GHC.HsQuasiQuote _ _ n _pos fs -> do - markExternal l GHC.AnnVal - -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") - - GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsTypedSplice _ hasParens _n b -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - -- ------------------------------- - - GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsUntypedSplice _ hasParens _n b -> do - case hasParens of - GHC.HasParens -> mark GHC.AnnOpenPE - GHC.HasDollar -> mark GHC.AnnThIdSplice - GHC.NoParens -> return () - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" - - -- ------------------------------- - - (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDeclField GHC.GhcPs) where - markAST _ (GHC.ConDeclField _ ns ty mdoc) = do - unsetContext Intercalate $ do - markListIntercalate ns - mark GHC.AnnDcolon - markLocated ty - markMaybe mdoc - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FieldOcc GHC.GhcPs) where - markAST _ (GHC.FieldOcc _ rn) = do - markLocated rn - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsDocString where - markAST l s = do - markExternal l GHC.AnnVal (GHC.unpackHDS s) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Pat GHC.GhcPs) where - markAST loc typ = do - markPat loc typ - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") - where - markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" - markPat l (GHC.VarPat _ n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is - -- resolved, particularly for pretty printing where annotations are added. - let pun_RDR = "pun-right-hand-side" - when (showGhc n /= pun_RDR) $ - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) - markPat _ (GHC.LazyPat _ p) = do - mark GHC.AnnTilde - markLocated p - - markPat _ (GHC.AsPat _ ln p) = do - markLocated ln - mark GHC.AnnAt - markLocated p - - markPat _ (GHC.ParPat _ p) = do - mark GHC.AnnOpenP - markLocated p - mark GHC.AnnCloseP - - markPat _ (GHC.BangPat _ p) = do - mark GHC.AnnBang - markLocated p - - markPat _ (GHC.ListPat _ ps) = do - mark GHC.AnnOpenS - markListIntercalateWithFunLevel markLocated 2 ps - mark GHC.AnnCloseS - - markPat _ (GHC.TuplePat _ pats b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevel markLocated 2 pats - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markPat _ (GHC.SumPat _ pat alt arity) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated pat - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markPat _ (GHC.ConPatIn n dets) = do - markHsConPatDetails n dets - - markPat _ GHC.ConPatOut {} = - traceM "warning: ConPatOut Introduced after renaming" - - markPat _ (GHC.ViewPat _ e pat) = do - markLocated e - mark GHC.AnnRarrow - markLocated pat - - markPat l (GHC.SplicePat _ s) = do - markAST l s - - markPat l (GHC.LitPat _ lp) = markAST l lp - - markPat _ (GHC.NPat _ ol mn _) = do - when (isJust mn) $ mark GHC.AnnMinus - markLocated ol - - markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do - markLocated ln - markWithString GHC.AnnVal "+" -- "+" - markLocated ol - - - markPat _ (GHC.SigPat ty pat) = do - markLocated pat - mark GHC.AnnDcolon - markLHsSigWcType ty - - markPat _ GHC.CoPat {} = - traceM "warning: CoPat introduced after renaming" - - markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x - --- --------------------------------------------------------------------- - -hsLit2String :: GHC.HsLit GHC.GhcPs -> String -hsLit2String lit = - case lit of - GHC.HsChar src v -> toSourceTextWithSuffix src v "" - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" - GHC.HsString src v -> toSourceTextWithSuffix src v "" - GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" - GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" - GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" - GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" - GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" - (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x - -toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String -toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix - --- -------------------------------------------------------------------- - -markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () -markHsConPatDetails ln dets = do - case dets of - GHC.PrefixCon args -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated args - GHC.RecCon (GHC.HsRecFields fs dd) -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - case dd of - Nothing -> markListIntercalateWithFunLevel markLocated 2 fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- '}' - GHC.InfixCon a1 a2 -> do - markLocated a1 - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln - markLocated a2 - -markHsConDeclDetails :: - Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () - -markHsConDeclDetails isDeprecated inGadt lns dets = do - case dets of - GHC.PrefixCon args -> - setContext (Set.singleton PrefixOp) $ mapM_ markLocated args - -- GHC.RecCon fs -> markLocated fs - GHC.RecCon fs -> do - mark GHC.AnnOpenC - if inGadt - then do - if isDeprecated - then setContext (Set.fromList [InGadt]) $ markLocated fs - else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs - else do - if isDeprecated - then markLocated fs - else setContext (Set.fromList [InRecCon]) $ markLocated fs - GHC.InfixCon a1 a2 -> do - markLocated a1 - setContext (Set.singleton InfixOp) $ mapM_ markLocated lns - markLocated a2 - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LConDeclField GHC.GhcPs] where - markAST _ fs = do - markOptional GHC.AnnOpenC -- '{' - markListIntercalate fs - markOptional GHC.AnnDotdot - inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' - inContext (Set.singleton InGadt) $ do - mark GHC.AnnRarrow - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsOverLit GHC.GhcPs) where - markAST l ol = - let str = case GHC.ol_val ol of - GHC.HsIntegral (GHC.IL src _ _) -> src - GHC.HsFractional (GHC.FL src _ _) -> src - GHC.HsIsString src _ -> src - in - markExternalSourceText l str "" - --- --------------------------------------------------------------------- - -instance (Annotate arg) - => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where - markAST _ (GHC.HsIB _ thing) = do - markLocated thing - markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.LastStmt _ body _ _) - = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - markAST _ (GHC.BindStmt _ pat body _ _) = do - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat - mark GHC.AnnLarrow - unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST _ GHC.ApplicativeStmt{} - = error "ApplicativeStmt should not appear in ParsedSource" - - markAST _ (GHC.BodyStmt _ body _ _) = do - unsetContext Intercalate $ markLocated body - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST l (GHC.ParStmt _ pbs _ _) = do - -- Within a given parallel list comprehension,one of the sections to be done - -- in parallel. It is a normal list comprehension, so has a list of - -- ParStmtBlock, one for each part of the sub- list comprehension - - - ifInContext (Set.singleton Intercalate) - ( - - unsetContext Intercalate $ - markListWithContextsFunction - (LC (Set.singleton Intercalate) -- only - Set.empty -- first - Set.empty -- middle - (Set.singleton Intercalate) -- last - ) (markAST l) pbs - ) - ( - unsetContext Intercalate $ - markListWithContextsFunction - (LC Set.empty -- only - (Set.fromList [AddVbar]) -- first - (Set.fromList [AddVbar]) -- middle - Set.empty -- last - ) (markAST l) pbs - ) - markTrailingSemi - - markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do - setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts - case form of - GHC.ThenForm -> do - mark GHC.AnnThen - unsetContext Intercalate $ markLocated using - case by of - Just b -> do - mark GHC.AnnBy - unsetContext Intercalate $ markLocated b - Nothing -> return () - GHC.GroupForm -> do - mark GHC.AnnThen - mark GHC.AnnGroup - case by of - Just b -> mark GHC.AnnBy >> markLocated b - Nothing -> return () - mark GHC.AnnUsing - markLocated using - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do - mark GHC.AnnRec - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - mapM_ markLocated stmts - markOptional GHC.AnnCloseC - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- Note: We never have a located ParStmtBlock, so have nothing to hang the --- annotation on. This means there is no pushing of context from the parent ParStmt. -instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where - markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do - markListIntercalate stmts - markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where - markAST _ lb = markHsLocalBinds lb - --- --------------------------------------------------------------------- - -markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) = - applyListAnnotationsLayout - (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ) -markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds -markHsLocalBinds GHC.EmptyLocalBinds{} = return () - -markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension" -markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension" -markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension" - --- --------------------------------------------------------------------- - -markMatchGroup :: (Annotate body) - => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) - -> Annotated () -markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _) - = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsExpr GHC.GhcPs) where - markAST loc expr = do - markExpr loc expr - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - -- TODO: If the AnnComma is not needed, revert to markAST - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - where - markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do - ifInContext (Set.singleton PrefixOp) - (setContext (Set.singleton PrefixOp) $ markLocated n) - (ifInContext (Set.singleton InfixOp) - (setContext (Set.singleton InfixOp) $ markLocated n) - (markLocated n) - ) - - markExpr l (GHC.HsRecFld _ f) = markAST l f - - markExpr l (GHC.HsOverLabel _ _ fs) - = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) - - - markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) = - markAST l n - markExpr l (GHC.HsOverLit _ ov) = markAST l ov - markExpr l (GHC.HsLit _ lit) = markAST l lit - - markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do - setContext (Set.singleton LambdaExpr) $ do - -- TODO: Change this, HsLam binds do not need obey layout rules. - -- And will only ever have a single match - markLocated match - markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match" - - markExpr l (GHC.HsLamCase _ match) = do - mark GHC.AnnLam - mark GHC.AnnCase - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l match - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsApp _ e1 e2) = do - setContext (Set.singleton PrefixOp) $ markLocated e1 - setContext (Set.singleton PrefixOp) $ markLocated e2 - - markExpr _ (GHC.OpApp _ e1 e2 e3) = do - let - isInfix = case e2 of - -- TODO: generalise this. Is it a fixity thing? - GHC.L _ (GHC.HsVar{}) -> True - _ -> False - - normal = - -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context - ifInContext (Set.singleton LeftMost) - (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) - (markLocated e1) - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - else normal - - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 - else markLocated e3 - - markExpr _ (GHC.NegApp _ e _) = do - mark GHC.AnnMinus - markLocated e - - markExpr _ (GHC.HsPar _ e) = do - mark GHC.AnnOpenP -- '(' - markLocated e - mark GHC.AnnCloseP -- ')' - - markExpr _ (GHC.SectionL _ e1 e2) = do - markLocated e1 - setContext (Set.singleton InfixOp) $ markLocated e2 - - markExpr _ (GHC.SectionR _ e1 e2) = do - setContext (Set.singleton InfixOp) $ markLocated e1 - markLocated e2 - - markExpr _ (GHC.ExplicitTuple _ args b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args - - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markExpr _ (GHC.ExplicitSum _ alt arity e) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated e - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do - mark GHC.AnnCase - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - setContext (Set.singleton CaseAlt) $ markMatchGroup l matches - markOptional GHC.AnnCloseC - - -- We set the layout for HsIf even though it need not obey layout rules as - -- when moving these expressions it's useful that they maintain "internal - -- integrity", that is to say the subparts remain indented relative to each - -- other. - markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do - -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do - mark GHC.AnnIf - markLocated e1 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen - mark GHC.AnnThen - setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse - mark GHC.AnnElse - setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 - - markExpr _ (GHC.HsMultiIf _ rhs) = do - mark GHC.AnnIf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - -- mapM_ markLocated rhs - markListWithLayout rhs - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do - setLayoutFlag (do -- Make sure the 'in' gets indented too - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e) - - -- ------------------------------- - - markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do - case cts of - GHC.DoExpr -> mark GHC.AnnDo - GHC.MDoExpr -> mark GHC.AnnMdo - _ -> return () - let (ostr,cstr) = - if isListComp cts - then ("[", "]") - else ("{", "}") - - when (isListComp cts) $ markWithString GHC.AnnOpen ostr - markOptional GHC.AnnOpenS - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - if isListComp cts - then do - markLocated (last es) - mark GHC.AnnVbar - setLayoutFlag (markListIntercalate (init es)) - else do - markListWithLayout es - markOptional GHC.AnnCloseS - markOptional GHC.AnnCloseC - when (isListComp cts) $ markWithString GHC.AnnClose cstr - - -- ------------------------------- - - markExpr _ (GHC.ExplicitList _ _ es) = do - mark GHC.AnnOpenS - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es - mark GHC.AnnCloseS - - markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do - markLocated n - mark GHC.AnnOpenC - case dd of - Nothing -> markListIntercalate fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC - - markExpr _ (GHC.RecordUpd _ e fs) = do - markLocated e - mark GHC.AnnOpenC - markListIntercalate fs - mark GHC.AnnCloseC - - markExpr _ (GHC.ExprWithTySig typ e) = do - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e - mark GHC.AnnDcolon - markLHsSigWcType typ - - markExpr _ (GHC.ArithSeq _ _ seqInfo) = do - mark GHC.AnnOpenS -- '[' - case seqInfo of - GHC.From e -> do - markLocated e - mark GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - markLocated e1 - mark GHC.AnnDotdot - markLocated e2 - GHC.FromThen e1 e2 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - markLocated e3 - mark GHC.AnnCloseS -- ']' - - markExpr _ (GHC.HsSCC _ src csFStr e) = do - markAnnOpen src "{-# SCC" - let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - markWithStringOptional GHC.AnnVal txt - markWithString GHC.AnnValStr txt - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do - -- markWithString GHC.AnnOpen src -- "{-# CORE" - markAnnOpen src "{-# CORE" - -- markWithString GHC.AnnVal (GHC.sl_st csFStr) - markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - markWithString GHC.AnnClose "#-}" - markLocated e - -- TODO: make monomorphic - markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do - mark GHC.AnnSimpleQuote - setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do - mark GHC.AnnThTyQuote - markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do - markWithString GHC.AnnOpen "[d|" - markOptional GHC.AnnOpenC - setContext (Set.singleton NoAdvanceLine) - $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds - markOptional GHC.AnnCloseC - mark GHC.AnnCloseQ -- "|]" - -- Introduced after the renamer - markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) = - traceM "warning: DecBrG introduced after renamer" - markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do - mark GHC.AnnOpenEQ -- "[|" - markOptional GHC.AnnOpenE -- "[e|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do - markWithString GHC.AnnOpen "[||" - markWithStringOptional GHC.AnnOpenE "[e||" - markLocated e - markWithString GHC.AnnClose "||]" - markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do - markWithString GHC.AnnOpen "[t|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do - markWithString GHC.AnnOpen "[p|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - - markExpr _ (GHC.HsRnBracketOut {}) = - traceM "warning: HsRnBracketOut introduced after renamer" - markExpr _ (GHC.HsTcBracketOut {}) = - traceM "warning: HsTcBracketOut introduced after renamer" - - markExpr l (GHC.HsSpliceE _ e) = markAST l e - - markExpr _ (GHC.HsProc _ p c) = do - mark GHC.AnnProc - markLocated p - mark GHC.AnnRarrow - markLocated c - - markExpr _ (GHC.HsStatic _ e) = do - mark GHC.AnnStatic - markLocated e - - markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markExpr _ (GHC.HsArrForm _ e _ cs) = do - markWithString GHC.AnnOpenB "(|" - markLocated e - mapM_ markLocated cs - markWithString GHC.AnnCloseB "|)" - - markExpr _ (GHC.HsTick {}) = return () - markExpr _ (GHC.HsBinTick {}) = return () - - markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markAnnOpen src "{-# GENERATED" - markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING - - let - markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) - markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s - - markOne 1 v1 s1 -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOne 2 v2 s2 -- INTEGER - mark GHC.AnnMinus -- '-' - markOne 3 v3 s3 -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOne 4 v4 s4 -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr l (GHC.EWildPat _) = do - ifInContext (Set.fromList [InfixOp]) - (do mark GHC.AnnBackquote - markWithString GHC.AnnVal "_" - mark GHC.AnnBackquote) - (markExternal l GHC.AnnVal "_") - - markExpr _ (GHC.EAsPat _ ln e) = do - markLocated ln - mark GHC.AnnAt - markLocated e - - markExpr _ (GHC.EViewPat _ e1 e2) = do - markLocated e1 - mark GHC.AnnRarrow - markLocated e2 - - markExpr _ (GHC.ELazyPat _ e) = do - mark GHC.AnnTilde - markLocated e - - markExpr _ (GHC.HsAppType ty e) = do - markLocated e - markInstead GHC.AnnAt AnnTypeApp - markLHsWcType ty - - markExpr _ (GHC.HsWrap {}) = - traceM "warning: HsWrap introduced after renaming" - markExpr _ (GHC.HsUnboundVar {}) = - traceM "warning: HsUnboundVar introduced after renaming" - - markExpr _ (GHC.HsConLikeOut{}) = - traceM "warning: HsConLikeOut introduced after type checking" - - markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension" - markExpr _ (GHC.XExpr _) = error "markExpr got extension" - --- --------------------------------------------------------------------- - -markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () -markLHsWcType (GHC.HsWC _ ty) = do - markLocated ty -markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLit GHC.GhcPs) where - markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where - markAST _ (GHC.HsRecField lbl expr punFlag) = do - unsetContext Intercalate $ markLocated lbl - when (punFlag == False) $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated expr - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - -instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where - markAST _ (GHC.Unambiguous _ n) = markLocated n - markAST _ (GHC.Ambiguous _ n) = markLocated n - markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- |Used for declarations that need to be aligned together, e.g. in a --- do or let .. in statement/expr -instance Annotate [GHC.ExprLStmt GHC.GhcPs] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTupArg GHC.GhcPs) where - markAST _ (GHC.Present _ (GHC.L l e)) = do - markLocated (GHC.L l e) - inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) - - markAST _ (GHC.Missing _) = do - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsCmdTop GHC.GhcPs) where - markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd - markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x - -instance Annotate (GHC.HsCmd GHC.GhcPs) where - markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do - -- The AnnOpen should be marked for a prefix usage, not for a postfix one, - -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm - - let isPrefixOp = case fixity of - GHC.Infix -> False - GHC.Prefix -> True - when isPrefixOp $ mark GHC.AnnOpenB -- "(|" - - -- This may be an infix operation - applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) - (Set.singleton InfixOp) (Set.singleton InfixOp)) - (prepareListAnnotation [e] - ++ prepareListAnnotation cs) - when isPrefixOp $ mark GHC.AnnCloseB -- "|)" - - markAST _ (GHC.HsCmdApp _ e1 e2) = do - markLocated e1 - markLocated e2 - - markAST l (GHC.HsCmdLam _ match) = do - setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match - - markAST _ (GHC.HsCmdPar _ e) = do - mark GHC.AnnOpenP - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsCmdCase _ e1 matches) = do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l matches - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do - mark GHC.AnnIf - markLocated e1 - markOffset GHC.AnnSemi 0 - mark GHC.AnnThen - markLocated e2 - markOffset GHC.AnnSemi 1 - mark GHC.AnnElse - markLocated e3 - - markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e - - markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do - mark GHC.AnnDo - markOptional GHC.AnnOpenC - markListWithLayout es - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdWrap {}) = - traceM "warning: HsCmdWrap introduced after renaming" - - markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyClDecl GHC.GhcPs) where - - markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi - - markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do - -- There may be arbitrary parens around parts of the constructor that are - -- infix. - -- Turn these into comments so that they feed into the right place automatically - -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - mark GHC.AnnType - - markTyClass fixity ln tyvars - mark GHC.AnnEqual - markLocated typ - markTrailingSemi - - markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity - (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do - if nd == GHC.DataType - then mark GHC.AnnData - else mark GHC.AnnNewtype - markMaybe mctyp - markLocated ctx - markTyClass fixity ln tyVars - case mk of - Nothing -> return () - Just k -> do - mark GHC.AnnDcolon - markLocated k - if isGadt cons - then mark GHC.AnnWhere - else unless (null cons) $ mark GHC.AnnEqual - markOptional GHC.AnnWhere - markOptional GHC.AnnOpenC - setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts cons - markOptional GHC.AnnCloseC - setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds - sigs meths ats atdefs docs) = do - mark GHC.AnnClass - markLocated ctx - - markTyClass fixity ln tyVars - - unless (null fds) $ do - mark GHC.AnnVbar - markListIntercalateWithFunLevel markLocated 2 fds - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - -- AZ:TODO: we end up with both the tyVars and the following body of the - -- class defn in annSortKey for the class. This could cause problems when - -- changing things. - setContext (Set.singleton InClassDecl) $ - applyListAnnotationsLayout - (prepareListAnnotation sigs - ++ prepareListAnnotation (GHC.bagToList meths) - ++ prepareListAnnotation ats - ++ prepareListAnnotation atdefs - ++ prepareListAnnotation docs - ) - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi -{- - | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdCtxt :: LHsContext pass, -- ^ Context... - tcdLName :: Located (IdP pass), -- ^ Name of the class - tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables - tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [Located (FunDep (Located (IdP pass)))], - -- ^ Functional deps - tcdSigs :: [LSig pass], -- ^ Methods' signatures - tcdMeths :: LHsBinds pass, -- ^ Default methods - tcdATs :: [LFamilyDecl pass], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn pass], - -- ^ Associated type defaults - tcdDocs :: [LDocDecl] -- ^ Haddock docs - } - --} - - markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) - = error "extension hit for TyClDecl" - markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.XTyClDecl _) - = error "extension hit for TyClDecl" - --- --------------------------------------------------------------------- - -markTyClass :: (Annotate a, Annotate ast) - => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () -markTyClass fixity ln tyVars = do - -- There may be arbitrary parens around parts of the constructor - -- Turn these into comments so that they feed into the right place automatically - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - let markParens = if fixity == GHC.Infix && length tyVars > 2 - then markMany - else markManyOptional - if fixity == GHC.Prefix - then do - markManyOptional GHC.AnnOpenP - setContext (Set.singleton PrefixOp) $ markLocated ln - -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars - setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars - when (length tyVars >= 2) $ do - markParens GHC.AnnCloseP - setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars - markManyOptional GHC.AnnCloseP - else do - case tyVars of - (x:y:xs) -> do - markParens GHC.AnnOpenP - markLocated x - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated y - markParens GHC.AnnCloseP - mapM_ markLocated xs - markManyOptional GHC.AnnCloseP - _ -> error $ "markTyClass: Infix op without operands" - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where - markAST _ ds = mapM_ markLocated ds - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where - markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do - mark GHC.AnnDeriving - case mstrategy of - Nothing -> return () - Just (GHC.L _ (GHC.ViaStrategy{})) -> return () - Just s -> markLocated s - markLocated typs - case mstrategy of - Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s - _ -> return () - - markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x - -{- - = HsDerivingClause - { deriv_clause_ext :: XCHsDerivingClause pass - , deriv_clause_strategy :: Maybe (LDerivStrategy pass) - -- ^ The user-specified strategy (if any) to use when deriving - -- 'deriv_clause_tys'. - , deriv_clause_tys :: Located [LHsSigType pass] - -- ^ The types to derive. - -- - -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, - -- we can mention type variables that aren't bound by the datatype, e.g. - -- - -- > data T b = ... deriving (C [a]) - -- - -- should produce a derived instance for @C [a] (T b)@. - } - --} - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyDecl GHC.GhcPs) where - markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do - case info of - GHC.DataFamily -> mark GHC.AnnData - _ -> mark GHC.AnnType - - mark GHC.AnnFamily - - markTyClass fixity ln tyvars - case GHC.unLoc rsig of - GHC.NoSig _ -> return () - GHC.KindSig _ _ -> do - mark GHC.AnnDcolon - markLocated rsig - GHC.TyVarSig _ _ -> do - mark GHC.AnnEqual - markLocated rsig - (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x - case minj of - Nothing -> return () - Just inj -> do - mark GHC.AnnVbar - markLocated inj - case info of - GHC.ClosedTypeFamily (Just eqns) -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- { - markListWithLayout eqns - markOptional GHC.AnnCloseC -- } - GHC.ClosedTypeFamily Nothing -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- { - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- } - _ -> return () - markTrailingSemi - - markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _) - = error "got extension for FamilyDecl" - markAST _ (GHC.XFamilyDecl _) - = error "got extension for FamilyDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where - markAST _ (GHC.NoSig _) = return () - markAST _ (GHC.KindSig _ k) = markLocated k - markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv - markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where - markAST _ (GHC.InjectivityAnn ln lns) = do - markLocated ln - mark GHC.AnnRarrow - mapM_ markLocated lns - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where - - markAST _ (GHC.HsIB _ eqn) = do - markFamEqn eqn - markTrailingSemi - markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where - - markAST _ (GHC.FamEqn _ ln (GHC.HsQTvs _ bndrs) fixity typ) = do - mark GHC.AnnType - mark GHC.AnnInstance - markTyClass fixity ln bndrs - mark GHC.AnnEqual - markLocated typ - - markAST _ (GHC.FamEqn _ _ (GHC.XLHsQTyVars _) _ _) - = error "TyFamDefltEqn hit extension point" - markAST _ (GHC.XFamEqn _) - = error "TyFamDefltEqn hit extension point" - --- --------------------------------------------------------------------- - --- TODO: modify lexer etc, in the meantime to not set haddock flag -instance Annotate GHC.DocDecl where - markAST l v = - let str = - case v of - (GHC.DocCommentNext ds) -> GHC.unpackHDS ds - (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds - (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds - (GHC.DocGroup _i ds) -> GHC.unpackHDS ds - in - markExternal l GHC.AnnVal str >> markTrailingSemi -{- -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - --} - --- --------------------------------------------------------------------- - -markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () -markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do - markLocated ctx - markMaybe typ - if isGadt cons - then markListWithLayout cons - else markListIntercalateWithFunLevel markLocated 2 cons - setContext (Set.singleton Deriving) $ markLocated derivs -markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance Annotate [GHC.LHsType GHC.GhcPs] where - markAST l ts = do - -- Note: A single item in parens in a standalone deriving clause - -- is parsed as a HsSigType, which is always a HsForAllTy or - -- HsQualTy. Without parens it is always a HsVar. So for round - -- trip pretty printing we need to take this into account. - let - parenIfNeeded' pa = - case ts of - [] -> if l == GHC.noSrcSpan - then markManyOptional pa - else markMany pa - [GHC.L _ GHC.HsForAllTy{}] -> markMany pa - [GHC.L _ GHC.HsQualTy{}] -> markMany pa - [_] -> markManyOptional pa - _ -> markMany pa - - parenIfNeeded'' pa = - ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set? - (markMany pa) - (parenIfNeeded' pa) - - parenIfNeeded pa = - case ts of - [GHC.L _ GHC.HsParTy{}] -> markOptional pa - _ -> parenIfNeeded'' pa - - -- ------------- - - parenIfNeeded GHC.AnnOpenP - - unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts - - parenIfNeeded GHC.AnnCloseP - - ifInContext (Set.singleton NoDarrow) - (return ()) - (if null ts && (l == GHC.noSrcSpan) - then markOptional GHC.AnnDarrow - else mark GHC.AnnDarrow) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDecl GHC.GhcPs) where - markAST _ (GHC.ConDeclH98 _ ln (GHC.L _ fa) mqtvs mctx - dets _) = do - when fa $ do - mark GHC.AnnForall - mapM_ markLocated mqtvs - mark GHC.AnnDot - - case mctx of - Just ctx -> do - setContext (Set.fromList [NoDarrow]) $ markLocated ctx - mark GHC.AnnDarrow - Nothing -> return () - - case dets of - GHC.InfixCon _ _ -> return () - _ -> setContext (Set.singleton PrefixOp) $ markLocated ln - - markHsConDeclDetails False False [ln] dets - - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar - markTrailingSemi -{- - | ConDeclH98 - { con_ext :: XConDeclH98 pass - , con_name :: Located (IdP pass) - - , con_forall :: Bool -- ^ True <=> explicit user-written forall - -- e.g. data T a = forall b. MkT b (b->a) - -- con_ex_tvs = {b} - -- False => con_ex_tvs is empty - , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - --} - markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - annotationsToComments [GHC.AnnOpenP] - markLocated (GHC.L l (ResTyGADTHook forall qvars)) - markMaybe mbCxt - markHsConDeclDetails False True lns args - markLocated typ - markManyOptional GHC.AnnCloseP - markTrailingSemi -{- - = ConDeclGADT - { con_g_ext :: XConDeclGADT pass - , con_names :: [Located (IdP pass)] - - -- The next four fields describe the type after the '::' - -- See Note [GADT abstract syntax] - , con_forall :: Located Bool -- ^ True <=> explicit forall - -- False => hsq_explicit is empty - , con_qvars :: LHsQTyVars pass - -- Whether or not there is an /explicit/ forall, we still - -- need to capture the implicitly-bound type/kind variables - - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon - , con_res_ty :: LHsType pass -- ^ Result type - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - --} - - markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _) - = error "hit extension point in ConDecl" - markAST _ (GHC.XConDecl _) - = error "hit extension point in ConDecl" - --- ResTyGADT has a SrcSpan for the original sigtype, we need to create --- a type for exactPC and annotatePC -data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs] - deriving (Typeable) -deriving instance Data (ResTyGADTHook) - -instance GHC.Outputable ResTyGADTHook where - ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs - - --- WildCardAnon exists because the GHC anonymous wildcard type is defined as --- = AnonWildCard (PostRn name Name) --- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but --- the instance doing this is parameterised on name, so we cannot put a value in --- for the (PostRn name Name) field. This is used instead. -data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable) - -instance Annotate WildCardAnon where - markAST l WildCardAnon = do - markExternal l GHC.AnnVal "_" - --- --------------------------------------------------------------------- - -instance Annotate ResTyGADTHook where - markAST _ (ResTyGADTHook forall bndrs) = do - when forall $ mark GHC.AnnForall - mapM_ markLocated bndrs - when forall $ mark GHC.AnnDot - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - - markAST _ (ls,rs') = do - mapM_ markLocated ls - mark GHC.AnnRarrow - mapM_ markLocated rs' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate GHC.CType where - markAST _ (GHC.CType src mh f) = do - -- markWithString GHC.AnnOpen src - markAnnOpen src "" - case mh of - Nothing -> return () - Just (GHC.Header srcH _h) -> - -- markWithString GHC.AnnHeader srcH - markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") - -- markWithString GHC.AnnVal (fst f) - markSourceText (fst f) (GHC.unpackFS $ snd f) - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -stringLiteralToString :: GHC.StringLiteral -> String -stringLiteralToString (GHC.StringLiteral st fs) = - case st of - GHC.NoSourceText -> GHC.unpackFS fs - GHC.SourceText src -> src diff --git a/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs deleted file mode 100644 --- a/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2935 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} - - --- | 'annotate' is a function which given a GHC AST fragment, constructs --- a syntax tree which indicates which annotations belong to each specific --- part of the fragment. --- --- "Delta" and "Print" provide two interpreters for this structure. You --- should probably use those unless you know what you're doing! --- --- The functor 'AnnotationF' has a number of constructors which correspond --- to different sitations which annotations can arise. It is hoped that in --- future versions of GHC these can be simplified by making suitable --- modifications to the AST. - -module Language.Haskell.GHC.ExactPrint.Annotater - ( - annotate - , AnnotationF(..) - , Annotated - , Annotate(..) - , withSortKeyContextsHelper - ) where - - -import Language.Haskell.GHC.ExactPrint.AnnotateTypes -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified BooleanFormula as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC --- import qualified HsDoc as GHC -import qualified Name as GHC -import qualified RdrName as GHC -import qualified Outputable as GHC -import qualified SrcLoc as GHC - -import Control.Monad.Identity -import Data.Data -import Data.Maybe - -import qualified Data.Set as Set - -import Debug.Trace - - -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} --- --------------------------------------------------------------------- - -class Data ast => Annotate ast where - markAST :: GHC.SrcSpan -> ast -> Annotated () - --- --------------------------------------------------------------------- - --- | Construct a syntax tree which represent which KeywordIds must appear --- where. -annotate :: (Annotate ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated () -annotate = markLocated - --- instance Annotate (GHC.SrcSpanLess ast) where --- markAST s ast = undefined -instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where - markAST l (GHC.L _ ast) = markAST l ast - --- --------------------------------------------------------------------- - --- | Constructs a syntax tree which contains information about which --- annotations are required by each element. -markLocated :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => ast -> Annotated () -markLocated ast = - case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of - Just d -> markLHsDecl d - Nothing -> withLocated ast markAST - --- --------------------------------------------------------------------- - --- |When adding missing annotations, do not put a preceding space in front of a list -markListNoPrecedingSpace :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => Bool -> [ast] -> Annotated () -markListNoPrecedingSpace intercal ls = - case ls of - [] -> return () - (l:ls') -> do - if intercal - then do - if null ls' - then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l - else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l - markListIntercalate ls' - else do - setContext (Set.singleton NoPrecedingSpace) $ markLocated l - mapM_ markLocated ls' - --- --------------------------------------------------------------------- - - --- |Mark a list, with the given keyword as a list item separator -markListIntercalate :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => [ast] -> Annotated () -markListIntercalate ls = markListIntercalateWithFun markLocated ls - --- --------------------------------------------------------------------- - -markListWithContexts :: Annotate ast - => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () -markListWithContexts ctxInitial ctxRest ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxInitial 2 $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial 2 $ markLocated x - setContextLevel ctxRest 2 $ mapM_ markLocated xs - --- --------------------------------------------------------------------- - --- Context for only if just one, else first item, middle ones, and last one -markListWithContexts' :: Annotate ast - => ListContexts - -> [GHC.Located ast] -> Annotated () -markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxOnly level $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial level $ markLocated x - go xs - where - level = 2 - go [] = return () - go [x] = setContextLevel ctxLast level $ markLocated x - go (x:xs) = do - setContextLevel ctxMiddle level $ markLocated x - go xs - - --- --------------------------------------------------------------------- - -markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () -markListWithLayout ls = - setLayoutFlag $ markList ls - --- --------------------------------------------------------------------- - -markList :: Annotate ast => [GHC.Located ast] -> Annotated () -markList ls = - setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts' ls - -markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markLocalBindsWithLayout binds = markHsLocalBinds binds - --- --------------------------------------------------------------------- - --- |This function is used to get around shortcomings in the GHC AST for 7.10.1 -markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () -markLocatedFromKw kw (GHC.L l a) = do - -- Note: l is needed so that the pretty printer can make something up - ss <- getSrcSpanForKw l kw - AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) - markLocated (GHC.L ss' a) - --- --------------------------------------------------------------------- - -markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () -markMaybe Nothing = return () -markMaybe (Just ast) = markLocated ast - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] -prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsModule GHC.GhcPs) where - markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do - - case mmn of - Nothing -> return () - Just (GHC.L ln mn) -> do - mark GHC.AnnModule - markExternal ln GHC.AnnVal (GHC.moduleNameString mn) - - forM_ mdepr markLocated - forM_ mexp markLocated - - mark GHC.AnnWhere - - markOptional GHC.AnnOpenC -- Possible '{' - markManyOptional GHC.AnnSemi -- possible leading semis - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps - - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs - - markOptional GHC.AnnCloseC -- Possible '}' - - markEOF - --- --------------------------------------------------------------------- - -instance Annotate GHC.WarningTxt where - markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# WARNING" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# DEPRECATED" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate GHC.StringLiteral where - markAST l (GHC.StringLiteral src fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SourceText,GHC.FastString) where - markAST l (src,fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LIE GHC.GhcPs] where - markAST _ ls = do - inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl - mark GHC.AnnOpenP -- '(' - -- Can't use markListIntercalate, there can be trailing commas, but only in imports. - markListIntercalateWithFunLevel markLocated 2 ls - - mark GHC.AnnCloseP -- ')' - -instance Annotate (GHC.IE GHC.GhcPs) where - markAST _ ie = do - - case ie of - GHC.IEVar _ ln -> markLocated ln - - GHC.IEThingAbs _ ln -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - - GHC.IEThingWith _ ln wc ns _lfs -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnOpenP - case wc of - GHC.NoIEWildcard -> - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns - GHC.IEWildcard n -> do - setContext (Set.fromList [PrefixOp,Intercalate]) - $ mapM_ markLocated (take n ns) - mark GHC.AnnDotdot - case drop n ns of - [] -> return () - ns' -> do - mark GHC.AnnComma - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns' - mark GHC.AnnCloseP - - (GHC.IEThingAll _ ln) -> do - setContext (Set.fromList [PrefixOp]) $ markLocated ln - mark GHC.AnnOpenP - mark GHC.AnnDotdot - mark GHC.AnnCloseP - - (GHC.IEModuleContents _ (GHC.L lm mn)) -> do - mark GHC.AnnModule - markExternal lm GHC.AnnVal (GHC.moduleNameString mn) - - -- Only used in Haddock mode so we can ignore them. - (GHC.IEGroup {}) -> return () - - (GHC.IEDoc {}) -> return () - - (GHC.IEDocNamed {}) -> return () - GHC.XIE x -> error $ "got XIE for :" ++ showGhc x - ifInContext (Set.fromList [Intercalate]) - (mark GHC.AnnComma) - (markOptional GHC.AnnComma) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IEWrappedName GHC.RdrName) where - markAST _ (GHC.IEName ln) = do - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEPattern ln) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEType ln) = do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -isSymRdr :: GHC.RdrName -> Bool -isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." - -instance Annotate GHC.RdrName where - markAST l n = do - let - str = rdrName2String n - isSym = isSymRdr n - doNormalRdrName = do - let str' = case str of - -- TODO: unicode support? - "forall" -> if spanLength l == 1 then "∀" else str - _ -> str - - let - markParen :: GHC.AnnKeywordId -> Annotated () - markParen pa = do - if isSym - then ifInContext (Set.fromList [PrefixOp,PrefixOpDollar]) - (mark pa) -- '(' - (markOptional pa) - else markOptional pa - - markOptional GHC.AnnSimpleQuote - markParen GHC.AnnOpenP - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 - cnt <- countAnns GHC.AnnVal - case cnt of - 0 -> markExternal l GHC.AnnVal str' - 1 -> markWithString GHC.AnnVal str' - _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 - markParen GHC.AnnCloseP - - case n of - GHC.Unqual _ -> doNormalRdrName - GHC.Qual _ _ -> doNormalRdrName - GHC.Orig _ _ -> if str == "~" - then doNormalRdrName - -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen) - else markExternal l GHC.AnnVal str - -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str - -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]" - GHC.Exact n' -> do - case str of - -- Special handling for Exact RdrNames, which are built-in Names - "[]" -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnCloseS -- ']' - "()" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnCloseP -- ')' - ('(':'#':_) -> do - markWithString GHC.AnnOpen "(#" -- '(#' - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - markWithString GHC.AnnClose "#)"-- '#)' - "[::]" -> do - markWithString GHC.AnnOpen "[:" -- '[:' - markWithString GHC.AnnClose ":]" -- ':]' - "->" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnRarrow - mark GHC.AnnCloseP -- ')' - -- "~#" -> do - -- mark GHC.AnnOpenP -- '(' - -- mark GHC.AnnTildehsh - -- mark GHC.AnnCloseP - "~" -> do - doNormalRdrName - "*" -> do - markExternal l GHC.AnnVal str - "★" -> do -- Note: unicode star - markExternal l GHC.AnnVal str - ":" -> do - -- Note: The OccName for ":" has the following attributes (via occAttributes) - -- (d, Data DataSym Sym Val ) - -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - doNormalRdrName - -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName - ('(':',':_) -> do - mark GHC.AnnOpenP - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - mark GHC.AnnCloseP -- ')' - _ -> do - let isSym' = isSymRdr (GHC.nameRdrName n') - when isSym' $ mark GHC.AnnOpenP -- '(' - markWithString GHC.AnnVal str - when isSym $ mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ImportDecl GHC.GhcPs) where - markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do - - -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - mark GHC.AnnImport - - -- "{-# SOURCE" and "#-}" - case msrc of - GHC.SourceText _txt -> do - markAnnOpen msrc "{-# SOURCE" - markWithString GHC.AnnClose "#-}" - GHC.NoSourceText -> return () - when safeflag (mark GHC.AnnSafe) - when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) - case mpkg of - Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> - markWithString GHC.AnnPackageName srcPkg - _ -> return () - - markLocated modname - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - mark GHC.AnnAs - markLocated mn - - case hiding of - Nothing -> return () - Just (isHiding,lie) -> do - if isHiding - then setContext (Set.singleton HasHiding) $ - markLocated lie - else markLocated lie - markTrailingSemi - - markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.ModuleName where - markAST l mname = - markExternal l GHC.AnnVal (GHC.moduleNameString mname) - --- --------------------------------------------------------------------- - -markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () -markLHsDecl (GHC.L l decl) = - case decl of - GHC.TyClD _ d -> markLocated (GHC.L l d) - GHC.InstD _ d -> markLocated (GHC.L l d) - GHC.DerivD _ d -> markLocated (GHC.L l d) - GHC.ValD _ d -> markLocated (GHC.L l d) - GHC.SigD _ d -> markLocated (GHC.L l d) - GHC.DefD _ d -> markLocated (GHC.L l d) - GHC.ForD _ d -> markLocated (GHC.L l d) - GHC.WarningD _ d -> markLocated (GHC.L l d) - GHC.AnnD _ d -> markLocated (GHC.L l d) - GHC.RuleD _ d -> markLocated (GHC.L l d) - GHC.SpliceD _ d -> markLocated (GHC.L l d) - GHC.DocD _ d -> markLocated (GHC.L l d) - GHC.RoleAnnotD _ d -> markLocated (GHC.L l d) - GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x - -instance Annotate (GHC.HsDecl GHC.GhcPs) where - markAST l d = markLHsDecl (GHC.L l d) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where - markAST _ (GHC.RoleAnnotDecl _ ln mr) = do - mark GHC.AnnType - mark GHC.AnnRole - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated mr - markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x - -instance Annotate (Maybe GHC.Role) where - markAST l Nothing = markExternal l GHC.AnnVal "_" - markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SpliceDecl GHC.GhcPs) where - markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do - markLocated e - markTrailingSemi - markAST _ (GHC.SpliceDecl _ e _flag) = do - markLocated e - markTrailingSemi - - markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecls GHC.GhcPs) where - markAST _ (GHC.HsRules _ src rules) = do - markAnnOpen src "{-# RULES" - setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules - markWithString GHC.AnnClose "#-}" - markTrailingSemi - markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecl GHC.GhcPs) where - markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do - markLocated ln - setContext (Set.singleton ExplicitNeverActive) $ markActivation l act - - case mtybndrs of - Nothing -> return () - Just bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - mark GHC.AnnForall - mapM_ markLocated termbndrs - mark GHC.AnnDot - - markLocated lhs - mark GHC.AnnEqual - markLocated rhs - inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi - markTrailingSemi -{- - = HsRule -- Source rule - { rd_ext :: XHsRule pass - -- ^ After renamer, free-vars from the LHS and RHS - , rd_name :: Located (SourceText,RuleName) - -- ^ Note [Pragma source text] in BasicTypes - , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] - -- ^ Forall'd type vars - , rd_tmvs :: [LRuleBndr pass] - -- ^ Forall'd term vars, before typechecking; after typechecking - -- this includes all forall'd vars - , rd_lhs :: Located (HsExpr pass) - , rd_rhs :: Located (HsExpr pass) - } - --} - - markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () -markActivation _ act = do - case act of - GHC.ActiveBefore src phase -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.ActiveAfter src phase -> do - mark GHC.AnnOpenS -- '[' - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.NeverActive -> do - inContext (Set.singleton ExplicitNeverActive) $ do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - mark GHC.AnnCloseS -- ']' - _ -> return () - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleBndr GHC.GhcPs) where - markAST _ (GHC.RuleBndr _ ln) = markLocated ln - markAST _ (GHC.RuleBndrSig _ ln st) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLHsSigWcType st - mark GHC.AnnCloseP -- ")" - markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x - --- --------------------------------------------------------------------- - -markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () -markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do - markLocated ty -markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit" -markLHsSigWcType (GHC.XHsWildCardBndrs _) = error "markLHsSigWcType extension hit" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.AnnDecl GHC.GhcPs) where - markAST _ (GHC.HsAnnotation _ src prov e) = do - markAnnOpen src "{-# ANN" - case prov of - (GHC.ValueAnnProvenance n) -> markLocated n - (GHC.TypeAnnProvenance n) -> do - mark GHC.AnnType - markLocated n - GHC.ModuleAnnProvenance -> mark GHC.AnnModule - - markLocated e - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecls GHC.GhcPs) where - markAST _ (GHC.Warnings _ src warns) = do - markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED - mapM_ markLocated warns - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecl GHC.GhcPs) where - markAST _ (GHC.Warning _ lns txt) = do - markListIntercalate lns - mark GHC.AnnOpenS -- "[" - case txt of - GHC.WarningTxt _src ls -> markListIntercalate ls - GHC.DeprecatedTxt _src ls -> markListIntercalate ls - mark GHC.AnnCloseS -- "]" - - markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x - -instance Annotate GHC.FastString where - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - markAST l fs = do - markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ForeignDecl GHC.GhcPs) where - markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnImport - markLocated cconv - unless (ll == GHC.noSrcSpan) $ markLocated safety - markExternalSourceText ls src "" - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnExport - markLocated spec - markExternal ls GHC.AnnVal (sourceTextToString src "") - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLocated typ - - - markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" - markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" - markAST _ (GHC.XForeignDecl _) = error "markAST ForeignDecl hit extenstion" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CExportSpec) where - markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CCallConv) where - markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" - markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" - markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" - markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" - markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.Safety) where - markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" - markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" - markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivDecl GHC.GhcPs) where - - markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do - mark GHC.AnnDeriving - markMaybe ms - mark GHC.AnnInstance - markMaybe mov - markLocated typ - markTrailingSemi - -{- -data DerivDecl pass = DerivDecl - { deriv_ext :: XCDerivDecl pass - , deriv_type :: LHsSigWcType pass - -- ^ The instance type to derive. - -- - -- It uses an 'LHsSigWcType' because the context is allowed to be a - -- single wildcard: - -- - -- > deriving instance _ => Eq (Foo a) - -- - -- Which signifies that the context should be inferred. - - -- See Note [Inferring the instance context] in TcDerivInfer. - - , deriv_strategy :: Maybe (LDerivStrategy pass) - , deriv_overlap_mode :: Maybe (Located OverlapMode) - -type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both - -data HsWildCardBndrs pass thing - -- See Note [HsType binders] - -- See Note [The wildcard story for types] - = HsWC { hswc_ext :: XHsWC pass thing - -- after the renamer - -- Wild cards, both named and anonymous - - , hswc_body :: thing - -- Main payload (type or list of types) - -- If there is an extra-constraints wildcard, - -- it's still there in the hsc_body. - } - - --} - - - markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension" - markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _) = error "markAST DerivDecl hit extension" - markAST _ (GHC.XDerivDecl _) = error "markAST DerivDecl hit extension" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivStrategy GHC.GhcPs) where - - markAST _ GHC.StockStrategy = mark GHC.AnnStock - markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass - markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype - markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do - mark GHC.AnnVia - markLocated ty - markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _)) - = error $ "got XHsImplicitBndrs in AnnDerivStrategy" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DefaultDecl GHC.GhcPs) where - - markAST _ (GHC.DefaultDecl _ typs) = do - mark GHC.AnnDefault - mark GHC.AnnOpenP -- '(' - markListIntercalate typs - mark GHC.AnnCloseP -- ')' - markTrailingSemi - - markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InstDecl GHC.GhcPs) where - - markAST l (GHC.ClsInstD _ cid) = markAST l cid - markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid - markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid - markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.OverlapMode where - - -- NOTE: NoOverlap is only used in the typechecker - markAST _ (GHC.NoOverlap src) = do - markAnnOpen src "{-# NO_OVERLAP" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlappable src) = do - markAnnOpen src "{-# OVERLAPPABLE" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlapping src) = do - markAnnOpen src "{-# OVERLAPPING" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlaps src) = do - markAnnOpen src "{-# OVERLAPS" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Incoherent src) = do - markAnnOpen src "{-# INCOHERENT" - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where - - markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do - mark GHC.AnnInstance - markMaybe mov - markLocated poly - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - - applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ++ prepareListAnnotation tyfams - ++ prepareListAnnotation datafams - ) - - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl" - markAST _ (GHC.XClsInstDecl _) = error "extension hit for ClsInstDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where -{- -newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } - -type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) - -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) - - --} - markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do - mark GHC.AnnType - mark GHC.AnnInstance -- Note: this keyword is optional - markFamEqn eqn - markTrailingSemi - - markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl" - --- --------------------------------------------------------------------- - --- markFamEqn :: (GHC.HasOccName (GHC.IdP pass), --- Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) --- => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) --- -> Annotated () -markFamEqn :: GHC.FamEqn GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs) - -> Annotated () -markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do - markTyClassArgs bndrs fixity ln pats - mark GHC.AnnEqual - markLocated rhs -{- -data FamEqn pass pats rhs - = FamEqn - { feqn_ext :: XCFamEqn pass pats rhs - , feqn_tycon :: Located (IdP pass) - , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars - , feqn_pats :: pats - , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , feqn_rhs :: rhs - } --} - -markFamEqn (GHC.XFamEqn _) = error "got XFamEqn" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where - - markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs pats fixity - defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do - case GHC.dd_ND defn of - GHC.NewType -> mark GHC.AnnNewtype - GHC.DataType -> mark GHC.AnnData - mark GHC.AnnInstance - - markLocated ctx - - markTyClassArgs bndrs fixity ln pats - - case (GHC.dd_kindSig defn) of - Just s -> do - mark GHC.AnnDcolon - markLocated s - Nothing -> return () - if isGadt $ GHC.dd_cons defn - then mark GHC.AnnWhere - else unless (null cons) $ mark GHC.AnnEqual - markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs) - markTrailingSemi - - markAST _ - (GHC.DataFamInstDecl - (GHC.HsIB _ (GHC.FamEqn _ _ _ _ _ (GHC.XHsDataDefn _)))) - = error "extension hit for DataFamInstDecl" - markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _))) - = error "extension hit for DataFamInstDecl" - markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _)) - = error "extension hit for DataFamInstDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsBind GHC.GhcPs) where - markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do - -- Note: from a layout perspective a FunBind should not exist, so the - -- current context is passed through unchanged to the matches. - -- TODO: perhaps bring the edp from the first match up to the annotation for - -- the FunBind. - let - tlFun = - ifInContext (Set.fromList [CtxOnly,CtxFirst]) - (markListWithContexts' listContexts matches) - (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) - ifInContext (Set.singleton TopLevel) - (setContextLevel (Set.singleton TopLevel) 2 tlFun) - tlFun - - -- ----------------------------------- - - markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do - markLocated lhs - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards - _ -> return () - markListIntercalateWithFunLevel markLocated 2 grhs - - -- TODO: extract this common code - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.VarBind _ _n rhse _) = - -- Note: this bind is introduced by the typechecker - markLocated rhse - - -- ----------------------------------- - - -- Introduced after renaming. - markAST _ (GHC.AbsBinds {}) = - traceM "warning: AbsBinds introduced after renaming" - - -- ----------------------------------- - - markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do - mark GHC.AnnPattern - case args of - GHC.InfixCon la lb -> do - markLocated la - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated lb - GHC.PrefixCon ns -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated ns - GHC.RecCon fs -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs - mark GHC.AnnCloseC -- '}' - case dir of - GHC.ImplicitBidirectional -> mark GHC.AnnEqual - _ -> mark GHC.AnnLarrow - - markLocated def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markMatchGroup l mg - mark GHC.AnnCloseC -- '}' - - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _) - = error "extension hit for HsBind" - markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _) - = error "extension hit for HsBind" - markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _)) - = error "extension hit for HsBind" - markAST _ (GHC.XHsBindsLR _) - = error "extension hit for HsBind" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IPBind GHC.GhcPs) where - markAST _ (GHC.IPBind _ en e) = do - case en of - Left n -> markLocated n - Right _i -> return () - mark GHC.AnnEqual - markLocated e - markTrailingSemi - - -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x - markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsIPName where - markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do - let - get_infix (GHC.FunRhs _ f _) = f - get_infix _ = GHC.Prefix - - isFunBind GHC.FunRhs{} = True - isFunBind _ = False - case (get_infix mln,pats) of - (GHC.Infix, a:b:xs) -> do - if null xs - then markOptional GHC.AnnOpenP - else mark GHC.AnnOpenP - markLocated a - case mln of - GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n - _ -> return () - markLocated b - if null xs - then markOptional GHC.AnnCloseP - else mark GHC.AnnCloseP - mapM_ markLocated xs - _ -> do - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam - case mln of - GHC.FunRhs n _ s -> do - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do - when (s == GHC.SrcStrict) $ mark GHC.AnnBang - markLocated n - mapM_ markLocated pats - _ -> markListNoPrecedingSpace False pats - - -- TODO: The AnnEqual annotation actually belongs in the first GRHS value - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards - _ -> return () - inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam - mapM_ markLocated grhs - - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _)) - = error "hit extension for Match" - markAST _ (GHC.XMatch _) - = error "hit extension for Match" - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where - markAST _ (GHC.GRHS _ guards expr) = do - case guards of - [] -> return () - (_:_) -> do - mark GHC.AnnVbar - unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) - $ markListIntercalate guards - ifInContext (Set.fromList [CaseAlt]) - (return ()) - (mark GHC.AnnEqual) - - markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test - - inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam - setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr - - markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Sig GHC.GhcPs) where - - markAST _ (GHC.TypeSig _ lns st) = do - setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns - mark GHC.AnnDcolon - markLHsSigWcType st - markTrailingSemi - tellContext (Set.singleton FollowingLine) - - markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do - when isDefault $ mark GHC.AnnDefault - setContext (Set.singleton PrefixOp) $ markListIntercalate ns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.IdSig {}) = - traceM "warning: Introduced after renaming" - - markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do - let fixstr = case fdir of - GHC.InfixL -> "infixl" - GHC.InfixR -> "infixr" - GHC.InfixN -> "infix" - markWithString GHC.AnnInfix fixstr - markSourceText src (show v) - setContext (Set.singleton InfixOp) $ markListIntercalate lns - markTrailingSemi - - markAST l (GHC.InlineSig _ ln inl) = do - markAnnOpen (GHC.inl_src inl) "{-# INLINE" - markActivation l (GHC.inl_act inl) - setContext (Set.singleton PrefixOp) $ markLocated ln - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - markAST l (GHC.SpecSig _ ln typs inl) = do - markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE - markActivation l (GHC.inl_act inl) - markLocated ln - mark GHC.AnnDcolon -- '::' - markListIntercalateWithFunLevel markLHsSigType 2 typs - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.SpecInstSig _ src typ) = do - markAnnOpen src "{-# SPECIALISE" - mark GHC.AnnInstance - markLHsSigType typ - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.MinimalSig _ src formula) = do - markAnnOpen src "{-# MINIMAL" - markLocated formula - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.SCCFunSig _ src ln ml) = do - markAnnOpen src "{-# SCC" - markLocated ln - markMaybe ml - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do - markAnnOpen src "{-# COMPLETE" - markListIntercalate ns - case mlns of - Nothing -> return () - Just _ -> do - mark GHC.AnnDcolon - markMaybe mlns - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - -- ----------------------------------- - markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _)) - = error "hit extension for Sig" - markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _)) - = error "hit extension for Sig" - markAST _ (GHC.FixSig _ (GHC.XFixitySig _)) - = error "hit extension for Sig" - markAST _ (GHC.XSig _) - = error "hit extension for Sig" - --- -------------------------------------------------------------------- - -markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () -markLHsSigType (GHC.HsIB _ typ) = markLocated typ -markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - -instance Annotate [GHC.LHsSigType GHC.GhcPs] where - markAST _ ls = do - -- mark GHC.AnnDeriving - -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it - -- is a HsTyVar. So for round trip pretty printing we need to take this into - -- account. - let marker = case ls of - [] -> markManyOptional - [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t) - then markMany - else markManyOptional - _ -> markMany -- Need parens if more than one entry - marker GHC.AnnOpenP - markListIntercalateWithFun markLHsSigType ls - marker GHC.AnnCloseP - --- -------------------------------------------------------------------- - -instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where - markAST _ (GHC.Var x) = do - setContext (Set.singleton PrefixOp) $ markLocated x - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls - markAST _ (GHC.And ls) = do - markListIntercalateWithFunLevel markLocated 2 ls - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Parens x) = do - mark GHC.AnnOpenP -- '(' - markLocated x - mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where - markAST _l (GHC.UserTyVar _ n) = do - markLocated n - - markAST _ (GHC.KindedTyVar _ n ty) = do - mark GHC.AnnOpenP -- '(' - markLocated n - mark GHC.AnnDcolon -- '::' - markLocated ty - mark GHC.AnnCloseP -- '(' - - markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsType GHC.GhcPs) where - markAST loc ty = do - inContext (Set.fromList [InTypeApp]) $ mark GHC.AnnAt - markType loc ty - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - where - - -- markType :: GHC.SrcSpan -> ast -> Annotated () - markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () - markType _ (GHC.HsForAllTy _ 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.IsPromoted) $ mark GHC.AnnSimpleQuote - unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name - - markType _ (GHC.HsAppTy _ t1 t2) = do - setContext (Set.singleton PrefixOp) $ markLocated t1 - markLocated t2 - - markType _ (GHC.HsAppKindTy l t k) = do - setContext (Set.singleton PrefixOp) $ markLocated t - markTypeApp l - markLocated k - - markType _ (GHC.HsFunTy _ t1 t2) = do - markLocated t1 - mark GHC.AnnRarrow - markLocated t2 - -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT - - markType _ (GHC.HsListTy _ t) = do - mark GHC.AnnOpenS -- '[' - markLocated t - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsTupleTy _ tt ts) = do - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' - _ -> markWithString GHC.AnnOpen "(#" -- '(#' - markListIntercalateWithFunLevel markLocated 2 ts - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' - _ -> markWithString GHC.AnnClose "#)" -- '#)' - - markType _ (GHC.HsSumTy _ tys) = do - markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys - markWithString GHC.AnnClose "#)" - - markType _ (GHC.HsOpTy _ t1 lo t2) = do - markLocated t1 - if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) - then do - markOptional GHC.AnnSimpleQuote - else do - mark GHC.AnnSimpleQuote - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo - markLocated t2 - - markType _ (GHC.HsParTy _ t) = do - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnCloseP -- ')' - - markType _ (GHC.HsIParamTy _ n t) = do - markLocated n - mark GHC.AnnDcolon - markLocated t - - markType l (GHC.HsStarTy _ isUnicode) = do - if isUnicode - then markExternal l GHC.AnnVal "\x2605" -- Unicode star - else markExternal l GHC.AnnVal "*" - - markType _ (GHC.HsKindSig _ t k) = do - markOptional GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnDcolon -- '::' - markLocated k - markOptional GHC.AnnCloseP -- ')' - - markType l (GHC.HsSpliceTy _ s) = do - markAST l s - - markType _ (GHC.HsDocTy _ t ds) = do - markLocated t - markLocated ds - - markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do - case mt of - GHC.NoSourceText -> return () - GHC.SourceText src -> do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - case str of - GHC.SrcLazy -> mark GHC.AnnTilde - GHC.SrcStrict -> mark GHC.AnnBang - GHC.NoSrcStrict -> return () - - markLocated t - - markType _ (GHC.HsRecTy _ cons) = do - mark GHC.AnnOpenC -- '{' - markListIntercalate cons - mark GHC.AnnCloseC -- '}' - - markType _ (GHC.HsExplicitListTy _ promoted ts) = do - when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote - mark GHC.AnnOpenS -- "[" - markListIntercalate ts - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsExplicitTupleTy _ ts) = do - mark GHC.AnnSimpleQuote - mark GHC.AnnOpenP - markListIntercalate ts - mark GHC.AnnCloseP - - markType l (GHC.HsTyLit _ lit) = do - case lit of - (GHC.HsNumTy s v) -> - markExternalSourceText l s (show v) - (GHC.HsStrTy s v) -> - markExternalSourceText l s (show v) - - markType l (GHC.HsWildCardTy _) = do - markExternal l GHC.AnnVal "_" - - markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x - - --- --------------------------------------------------------------------- - --- instance Annotate (GHC.HsAppType GHC.GhcPs) where --- markAST _ (GHC.HsAppInfix _ n) = do --- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote --- setContext (Set.singleton InfixOp) $ markLocated n --- markAST _ (GHC.HsAppPrefix _ t) = do --- markOptional GHC.AnnTilde --- setContext (Set.singleton PrefixOp) $ markLocated t - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsSplice GHC.GhcPs) where - markAST l c = - case c of - GHC.HsQuasiQuote _ _ n _pos fs -> do - markExternal l GHC.AnnVal - -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") - - GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsTypedSplice _ hasParens _n b -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - -- ------------------------------- - - GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do - when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE - if (hasParens == GHC.HasDollar) - then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - else markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsUntypedSplice _ hasParens _n b -> do - case hasParens of - GHC.HasParens -> mark GHC.AnnOpenPE - GHC.HasDollar -> mark GHC.AnnThIdSplice - GHC.NoParens -> return () - markLocated b - when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP - - GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" - GHC.HsSplicedT{} -> error "HsSplicedT only exists between renamer and typechecker in GHC" - - -- ------------------------------- - - (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDeclField GHC.GhcPs) where - markAST _ (GHC.ConDeclField _ ns ty mdoc) = do - unsetContext Intercalate $ do - markListIntercalate ns - mark GHC.AnnDcolon - markLocated ty - markMaybe mdoc - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FieldOcc GHC.GhcPs) where - markAST _ (GHC.FieldOcc _ rn) = do - markLocated rn - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsDocString where - markAST l s = do - markExternal l GHC.AnnVal (GHC.unpackHDS s) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Pat GHC.GhcPs) where - markAST loc typ = do - markPat loc typ - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") - where - markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" - markPat l (GHC.VarPat _ n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is - -- resolved, particularly for pretty printing where annotations are added. - let pun_RDR = "pun-right-hand-side" - when (showGhc n /= pun_RDR) $ - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) - -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n - markPat _ (GHC.LazyPat _ p) = do - mark GHC.AnnTilde - markLocated p - - markPat _ (GHC.AsPat _ ln p) = do - markLocated ln - mark GHC.AnnAt - markLocated p - - markPat _ (GHC.ParPat _ p) = do - mark GHC.AnnOpenP - markLocated p - mark GHC.AnnCloseP - - markPat _ (GHC.BangPat _ p) = do - mark GHC.AnnBang - markLocated p - - markPat _ (GHC.ListPat _ ps) = do - mark GHC.AnnOpenS - markListIntercalateWithFunLevel markLocated 2 ps - mark GHC.AnnCloseS - - markPat _ (GHC.TuplePat _ pats b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevel markLocated 2 pats - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markPat _ (GHC.SumPat _ pat alt arity) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated pat - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markPat _ (GHC.ConPatIn n dets) = do - markHsConPatDetails n dets - - markPat _ GHC.ConPatOut {} = - traceM "warning: ConPatOut Introduced after renaming" - - markPat _ (GHC.ViewPat _ e pat) = do - markLocated e - mark GHC.AnnRarrow - markLocated pat - - markPat l (GHC.SplicePat _ s) = do - markAST l s - - markPat l (GHC.LitPat _ lp) = markAST l lp - - markPat _ (GHC.NPat _ ol mn _) = do - when (isJust mn) $ mark GHC.AnnMinus - markLocated ol - - markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do - markLocated ln - markWithString GHC.AnnVal "+" -- "+" - markLocated ol - - - markPat _ (GHC.SigPat _ pat ty) = do - markLocated pat - mark GHC.AnnDcolon - markLHsSigWcType ty - - markPat _ GHC.CoPat {} = - traceM "warning: CoPat introduced after renaming" - - markPat _ (GHC.XPat (GHC.L l p)) = markPat l p - -- markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x - --- --------------------------------------------------------------------- - -hsLit2String :: GHC.HsLit GHC.GhcPs -> String -hsLit2String lit = - case lit of - GHC.HsChar src v -> toSourceTextWithSuffix src v "" - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" - GHC.HsString src v -> toSourceTextWithSuffix src v "" - GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" - GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" - GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" - GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" - GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" - (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x - -toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String -toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix - --- -------------------------------------------------------------------- - -markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () -markHsConPatDetails ln dets = do - case dets of - GHC.PrefixCon args -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated args - GHC.RecCon (GHC.HsRecFields fs dd) -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - case dd of - Nothing -> markListIntercalateWithFunLevel markLocated 2 fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- '}' - GHC.InfixCon a1 a2 -> do - markLocated a1 - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln - markLocated a2 - -markHsConDeclDetails :: - Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () - -markHsConDeclDetails isDeprecated inGadt lns dets = do - case dets of - GHC.PrefixCon args -> - setContext (Set.singleton PrefixOp) $ mapM_ markLocated args - -- GHC.RecCon fs -> markLocated fs - GHC.RecCon fs -> do - mark GHC.AnnOpenC - if inGadt - then do - if isDeprecated - then setContext (Set.fromList [InGadt]) $ markLocated fs - else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs - else do - if isDeprecated - then markLocated fs - else setContext (Set.fromList [InRecCon]) $ markLocated fs - GHC.InfixCon a1 a2 -> do - markLocated a1 - setContext (Set.singleton InfixOp) $ mapM_ markLocated lns - markLocated a2 - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LConDeclField GHC.GhcPs] where - markAST _ fs = do - markOptional GHC.AnnOpenC -- '{' - markListIntercalate fs - markOptional GHC.AnnDotdot - inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' - inContext (Set.singleton InGadt) $ do - mark GHC.AnnRarrow - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsOverLit GHC.GhcPs) where - markAST l ol = - let str = case GHC.ol_val ol of - GHC.HsIntegral (GHC.IL src _ _) -> src - GHC.HsFractional (GHC.FL src _ _) -> src - GHC.HsIsString src _ -> src - in - markExternalSourceText l str "" - --- --------------------------------------------------------------------- - -instance (Annotate arg) - => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where - markAST _ (GHC.HsIB _ thing) = do - markLocated thing - markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.LastStmt _ body _ _) - = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - markAST _ (GHC.BindStmt _ pat body _ _) = do - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat - mark GHC.AnnLarrow - unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST _ GHC.ApplicativeStmt{} - = error "ApplicativeStmt should not appear in ParsedSource" - - markAST _ (GHC.BodyStmt _ body _ _) = do - unsetContext Intercalate $ markLocated body - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST l (GHC.ParStmt _ pbs _ _) = do - -- Within a given parallel list comprehension,one of the sections to be done - -- in parallel. It is a normal list comprehension, so has a list of - -- ParStmtBlock, one for each part of the sub- list comprehension - - - ifInContext (Set.singleton Intercalate) - ( - - unsetContext Intercalate $ - markListWithContextsFunction - (LC (Set.singleton Intercalate) -- only - Set.empty -- first - Set.empty -- middle - (Set.singleton Intercalate) -- last - ) (markAST l) pbs - ) - ( - unsetContext Intercalate $ - markListWithContextsFunction - (LC Set.empty -- only - (Set.fromList [AddVbar]) -- first - (Set.fromList [AddVbar]) -- middle - Set.empty -- last - ) (markAST l) pbs - ) - markTrailingSemi - - markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do - setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts - case form of - GHC.ThenForm -> do - mark GHC.AnnThen - unsetContext Intercalate $ markLocated using - case by of - Just b -> do - mark GHC.AnnBy - unsetContext Intercalate $ markLocated b - Nothing -> return () - GHC.GroupForm -> do - mark GHC.AnnThen - mark GHC.AnnGroup - case by of - Just b -> mark GHC.AnnBy >> markLocated b - Nothing -> return () - mark GHC.AnnUsing - markLocated using - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do - mark GHC.AnnRec - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - markListWithLayout stmts - markOptional GHC.AnnCloseC - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- Note: We never have a located ParStmtBlock, so have nothing to hang the --- annotation on. This means there is no pushing of context from the parent ParStmt. -instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where - markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do - markListIntercalate stmts - markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where - markAST _ lb = markHsLocalBinds lb - --- --------------------------------------------------------------------- - -markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) = - applyListAnnotationsLayout - (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ) -markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds -markHsLocalBinds GHC.EmptyLocalBinds{} = return () - -markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension" -markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension" -markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension" - --- --------------------------------------------------------------------- - -markMatchGroup :: (Annotate body) - => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) - -> Annotated () -markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _) - = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsExpr GHC.GhcPs) where - markAST loc expr = do - markExpr loc expr - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - -- TODO: If the AnnComma is not needed, revert to markAST - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - where - markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do - ifInContext (Set.singleton PrefixOp) - (setContext (Set.singleton PrefixOp) $ markLocated n) - (ifInContext (Set.singleton InfixOp) - (setContext (Set.singleton InfixOp) $ markLocated n) - (markLocated n) - ) - - markExpr l (GHC.HsRecFld _ f) = markAST l f - - markExpr l (GHC.HsOverLabel _ _ fs) - = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) - - - markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) = - markAST l n - markExpr l (GHC.HsOverLit _ ov) = markAST l ov - markExpr l (GHC.HsLit _ lit) = markAST l lit - - markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do - setContext (Set.singleton LambdaExpr) $ do - -- TODO: Change this, HsLam binds do not need obey layout rules. - -- And will only ever have a single match - markLocated match - markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match" - - markExpr l (GHC.HsLamCase _ match) = do - mark GHC.AnnLam - mark GHC.AnnCase - markOptional GHC.AnnSemi - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l match - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsApp _ e1 e2) = do - setContext (Set.singleton PrefixOp) $ markLocated e1 - setContext (Set.singleton PrefixOp) $ markLocated e2 - - -- ------------------------------- - - markExpr _ (GHC.OpApp _ e1 e2 e3) = do - let - isInfix = case e2 of - -- TODO: generalise this. Is it a fixity thing? - GHC.L _ (GHC.HsVar{}) -> True - _ -> False - - normal = - -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context - ifInContext (Set.singleton LeftMost) - (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) - (markLocated e1) - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - else normal - - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 - else markLocated e3 - - -- ------------------------------- - - markExpr _ (GHC.NegApp _ e _) = do - mark GHC.AnnMinus - markLocated e - - markExpr _ (GHC.HsPar _ e) = do - mark GHC.AnnOpenP -- '(' - markLocated e - mark GHC.AnnCloseP -- ')' - - markExpr _ (GHC.SectionL _ e1 e2) = do - markLocated e1 - setContext (Set.singleton InfixOp) $ markLocated e2 - - markExpr _ (GHC.SectionR _ e1 e2) = do - setContext (Set.singleton InfixOp) $ markLocated e1 - markLocated e2 - - markExpr _ (GHC.ExplicitTuple _ args b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args - - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markExpr _ (GHC.ExplicitSum _ alt arity e) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated e - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do - mark GHC.AnnCase - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - setContext (Set.singleton CaseAlt) $ markMatchGroup l matches - markOptional GHC.AnnCloseC - - -- We set the layout for HsIf even though it need not obey layout rules as - -- when moving these expressions it's useful that they maintain "internal - -- integrity", that is to say the subparts remain indented relative to each - -- other. - markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do - -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do - mark GHC.AnnIf - markLocated e1 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen - mark GHC.AnnThen - setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse - mark GHC.AnnElse - setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 - - markExpr _ (GHC.HsMultiIf _ rhs) = do - mark GHC.AnnIf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - -- mapM_ markLocated rhs - markListWithLayout rhs - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do - setLayoutFlag (do -- Make sure the 'in' gets indented too - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e) - - -- ------------------------------- - - markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do - case cts of - GHC.DoExpr -> mark GHC.AnnDo - GHC.MDoExpr -> mark GHC.AnnMdo - _ -> return () - let (ostr,cstr) = - if isListComp cts - then ("[", "]") - else ("{", "}") - - when (isListComp cts) $ markWithString GHC.AnnOpen ostr - markOptional GHC.AnnOpenS - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - if isListComp cts - then do - markLocated (last es) - mark GHC.AnnVbar - setLayoutFlag (markListIntercalate (init es)) - else do - markListWithLayout es - markOptional GHC.AnnCloseS - markOptional GHC.AnnCloseC - when (isListComp cts) $ markWithString GHC.AnnClose cstr - - -- ------------------------------- - - markExpr _ (GHC.ExplicitList _ _ es) = do - mark GHC.AnnOpenS - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es - mark GHC.AnnCloseS - - markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do - markLocated n - mark GHC.AnnOpenC - case dd of - Nothing -> markListIntercalate fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC - - markExpr _ (GHC.RecordUpd _ e fs) = do - markLocated e - mark GHC.AnnOpenC - markListIntercalate fs - mark GHC.AnnCloseC - - markExpr _ (GHC.ExprWithTySig _ e typ) = do - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e - mark GHC.AnnDcolon - markLHsSigWcType typ - - markExpr _ (GHC.ArithSeq _ _ seqInfo) = do - mark GHC.AnnOpenS -- '[' - case seqInfo of - GHC.From e -> do - markLocated e - mark GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - markLocated e1 - mark GHC.AnnDotdot - markLocated e2 - GHC.FromThen e1 e2 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - markLocated e3 - mark GHC.AnnCloseS -- ']' - - markExpr _ (GHC.HsSCC _ src csFStr e) = do - markAnnOpen src "{-# SCC" - let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - markWithStringOptional GHC.AnnVal txt - markWithString GHC.AnnValStr txt - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do - -- markWithString GHC.AnnOpen src -- "{-# CORE" - markAnnOpen src "{-# CORE" - -- markWithString GHC.AnnVal (GHC.sl_st csFStr) - markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - markWithString GHC.AnnClose "#-}" - markLocated e - -- TODO: make monomorphic - markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do - mark GHC.AnnSimpleQuote - setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do - mark GHC.AnnThTyQuote - markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do - markWithString GHC.AnnOpen "[d|" - markOptional GHC.AnnOpenC - setContext (Set.singleton NoAdvanceLine) - $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds - markOptional GHC.AnnCloseC - mark GHC.AnnCloseQ -- "|]" - -- Introduced after the renamer - markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) = - traceM "warning: DecBrG introduced after renamer" - markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do - mark GHC.AnnOpenEQ -- "[|" - markOptional GHC.AnnOpenE -- "[e|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do - markWithString GHC.AnnOpen "[||" - markWithStringOptional GHC.AnnOpenE "[e||" - markLocated e - markWithString GHC.AnnClose "||]" - markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do - markWithString GHC.AnnOpen "[t|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do - markWithString GHC.AnnOpen "[p|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - - markExpr _ (GHC.HsRnBracketOut {}) = - traceM "warning: HsRnBracketOut introduced after renamer" - markExpr _ (GHC.HsTcBracketOut {}) = - traceM "warning: HsTcBracketOut introduced after renamer" - - markExpr l (GHC.HsSpliceE _ e) = markAST l e - - markExpr _ (GHC.HsProc _ p c) = do - mark GHC.AnnProc - markLocated p - mark GHC.AnnRarrow - markLocated c - - markExpr _ (GHC.HsStatic _ e) = do - mark GHC.AnnStatic - markLocated e - - markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markExpr _ (GHC.HsArrForm _ e _ cs) = do - markWithString GHC.AnnOpenB "(|" - markLocated e - mapM_ markLocated cs - markWithString GHC.AnnCloseB "|)" - - markExpr _ (GHC.HsTick {}) = return () - markExpr _ (GHC.HsBinTick {}) = return () - - markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markAnnOpen src "{-# GENERATED" - markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING - - let - markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) - markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s - - markOne 1 v1 s1 -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOne 2 v2 s2 -- INTEGER - mark GHC.AnnMinus -- '-' - markOne 3 v3 s3 -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOne 4 v4 s4 -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr 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 - markInstead GHC.AnnAt AnnTypeApp - markLHsWcType ty - - markExpr _ (GHC.HsWrap {}) = - traceM "warning: HsWrap introduced after renaming" - markExpr _ (GHC.HsUnboundVar {}) = - traceM "warning: HsUnboundVar introduced after renaming" - - markExpr _ (GHC.HsConLikeOut{}) = - traceM "warning: HsConLikeOut introduced after type checking" - - markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension" - markExpr _ (GHC.XExpr _) = error "markExpr got extension" - --- --------------------------------------------------------------------- - -markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () -markLHsWcType (GHC.HsWC _ ty) = do - markLocated ty -markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLit GHC.GhcPs) where - markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where - markAST _ (GHC.HsRecField lbl expr punFlag) = do - unsetContext Intercalate $ markLocated lbl - when (punFlag == False) $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated expr - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - -instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where - markAST _ (GHC.Unambiguous _ n) = markLocated n - markAST _ (GHC.Ambiguous _ n) = markLocated n - markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- |Used for declarations that need to be aligned together, e.g. in a --- do or let .. in statement/expr -instance Annotate [GHC.ExprLStmt GHC.GhcPs] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTupArg GHC.GhcPs) where - markAST _ (GHC.Present _ (GHC.L l e)) = do - markLocated (GHC.L l e) - inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) - - markAST _ (GHC.Missing _) = do - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsCmdTop GHC.GhcPs) where - markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd - markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x - -instance Annotate (GHC.HsCmd GHC.GhcPs) where - markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do - -- The AnnOpen should be marked for a prefix usage, not for a postfix one, - -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm - - let isPrefixOp = case fixity of - GHC.Infix -> False - GHC.Prefix -> True - when isPrefixOp $ mark GHC.AnnOpenB -- "(|" - - -- This may be an infix operation - applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) - (Set.singleton InfixOp) (Set.singleton InfixOp)) - (prepareListAnnotation [e] - ++ prepareListAnnotation cs) - when isPrefixOp $ mark GHC.AnnCloseB -- "|)" - - markAST _ (GHC.HsCmdApp _ e1 e2) = do - markLocated e1 - markLocated e2 - - markAST l (GHC.HsCmdLam _ match) = do - setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match - - markAST _ (GHC.HsCmdPar _ e) = do - mark GHC.AnnOpenP - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsCmdCase _ e1 matches) = do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l matches - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do - mark GHC.AnnIf - markLocated e1 - markOffset GHC.AnnSemi 0 - mark GHC.AnnThen - markLocated e2 - markOffset GHC.AnnSemi 1 - mark GHC.AnnElse - markLocated e3 - - markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e - - markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do - mark GHC.AnnDo - markOptional GHC.AnnOpenC - markListWithLayout es - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdWrap {}) = - traceM "warning: HsCmdWrap introduced after renaming" - - markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyClDecl GHC.GhcPs) where - - markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi -{- - SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs - , tcdLName :: Located (IdP pass) -- ^ Type constructor - , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an - -- associated type these - -- include outer binders - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType pass } -- ^ RHS of type declaration - --} - markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do - -- There may be arbitrary parens around parts of the constructor that are - -- infix. - -- Turn these into comments so that they feed into the right place automatically - -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - mark GHC.AnnType - - markTyClass Nothing fixity ln tyvars - mark GHC.AnnEqual - markLocated typ - markTrailingSemi - - markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity - (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do - if nd == GHC.DataType - then mark GHC.AnnData - else mark GHC.AnnNewtype - markMaybe mctyp - markLocated ctx - markTyClass Nothing fixity ln tyVars - case mk of - Nothing -> return () - Just k -> do - mark GHC.AnnDcolon - markLocated k - if isGadt cons - then mark GHC.AnnWhere - else unless (null cons) $ mark GHC.AnnEqual - markOptional GHC.AnnWhere - markOptional GHC.AnnOpenC - setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts cons - markOptional GHC.AnnCloseC - setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds - sigs meths ats atdefs docs) = do - mark GHC.AnnClass - markLocated ctx - - markTyClass Nothing fixity ln tyVars - - unless (null fds) $ do - mark GHC.AnnVbar - markListIntercalateWithFunLevel markLocated 2 fds - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - -- AZ:TODO: we end up with both the tyVars and the following body of the - -- class defn in annSortKey for the class. This could cause problems when - -- changing things. - setContext (Set.singleton InClassDecl) $ - applyListAnnotationsLayout - (prepareListAnnotation sigs - ++ prepareListAnnotation (GHC.bagToList meths) - ++ prepareListAnnotation ats - ++ prepareListAnnotation atdefs - ++ prepareListAnnotation docs - ) - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi -{- - | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdCtxt :: LHsContext pass, -- ^ Context... - tcdLName :: Located (IdP pass), -- ^ Name of the class - tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables - tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [Located (FunDep (Located (IdP pass)))], - -- ^ Functional deps - tcdSigs :: [LSig pass], -- ^ Methods' signatures - tcdMeths :: LHsBinds pass, -- ^ Default methods - tcdATs :: [LFamilyDecl pass], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn pass], - -- ^ Associated type defaults - tcdDocs :: [LDocDecl] -- ^ Haddock docs - } - --} - - markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) - = error "extension hit for TyClDecl" - markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) - = error "extension hit for TyClDecl" - markAST _ (GHC.XTyClDecl _) - = error "extension hit for TyClDecl" - --- --------------------------------------------------------------------- - -markTypeApp :: GHC.SrcSpan -> Annotated () -markTypeApp loc = do - let l = GHC.srcSpanFirstCharacter loc - markExternal l GHC.AnnVal "@" - --- --------------------------------------------------------------------- - -markTyClassArgs :: (Annotate a) - => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity - -- -> GHC.Located a -> [ast] -> Annotated () - -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated () -markTyClassArgs mbndrs fixity ln tyVars = do - let - cvt (GHC.HsValArg val) = markLocated val - cvt (GHC.HsTypeArg loc typ) = do - markTypeApp loc - -- let l = GHC.srcSpanFirstCharacter loc - -- markExternal l GHC.AnnVal "@" - markLocated typ - cvt (GHC.HsArgPar _ss) = undefined - markTyClassWorker cvt mbndrs fixity ln tyVars - {- -type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) - -data HsArg tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg ty -- Argument is a visible type application (f @ty) - | HsArgPar SrcSpan -- See Note [HsArgPar] --} - --- TODO:AZ: simplify -markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, Annotate ast,GHC.HasSrcSpan ast) - => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity - -> GHC.Located a -> [ast] -> Annotated () -markTyClass = markTyClassWorker markLocated - -markTyClassWorker :: (Annotate a) - => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity - -- -> GHC.Located a -> [ast] -> Annotated () - -> GHC.Located a -> [b] -> Annotated () -markTyClassWorker markFn mbndrs fixity ln tyVars = do - let processBinders = - case mbndrs of - Nothing -> return () - Just bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - -- There may be arbitrary parens around parts of the constructor - -- Turn these into comments so that they feed into the right place automatically - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - let markParens = if fixity == GHC.Infix && length tyVars > 2 - then markMany - else markManyOptional - if fixity == GHC.Prefix - then do - markManyOptional GHC.AnnOpenP - processBinders - setContext (Set.singleton PrefixOp) $ markLocated ln - -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars - setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars - when (length tyVars >= 2) $ do - markParens GHC.AnnCloseP - setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars - markManyOptional GHC.AnnCloseP - else do - case tyVars of - (x:y:xs) -> do - markParens GHC.AnnOpenP - processBinders - markFn x - setContext (Set.singleton InfixOp) $ markLocated ln - markFn y - markParens GHC.AnnCloseP - mapM_ markFn xs - markManyOptional GHC.AnnCloseP - _ -> error $ "markTyClass: Infix op without operands" - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where - markAST _ ds = mapM_ markLocated ds - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where - markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do - mark GHC.AnnDeriving - case mstrategy of - Nothing -> return () - Just (GHC.L _ (GHC.ViaStrategy{})) -> return () - Just s -> markLocated s - markLocated typs - case mstrategy of - Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s - _ -> return () - - markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x - -{- - = HsDerivingClause - { deriv_clause_ext :: XCHsDerivingClause pass - , deriv_clause_strategy :: Maybe (LDerivStrategy pass) - -- ^ The user-specified strategy (if any) to use when deriving - -- 'deriv_clause_tys'. - , deriv_clause_tys :: Located [LHsSigType pass] - -- ^ The types to derive. - -- - -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, - -- we can mention type variables that aren't bound by the datatype, e.g. - -- - -- > data T b = ... deriving (C [a]) - -- - -- should produce a derived instance for @C [a] (T b)@. - } - --} - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyDecl GHC.GhcPs) where - markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do - case info of - GHC.DataFamily -> mark GHC.AnnData - _ -> mark GHC.AnnType - - mark GHC.AnnFamily - - markTyClass Nothing fixity ln tyvars - case GHC.unLoc rsig of - GHC.NoSig _ -> return () - GHC.KindSig _ _ -> do - mark GHC.AnnDcolon - markLocated rsig - GHC.TyVarSig _ _ -> do - mark GHC.AnnEqual - markLocated rsig - (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x - case minj of - Nothing -> return () - Just inj -> do - mark GHC.AnnVbar - markLocated inj - case info of - GHC.ClosedTypeFamily (Just eqns) -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- { - markListWithLayout eqns - markOptional GHC.AnnCloseC -- } - GHC.ClosedTypeFamily Nothing -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- { - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- } - _ -> return () - markTrailingSemi - - markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _) - = error "got extension for FamilyDecl" - markAST _ (GHC.XFamilyDecl _) - = error "got extension for FamilyDecl" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where - markAST _ (GHC.NoSig _) = return () - markAST _ (GHC.KindSig _ k) = markLocated k - markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv - markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where - markAST _ (GHC.InjectivityAnn ln lns) = do - markLocated ln - mark GHC.AnnRarrow - mapM_ markLocated lns - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where -{- -type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) - -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) - -type HsTyPats pass = [LHsTypeArg pass] - --} - markAST _ (GHC.HsIB _ eqn) = do - markFamEqn eqn - markTrailingSemi - markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where - - markAST _ (GHC.FamEqn _ ln mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do - mark GHC.AnnType - mark GHC.AnnInstance - markTyClass mbndrs fixity ln bndrs - mark GHC.AnnEqual - markLocated typ -{- -type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass) - -data LHsQTyVars pass -- See Note [HsType binders] - = HsQTvs { hsq_ext :: XHsQTvs pass - - , hsq_explicit :: [LHsTyVarBndr pass] - -- Explicit variables, written by the user - -- See Note [HsForAllTy tyvar binders] - } - - -data FamEqn pass pats rhs - = FamEqn - { feqn_ext :: XCFamEqn pass pats rhs - , feqn_tycon :: Located (IdP pass) - , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars - , feqn_pats :: pats - , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , feqn_rhs :: rhs - } --} - - markAST _ (GHC.FamEqn _ _ _ (GHC.XLHsQTyVars _) _ _) - = error "TyFamDefltEqn hit extension point" - markAST _ (GHC.XFamEqn _) - = error "TyFamDefltEqn hit extension point" - --- --------------------------------------------------------------------- - --- TODO: modify lexer etc, in the meantime to not set haddock flag -instance Annotate GHC.DocDecl where - markAST l v = - let str = - case v of - (GHC.DocCommentNext ds) -> GHC.unpackHDS ds - (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds - (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds - (GHC.DocGroup _i ds) -> GHC.unpackHDS ds - in - markExternal l GHC.AnnVal str >> markTrailingSemi -{- -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - --} - --- --------------------------------------------------------------------- - -markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () -markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do - markLocated ctx - markMaybe typ - if isGadt cons - then markListWithLayout cons - else markListIntercalateWithFunLevel markLocated 2 cons - setContext (Set.singleton Deriving) $ markLocated derivs -markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance Annotate [GHC.LHsType GHC.GhcPs] where - markAST l ts = do - -- Note: A single item in parens in a standalone deriving clause - -- is parsed as a HsSigType, which is always a HsForAllTy or - -- HsQualTy. Without parens it is always a HsVar. So for round - -- trip pretty printing we need to take this into account. - let - parenIfNeeded' pa = - case ts of - [] -> if l == GHC.noSrcSpan - then markManyOptional pa - else markMany pa - [GHC.L _ GHC.HsForAllTy{}] -> markMany pa - [GHC.L _ GHC.HsQualTy{}] -> markMany pa - [_] -> markManyOptional pa - _ -> markMany pa - - parenIfNeeded'' pa = - ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set? - (markMany pa) - (parenIfNeeded' pa) - - parenIfNeeded pa = - case ts of - [GHC.L _ GHC.HsParTy{}] -> markOptional pa - _ -> parenIfNeeded'' pa - - -- ------------- - - parenIfNeeded GHC.AnnOpenP - - unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts - - parenIfNeeded GHC.AnnCloseP - - ifInContext (Set.singleton NoDarrow) - (return ()) - (if null ts && (l == GHC.noSrcSpan) - then markOptional GHC.AnnDarrow - else mark GHC.AnnDarrow) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDecl GHC.GhcPs) where - markAST _ (GHC.ConDeclH98 _ ln (GHC.L _ fa) mqtvs mctx - dets _) = do - when fa $ do - mark GHC.AnnForall - mapM_ markLocated mqtvs - mark GHC.AnnDot - - case mctx of - Just ctx -> do - setContext (Set.fromList [NoDarrow]) $ markLocated ctx - mark GHC.AnnDarrow - Nothing -> return () - - case dets of - GHC.InfixCon _ _ -> return () - _ -> setContext (Set.singleton PrefixOp) $ markLocated ln - - markHsConDeclDetails False False [ln] dets - - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar - markTrailingSemi -{- - | ConDeclH98 - { con_ext :: XConDeclH98 pass - , con_name :: Located (IdP pass) - - , con_forall :: Bool -- ^ True <=> explicit user-written forall - -- e.g. data T a = forall b. MkT b (b->a) - -- con_ex_tvs = {b} - -- False => con_ex_tvs is empty - , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - --} - markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - annotationsToComments [GHC.AnnOpenP] - markLocated (GHC.L l (ResTyGADTHook forall qvars)) - markMaybe mbCxt - markHsConDeclDetails False True lns args - markLocated typ - markManyOptional GHC.AnnCloseP - markTrailingSemi -{- - = ConDeclGADT - { con_g_ext :: XConDeclGADT pass - , con_names :: [Located (IdP pass)] - - -- The next four fields describe the type after the '::' - -- See Note [GADT abstract syntax] - , con_forall :: Located Bool -- ^ True <=> explicit forall - -- False => hsq_explicit is empty - , con_qvars :: LHsQTyVars pass - -- Whether or not there is an /explicit/ forall, we still - -- need to capture the implicitly-bound type/kind variables - - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon - , con_res_ty :: LHsType pass -- ^ Result type - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - --} - - markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _) - = error "hit extension point in ConDecl" - markAST _ (GHC.XConDecl _) - = error "hit extension point in ConDecl" - --- ResTyGADT has a SrcSpan for the original sigtype, we need to create --- a type for exactPC and annotatePC -data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs] - deriving (Typeable) -deriving instance Data (ResTyGADTHook) - -instance GHC.Outputable ResTyGADTHook where - ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs - - --- WildCardAnon exists because the GHC anonymous wildcard type is defined as --- = AnonWildCard (PostRn name Name) --- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but --- the instance doing this is parameterised on name, so we cannot put a value in --- for the (PostRn name Name) field. This is used instead. -data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable) - -instance Annotate WildCardAnon where - markAST l WildCardAnon = do - markExternal l GHC.AnnVal "_" - --- --------------------------------------------------------------------- - -instance Annotate ResTyGADTHook where - markAST _ (ResTyGADTHook forall bndrs) = do - when forall $ mark GHC.AnnForall - mapM_ markLocated bndrs - when forall $ mark GHC.AnnDot - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - - markAST _ (ls,rs') = do - mapM_ markLocated ls - mark GHC.AnnRarrow - mapM_ markLocated rs' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate GHC.CType where - markAST _ (GHC.CType src mh f) = do - -- markWithString GHC.AnnOpen src - markAnnOpen src "" - case mh of - Nothing -> return () - Just (GHC.Header srcH _h) -> - -- markWithString GHC.AnnHeader srcH - markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") - -- markWithString GHC.AnnVal (fst f) - markSourceText (fst f) (GHC.unpackFS $ snd f) - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -stringLiteralToString :: GHC.StringLiteral -> String -stringLiteralToString (GHC.StringLiteral st fs) = - case st of - GHC.NoSourceText -> GHC.unpackFS fs - GHC.SourceText src -> src diff --git a/src-ghc90/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc90/Language/Haskell/GHC/ExactPrint/Annotater.hs deleted file mode 100644 --- a/src-ghc90/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ /dev/null @@ -1,2813 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} - - --- | 'annotate' is a function which given a GHC AST fragment, constructs --- a syntax tree which indicates which annotations belong to each specific --- part of the fragment. --- --- "Delta" and "Print" provide two interpreters for this structure. You --- should probably use those unless you know what you're doing! --- --- The functor 'AnnotationF' has a number of constructors which correspond --- to different sitations which annotations can arise. It is hoped that in --- future versions of GHC these can be simplified by making suitable --- modifications to the AST. - -module Language.Haskell.GHC.ExactPrint.Annotater - ( - annotate - , AnnotationF(..) - , Annotated - , Annotate(..) - , withSortKeyContextsHelper - ) where - - -import Language.Haskell.GHC.ExactPrint.AnnotateTypes -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import qualified GHC as GHC -import qualified GHC.Core.Class as GHC -import qualified GHC.Core.Coercion.Axiom as GHC -import qualified GHC.Data.Bag as GHC -import qualified GHC.Data.BooleanFormula as GHC -import qualified GHC.Data.FastString as GHC -import qualified GHC.Parser.Annotation as GHC -import qualified GHC.Types.Basic as GHC -import qualified GHC.Types.ForeignCall as GHC -import qualified GHC.Types.Name as GHC -import qualified GHC.Types.Name.Reader as GHC -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Types.Var as GHC -import qualified GHC.Utils.Outputable as GHC - -import Control.Monad.Identity -import Data.Data -import Data.Maybe - -import qualified Data.Set as Set - -import Debug.Trace - - -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} --- --------------------------------------------------------------------- - -class Data ast => Annotate ast where - markAST :: GHC.SrcSpan -> ast -> Annotated () - --- --------------------------------------------------------------------- - --- | Construct a syntax tree which represent which KeywordIds must appear --- where. --- annotate :: (Annotate ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated () -annotate :: (Annotate ast) => GHC.Located ast -> Annotated () -annotate = markLocated - --- instance Annotate (GHC.SrcSpanLess ast) where --- markAST s ast = undefined -instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where - markAST l (GHC.L _ ast) = markAST l ast - --- --------------------------------------------------------------------- - --- | Constructs a syntax tree which contains information about which --- annotations are required by each element. -markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () -markLocated ast = - case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of - Just d -> markLHsDecl d - Nothing -> withLocated ast markAST - --- --------------------------------------------------------------------- - --- |When adding missing annotations, do not put a preceding space in front of a list -markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () -markListNoPrecedingSpace intercal ls = - case ls of - [] -> return () - (l:ls') -> do - if intercal - then do - if null ls' - then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l - else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l - markListIntercalate ls' - else do - setContext (Set.singleton NoPrecedingSpace) $ markLocated l - mapM_ markLocated ls' - --- --------------------------------------------------------------------- - - --- |Mark a list, with the given keyword as a list item separator -markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () -markListIntercalate ls = markListIntercalateWithFun markLocated ls - --- --------------------------------------------------------------------- - -markListWithContexts :: Annotate ast - => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () -markListWithContexts ctxInitial ctxRest ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxInitial 2 $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial 2 $ markLocated x - setContextLevel ctxRest 2 $ mapM_ markLocated xs - --- --------------------------------------------------------------------- - --- Context for only if just one, else first item, middle ones, and last one -markListWithContexts' :: Annotate ast - => ListContexts - -> [GHC.Located ast] -> Annotated () -markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxOnly level $ markLocated x - (x:xs) -> do - setContextLevel ctxInitial level $ markLocated x - go xs - where - level = 2 - go [] = return () - go [x] = setContextLevel ctxLast level $ markLocated x - go (x:xs) = do - setContextLevel ctxMiddle level $ markLocated x - go xs - - --- --------------------------------------------------------------------- - -markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () -markListWithLayout ls = - setLayoutFlag $ markList ls - --- --------------------------------------------------------------------- - -markList :: Annotate ast => [GHC.Located ast] -> Annotated () -markList ls = - setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts' ls - -markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markLocalBindsWithLayout binds = markHsLocalBinds binds - --- --------------------------------------------------------------------- - --- |This function is used to get around shortcomings in the GHC AST for 7.10.1 -markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () -markLocatedFromKw kw (GHC.L l a) = do - -- Note: l is needed so that the pretty printer can make something up - ss <- getSrcSpanForKw l kw - AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) - markLocated (GHC.L (GHC.RealSrcSpan ss' Nothing) a) - --- --------------------------------------------------------------------- - -markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () -markMaybe Nothing = return () -markMaybe (Just ast) = markLocated ast - --- --------------------------------------------------------------------- - -markTightPrefix :: Annotated () -> Annotated () -markTightPrefix action = setContext (Set.singleton InTypeApp) action - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.RealSrcSpan,Annotated ())] -prepareListAnnotation ls = map (\b -> (rs $ GHC.getLoc b,markLocated b)) ls - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsModule where - markAST _ (GHC.HsModule _lo mmn mexp imps decs mdepr _haddock) = do - - case mmn of - Nothing -> return () - Just (GHC.L ln mn) -> do - mark GHC.AnnModule - markExternal ln GHC.AnnVal (GHC.moduleNameString mn) - - forM_ mdepr markLocated - forM_ mexp markLocated - - mark GHC.AnnWhere - - markOptional GHC.AnnOpenC -- Possible '{' - markManyOptional GHC.AnnSemi -- possible leading semis - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps - - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs - - markOptional GHC.AnnCloseC -- Possible '}' - - markEOF - --- --------------------------------------------------------------------- - -instance Annotate GHC.WarningTxt where - markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# WARNING" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do - markAnnOpen txt "{-# DEPRECATED" - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate GHC.StringLiteral where - markAST l (GHC.StringLiteral src fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SourceText,GHC.FastString) where - markAST l (src,fs) = do - markExternalSourceText l src (show (GHC.unpackFS fs)) - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LIE GHC.GhcPs] where - markAST _ ls = do - inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl - mark GHC.AnnOpenP -- '(' - -- Can't use markListIntercalate, there can be trailing commas, but only in imports. - markListIntercalateWithFunLevel markLocated 2 ls - - markOptional GHC.AnnComma - mark GHC.AnnCloseP -- ')' - -instance Annotate (GHC.IE GHC.GhcPs) where - markAST _ ie = do - - case ie of - GHC.IEVar _ ln -> markLocated ln - - GHC.IEThingAbs _ ln -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - - GHC.IEThingWith _ ln wc ns _lfs -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnOpenP - case wc of - GHC.NoIEWildcard -> - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns - GHC.IEWildcard n -> do - setContext (Set.fromList [PrefixOp,Intercalate]) - $ mapM_ markLocated (take n ns) - mark GHC.AnnDotdot - case drop n ns of - [] -> return () - ns' -> do - mark GHC.AnnComma - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markListIntercalate ns' - mark GHC.AnnCloseP - - (GHC.IEThingAll _ ln) -> do - setContext (Set.fromList [PrefixOp]) $ markLocated ln - mark GHC.AnnOpenP - mark GHC.AnnDotdot - mark GHC.AnnCloseP - - (GHC.IEModuleContents _ (GHC.L lm mn)) -> do - mark GHC.AnnModule - markExternal lm GHC.AnnVal (GHC.moduleNameString mn) - - -- Only used in Haddock mode so we can ignore them. - (GHC.IEGroup {}) -> return () - - (GHC.IEDoc {}) -> return () - - (GHC.IEDocNamed {}) -> return () - ifInContext (Set.fromList [Intercalate]) - (mark GHC.AnnComma) - (markOptional GHC.AnnComma) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IEWrappedName GHC.RdrName) where - markAST _ (GHC.IEName ln) = do - unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) - $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEPattern ln) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.IEType ln) = do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocated ln - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -isSymRdr :: GHC.RdrName -> Bool -isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." - -instance Annotate GHC.RdrName where - markAST l n = do - let - str = rdrName2String n - isSym = isSymRdr n - doNormalRdrName = do - let str' = case str of - -- TODO: unicode support? - "forall" -> if spanLength l == 1 then "∀" else str - _ -> str - - let - markParen :: GHC.AnnKeywordId -> Annotated () - markParen pa = do - if isSym - then ifInContext (Set.fromList [PrefixOp,PrefixOpDollar]) - (mark pa) -- '(' - (markOptional pa) - else markOptional pa - - markOptional GHC.AnnSimpleQuote - markParen GHC.AnnOpenP - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 - cnt <- countAnns GHC.AnnVal - case cnt of - 0 -> markExternal l GHC.AnnVal str' - 1 -> markWithString GHC.AnnVal str' - _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) - unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 - markParen GHC.AnnCloseP - - case n of - GHC.Unqual _ -> doNormalRdrName - GHC.Qual _ _ -> doNormalRdrName - GHC.Orig _ _ -> if str == "~" - then doNormalRdrName - -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen) - else markExternal l GHC.AnnVal str - GHC.Exact n' -> do - case str of - -- Special handling for Exact RdrNames, which are built-in Names - "[]" -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnCloseS -- ']' - "()" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnCloseP -- ')' - ('(':'#':_) -> do - markWithString GHC.AnnOpen "(#" -- '(#' - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - markWithString GHC.AnnClose "#)"-- '#)' - "[::]" -> do - markWithString GHC.AnnOpen "[:" -- '[:' - markWithString GHC.AnnClose ":]" -- ':]' - "->" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnRarrow - mark GHC.AnnCloseP -- ')' - "~" -> do - doNormalRdrName - "*" -> do - markExternal l GHC.AnnVal str - "★" -> do -- Note: unicode star - markExternal l GHC.AnnVal str - ":" -> do - -- Note: The OccName for ":" has the following attributes (via occAttributes) - -- (d, Data DataSym Sym Val ) - -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - doNormalRdrName - -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName - ('(':',':_) -> do - mark GHC.AnnOpenP - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - mark GHC.AnnCloseP -- ')' - _ -> do - let isSym' = isSymRdr (GHC.nameRdrName n') - when isSym' $ mark GHC.AnnOpenP -- '(' - markWithString GHC.AnnVal str - when isSym $ mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ImportDecl GHC.GhcPs) where - markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do - - -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - mark GHC.AnnImport - - -- "{-# SOURCE" and "#-}" - case msrc of - GHC.SourceText _txt -> do - markAnnOpen msrc "{-# SOURCE" - markWithString GHC.AnnClose "#-}" - GHC.NoSourceText -> return () - when safeflag (mark GHC.AnnSafe) - case qualFlag of - GHC.QualifiedPre -- 'qualified' appears in prepositive position. - -> (unsetContext TopLevel $ mark GHC.AnnQualified) - _ -> return () - case mpkg of - Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> - markWithString GHC.AnnPackageName srcPkg - _ -> return () - - markLocated modname - - case qualFlag of - GHC.QualifiedPost -- 'qualified' appears in postpositive position. - -> (unsetContext TopLevel $ mark GHC.AnnQualified) - _ -> return () - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - mark GHC.AnnAs - markLocated mn - - case hiding of - Nothing -> return () - Just (isHiding,lie) -> do - if isHiding - then setContext (Set.singleton HasHiding) $ - markLocated lie - else markLocated lie - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate GHC.ModuleName where - markAST l mname = - markExternal l GHC.AnnVal (GHC.moduleNameString mname) - --- --------------------------------------------------------------------- - -markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () -markLHsDecl (GHC.L l decl) = - case decl of - GHC.TyClD _ d -> markLocated (GHC.L l d) - GHC.InstD _ d -> markLocated (GHC.L l d) - GHC.DerivD _ d -> markLocated (GHC.L l d) - GHC.ValD _ d -> markLocated (GHC.L l d) - GHC.SigD _ d -> markLocated (GHC.L l d) - GHC.KindSigD _ d -> markLocated (GHC.L l d) - GHC.DefD _ d -> markLocated (GHC.L l d) - GHC.ForD _ d -> markLocated (GHC.L l d) - GHC.WarningD _ d -> markLocated (GHC.L l d) - GHC.AnnD _ d -> markLocated (GHC.L l d) - GHC.RuleD _ d -> markLocated (GHC.L l d) - GHC.SpliceD _ d -> markLocated (GHC.L l d) - GHC.DocD _ d -> markLocated (GHC.L l d) - GHC.RoleAnnotD _ d -> markLocated (GHC.L l d) - -instance Annotate (GHC.HsDecl GHC.GhcPs) where - markAST l d = markLHsDecl (GHC.L l d) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where - markAST _ (GHC.RoleAnnotDecl _ ln mr) = do - mark GHC.AnnType - mark GHC.AnnRole - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated mr - -instance Annotate (Maybe GHC.Role) where - markAST l Nothing = markExternal l GHC.AnnVal "_" - markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SpliceDecl GHC.GhcPs) where - markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do - markLocated e - markTrailingSemi - markAST _ (GHC.SpliceDecl _ e _flag) = do - markLocated e - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecls GHC.GhcPs) where - markAST _ (GHC.HsRules _ src rules) = do - markAnnOpen src "{-# RULES" - setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleDecl GHC.GhcPs) where - markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do - markLocated ln - setContext (Set.singleton ExplicitNeverActive) $ markActivation l act - - case mtybndrs of - Nothing -> return () - Just bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - mark GHC.AnnForall - mapM_ markLocated termbndrs - mark GHC.AnnDot - - markLocated lhs - mark GHC.AnnEqual - markLocated rhs - inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi - markTrailingSemi -{- - = HsRule -- Source rule - { rd_ext :: XHsRule pass - -- ^ After renamer, free-vars from the LHS and RHS - , rd_name :: Located (SourceText,RuleName) - -- ^ Note [Pragma source text] in BasicTypes - , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] - -- ^ Forall'd type vars - , rd_tmvs :: [LRuleBndr pass] - -- ^ Forall'd term vars, before typechecking; after typechecking - -- this includes all forall'd vars - , rd_lhs :: Located (HsExpr pass) - , rd_rhs :: Located (HsExpr pass) - } - --} - --- --------------------------------------------------------------------- - -markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () -markActivation _ act = do - case act of - GHC.ActiveBefore src phase -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.ActiveAfter src phase -> do - mark GHC.AnnOpenS -- '[' - markSourceText src (show phase) - mark GHC.AnnCloseS -- ']' - GHC.NeverActive -> do - inContext (Set.singleton ExplicitNeverActive) $ do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - mark GHC.AnnCloseS -- ']' - _ -> return () - --- --------------------------------------------------------------------- - -instance Annotate (GHC.RuleBndr GHC.GhcPs) where -{- - = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) - | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass) --} - markAST _ (GHC.RuleBndr _ ln) = markLocated ln - markAST _ (GHC.RuleBndrSig _ ln (GHC.HsPS _ ty)) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLocated ty - mark GHC.AnnCloseP -- ")" - --- --------------------------------------------------------------------- - -markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () -markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do - markLocated ty - --- --------------------------------------------------------------------- - -instance Annotate (GHC.AnnDecl GHC.GhcPs) where - markAST _ (GHC.HsAnnotation _ src prov e) = do - markAnnOpen src "{-# ANN" - case prov of - (GHC.ValueAnnProvenance n) -> markLocated n - (GHC.TypeAnnProvenance n) -> do - mark GHC.AnnType - markLocated n - GHC.ModuleAnnProvenance -> mark GHC.AnnModule - - markLocated e - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecls GHC.GhcPs) where - markAST _ (GHC.Warnings _ src warns) = do - markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED - mapM_ markLocated warns - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.WarnDecl GHC.GhcPs) where - markAST _ (GHC.Warning _ lns txt) = do - markListIntercalate lns - mark GHC.AnnOpenS -- "[" - case txt of - GHC.WarningTxt _src ls -> markListIntercalate ls - GHC.DeprecatedTxt _src ls -> markListIntercalate ls - mark GHC.AnnCloseS -- "]" - -instance Annotate GHC.FastString where - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - markAST l fs = do - markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ForeignDecl GHC.GhcPs) where - markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnImport - markLocated cconv - unless (ll == GHC.noSrcSpan) $ markLocated safety - markExternalSourceText ls src "" - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnExport - markLocated spec - markExternal ls GHC.AnnVal (sourceTextToString src "") - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLocated typ - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CExportSpec) where - markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CCallConv) where - markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" - markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" - markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" - markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" - markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.Safety) where - markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" - markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" - markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivDecl GHC.GhcPs) where - - markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do - mark GHC.AnnDeriving - markMaybe ms - mark GHC.AnnInstance - markMaybe mov - markLocated typ - markTrailingSemi - -{- -data DerivDecl pass = DerivDecl - { deriv_ext :: XCDerivDecl pass - , deriv_type :: LHsSigWcType pass - -- ^ The instance type to derive. - -- - -- It uses an 'LHsSigWcType' because the context is allowed to be a - -- single wildcard: - -- - -- > deriving instance _ => Eq (Foo a) - -- - -- Which signifies that the context should be inferred. - - -- See Note [Inferring the instance context] in TcDerivInfer. - - , deriv_strategy :: Maybe (LDerivStrategy pass) - , deriv_overlap_mode :: Maybe (Located OverlapMode) - -type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both - -data HsWildCardBndrs pass thing - -- See Note [HsType binders] - -- See Note [The wildcard story for types] - = HsWC { hswc_ext :: XHsWC pass thing - -- after the renamer - -- Wild cards, both named and anonymous - - , hswc_body :: thing - -- Main payload (type or list of types) - -- If there is an extra-constraints wildcard, - -- it's still there in the hsc_body. - } - - --} - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DerivStrategy GHC.GhcPs) where - - markAST _ GHC.StockStrategy = mark GHC.AnnStock - markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass - markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype - markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do - mark GHC.AnnVia - markLocated ty - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DefaultDecl GHC.GhcPs) where - - markAST _ (GHC.DefaultDecl _ typs) = do - mark GHC.AnnDefault - mark GHC.AnnOpenP -- '(' - markListIntercalate typs - mark GHC.AnnCloseP -- ')' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InstDecl GHC.GhcPs) where - - markAST l (GHC.ClsInstD _ cid) = markAST l cid - markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid - markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid - --- --------------------------------------------------------------------- - -instance Annotate GHC.OverlapMode where - - -- NOTE: NoOverlap is only used in the typechecker - markAST _ (GHC.NoOverlap src) = do - markAnnOpen src "{-# NO_OVERLAP" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlappable src) = do - markAnnOpen src "{-# OVERLAPPABLE" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlapping src) = do - markAnnOpen src "{-# OVERLAPPING" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlaps src) = do - markAnnOpen src "{-# OVERLAPS" - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Incoherent src) = do - markAnnOpen src "{-# INCOHERENT" - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where - - markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do - mark GHC.AnnInstance - markMaybe mov - markLocated poly - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - - applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ++ prepareListAnnotation tyfams - ++ prepareListAnnotation datafams - ) - - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where -{- -newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } - -type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) - -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) - - --} - markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do - mark GHC.AnnType - mark GHC.AnnInstance -- Note: this keyword is optional - markFamEqn eqn - markTrailingSemi - --- --------------------------------------------------------------------- - --- markFamEqn :: (GHC.HasOccName (GHC.IdP pass), --- Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) --- => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) --- -> Annotated () --- markFamEqn :: GHC.FamEqn GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs) -markFamEqn :: GHC.FamEqn GhcPs (GHC.LHsType GHC.GhcPs) - -> Annotated () -markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do - markTyClassArgs bndrs fixity ln pats - mark GHC.AnnEqual - markLocated rhs -{- -data FamEqn pass pats rhs - = FamEqn - { feqn_ext :: XCFamEqn pass pats rhs - , feqn_tycon :: Located (IdP pass) - , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars - , feqn_pats :: pats - , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , feqn_rhs :: rhs - } --} - --- --------------------------------------------------------------------- - -instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where - - markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs pats fixity - defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do - case GHC.dd_ND defn of - GHC.NewType -> mark GHC.AnnNewtype - GHC.DataType -> mark GHC.AnnData - mark GHC.AnnInstance - - markLocated ctx - - markTyClassArgs bndrs fixity ln pats - - case (GHC.dd_kindSig defn) of - Just s -> do - mark GHC.AnnDcolon - markLocated s - Nothing -> return () - if isGadt $ GHC.dd_cons defn - then mark GHC.AnnWhere - else unless (null cons) $ mark GHC.AnnEqual - markDataDefn l (GHC.HsDataDefn GHC.NoExtField nd (GHC.noLoc []) typ _mk cons mderivs) - markOptional GHC.AnnWhere - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsBind GHC.GhcPs) where - markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _) = do - -- Note: from a layout perspective a FunBind should not exist, so the - -- current context is passed through unchanged to the matches. - -- TODO: perhaps bring the edp from the first match up to the annotation for - -- the FunBind. - let - tlFun = - ifInContext (Set.fromList [CtxOnly,CtxFirst]) - (markListWithContexts' listContexts matches) - (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) - ifInContext (Set.singleton TopLevel) - (setContextLevel (Set.singleton TopLevel) 2 tlFun) - tlFun - - -- ----------------------------------- - - markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do - markLocated lhs - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards - _ -> return () - markListIntercalateWithFunLevel markLocated 2 grhs - - -- TODO: extract this common code - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.VarBind _ _n rhse) = - -- Note: this bind is introduced by the typechecker - markLocated rhse - - -- ----------------------------------- - - -- Introduced after renaming. - markAST _ (GHC.AbsBinds {}) = - traceM "warning: AbsBinds introduced after renaming" - - -- ----------------------------------- - - markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do - mark GHC.AnnPattern - case args of - GHC.InfixCon la lb -> do - markLocated la - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated lb - GHC.PrefixCon ns -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated ns - GHC.RecCon fs -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs - mark GHC.AnnCloseC -- '}' - case dir of - GHC.ImplicitBidirectional -> mark GHC.AnnEqual - _ -> mark GHC.AnnLarrow - - markLocated def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markMatchGroup l mg - mark GHC.AnnCloseC -- '}' - - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.IPBind GHC.GhcPs) where - markAST _ (GHC.IPBind _ en e) = do - case en of - Left n -> markLocated n - Right _i -> return () - mark GHC.AnnEqual - markLocated e - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsIPName where - markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where - - markAST l (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do - let - get_infix (GHC.FunRhs _ f _) = f - get_infix _ = GHC.Prefix - - isFunBind GHC.FunRhs{} = True - isFunBind _ = False - case (get_infix mln,pats) of - (GHC.Infix, a:b:xs) -> do - if null xs - then markOptional GHC.AnnOpenP - else mark GHC.AnnOpenP - markLocated a - case mln of - GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n - _ -> return () - markLocated b - if null xs - then markOptional GHC.AnnCloseP - else mark GHC.AnnCloseP - mapM_ markLocated xs - _ -> do - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam - case mln of - GHC.FunRhs n _ s -> do - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do - if (s == GHC.SrcStrict) - then do - markExternal (GHC.srcSpanFirstCharacter l) GHC.AnnBang "!" - markTightPrefix $ markLocated n - else markLocated n - mapM_ markLocated pats - _ -> markListNoPrecedingSpace False pats - - -- TODO: The AnnEqual annotation actually belongs in the first GRHS value - case grhs of - (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards - _ -> return () - inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam - mapM_ markLocated grhs - - case lb of - GHC.EmptyLocalBinds{} -> return () - _ -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where - markAST _ (GHC.GRHS _ guards expr) = do - case guards of - [] -> return () - (_:_) -> do - mark GHC.AnnVbar - unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) - $ markListIntercalate guards - ifInContext (Set.fromList [CaseAlt]) - (return ()) - (mark GHC.AnnEqual) - - markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test - - inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam - setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Sig GHC.GhcPs) where - - markAST _ (GHC.TypeSig _ lns st) = do - setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns - mark GHC.AnnDcolon - markLHsSigWcType st - markTrailingSemi - tellContext (Set.singleton FollowingLine) - - markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do - mark GHC.AnnPattern - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do - when isDefault $ mark GHC.AnnDefault - setContext (Set.singleton PrefixOp) $ markListIntercalate ns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.IdSig {}) = - traceM "warning: Introduced after renaming" - - markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do - let fixstr = case fdir of - GHC.InfixL -> "infixl" - GHC.InfixR -> "infixr" - GHC.InfixN -> "infix" - markWithString GHC.AnnInfix fixstr - markSourceText src (show v) - setContext (Set.singleton InfixOp) $ markListIntercalate lns - markTrailingSemi - - markAST l (GHC.InlineSig _ ln inl) = do - markAnnOpen (GHC.inl_src inl) "{-# INLINE" - markActivation l (GHC.inl_act inl) - setContext (Set.singleton PrefixOp) $ markLocated ln - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - markAST l (GHC.SpecSig _ ln typs inl) = do - markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE - markActivation l (GHC.inl_act inl) - markLocated ln - mark GHC.AnnDcolon -- '::' - markListIntercalateWithFunLevel markLHsSigType 2 typs - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.SpecInstSig _ src typ) = do - markAnnOpen src "{-# SPECIALISE" - mark GHC.AnnInstance - markLHsSigType typ - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - markAST _ (GHC.MinimalSig _ src formula) = do - markAnnOpen src "{-# MINIMAL" - markLocated formula - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.SCCFunSig _ src ln ml) = do - markAnnOpen src "{-# SCC" - markLocated ln - markMaybe ml - markWithString GHC.AnnClose "#-}" - markTrailingSemi - - markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do - markAnnOpen src "{-# COMPLETE" - markListIntercalate ns - case mlns of - Nothing -> return () - Just _ -> do - mark GHC.AnnDcolon - markMaybe mlns - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.StandaloneKindSig GHC.GhcPs) where - - markAST _ (GHC.StandaloneKindSig _ ln st) = do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLHsSigType st - markTrailingSemi - tellContext (Set.singleton FollowingLine) - --- -------------------------------------------------------------------- - -markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () -markLHsSigType (GHC.HsIB _ typ) = markLocated typ - -instance Annotate [GHC.LHsSigType GHC.GhcPs] where - markAST _ ls = do - -- mark GHC.AnnDeriving - -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it - -- is a HsTyVar. So for round trip pretty printing we need to take this into - -- account. - let marker = case ls of - [] -> markManyOptional - [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t) - then markMany - else markManyOptional - _ -> markMany -- Need parens if more than one entry - marker GHC.AnnOpenP - markListIntercalateWithFun markLHsSigType ls - marker GHC.AnnCloseP - --- -------------------------------------------------------------------- - -instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where - markAST _ (GHC.Var x) = do - setContext (Set.singleton PrefixOp) $ markLocated x - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls - markAST _ (GHC.And ls) = do - markListIntercalateWithFunLevel markLocated 2 ls - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - markAST _ (GHC.Parens x) = do - mark GHC.AnnOpenP -- '(' - markLocated x - mark GHC.AnnCloseP -- ')' - inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance (Data flag) => Annotate (GHC.HsTyVarBndr flag GHC.GhcPs) where - markAST _l (GHC.UserTyVar _ f n) = do - markInferred f GHC.AnnOpenC Nothing -- '{' - markLocated n - markInferred f GHC.AnnCloseC Nothing -- '}' - - markAST _ (GHC.KindedTyVar _ f n ty) = do - markInferred f GHC.AnnOpenC (Just GHC.AnnOpenP) - markLocated n - mark GHC.AnnDcolon -- '::' - markLocated ty - markInferred f GHC.AnnCloseC (Just GHC.AnnCloseP) - -markInferred :: Typeable a - => a -> GHC.AnnKeywordId -> (Maybe GHC.AnnKeywordId) -> Annotated () -markInferred flag kw kw2 = - case (cast flag :: Maybe GHC.Specificity) of - (Just GHC.InferredSpec) -> mark kw - _ -> mapM_ mark kw2 - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsType GHC.GhcPs) where - markAST loc ty = do - markType loc ty - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - inContext (Set.singleton InGadt) $ do - mark GHC.AnnRarrow - -- markOptional GHC.AnnLolly - where - - -- markType :: GHC.SrcSpan -> ast -> Annotated () - markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () - markType _ (GHC.HsForAllTy _ tele typ) = do - mark GHC.AnnForall - case tele of - (GHC.HsForAllVis _ qtvs) -> do - mapM_ markLocated qtvs - mark GHC.AnnRarrow - (GHC.HsForAllInvis _ qtvs) -> do - mapM_ markLocated qtvs - mark GHC.AnnDot - markLocated typ - - markType _ (GHC.HsQualTy _ cxt typ) = do - markLocated cxt - markLocated typ - - markType _ (GHC.HsTyVar _ promoted name) = do - when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote - unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name - - markType _ (GHC.HsAppTy _ t1 t2) = do - setContext (Set.singleton PrefixOp) $ markLocated t1 - markLocated t2 - - markType _ (GHC.HsAppKindTy l t k) = do - setContext (Set.singleton PrefixOp) $ markLocated t - markTypeApp l - markTightPrefix $ markLocated k - - markType _ (GHC.HsFunTy _ arrow t1 t2) = do - markLocated t1 - markArrow arrow - -- case arrow of - -- GHC.HsLinearArrow -> do - -- case u of - -- GHC.NormalSyntax -> do - -- mark GHC.AnnMult -- "%1" - -- mark GHC.AnnRarrow - -- GHC.UnicodeSyntax -> mark GHC.AnnLollyU - -- GHC.HsUnrestrictedArrow -> mark GHC.AnnRarrow -- a -> b - -- GHC.HsExplicitMult _ -> do - -- mark GHC.AnnMult -- "%1" - -- mark GHC.AnnRarrow - -- arr = case mult of - -- HsLinearArrow -> lollipop - -- HsUnrestrictedArrow -> arrow - -- HsExplicitMult p -> mulArrow (ppr p) --- lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") --- mulArrow d = text "%" <> d <+> arrow - - - markLocated t2 - - markType _ (GHC.HsListTy _ t) = do - mark GHC.AnnOpenS -- '[' - markLocated t - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsTupleTy _ tt ts) = do - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' - _ -> markWithString GHC.AnnOpen "(#" -- '(#' - markListIntercalateWithFunLevel markLocated 2 ts - case tt of - GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' - _ -> markWithString GHC.AnnClose "#)" -- '#)' - - markType _ (GHC.HsSumTy _ tys) = do - markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys - markWithString GHC.AnnClose "#)" - - markType _ (GHC.HsOpTy _ t1 lo t2) = do - markLocated t1 - if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) - then do - markOptional GHC.AnnSimpleQuote - else do - mark GHC.AnnSimpleQuote - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo - markLocated t2 - - markType _ (GHC.HsParTy _ t) = do - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnCloseP -- ')' - - markType _ (GHC.HsIParamTy _ n t) = do - markLocated n - mark GHC.AnnDcolon - markLocated t - - markType l (GHC.HsStarTy _ isUnicode) = do - if isUnicode - then markExternal l GHC.AnnVal "\x2605" -- Unicode star - else markExternal l GHC.AnnVal "*" - - markType _ (GHC.HsKindSig _ t k) = do - markOptional GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnDcolon -- '::' - markLocated k - markOptional GHC.AnnCloseP -- ')' - - markType l (GHC.HsSpliceTy _ s) = do - markAST l s - - markType _ (GHC.HsDocTy _ t ds) = do - markLocated t - markLocated ds - - markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do - case mt of - GHC.NoSourceText -> return () - GHC.SourceText src -> do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - case str of - GHC.SrcLazy -> do - mark GHC.AnnTilde - markTightPrefix $ markLocated t - GHC.SrcStrict -> do - mark GHC.AnnBang - markTightPrefix $ markLocated t - GHC.NoSrcStrict -> markLocated t - - - markType _ (GHC.HsRecTy _ cons) = do - mark GHC.AnnOpenC -- '{' - markListIntercalate cons - mark GHC.AnnCloseC -- '}' - - markType _ (GHC.HsExplicitListTy _ promoted ts) = do - when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote - mark GHC.AnnOpenS -- "[" - markListIntercalate ts - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsExplicitTupleTy _ ts) = do - mark GHC.AnnSimpleQuote - mark GHC.AnnOpenP - markListIntercalate ts - mark GHC.AnnCloseP - - markType l (GHC.HsTyLit _ lit) = do - case lit of - (GHC.HsNumTy s v) -> - markExternalSourceText l s (show v) - (GHC.HsStrTy s v) -> - markExternalSourceText l s (show v) - - markType l (GHC.HsWildCardTy _) = do - markExternal l GHC.AnnVal "_" - - markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x - - --- --------------------------------------------------------------------- - --- instance Annotate (GHC.HsAppType GHC.GhcPs) where --- markAST _ (GHC.HsAppInfix _ n) = do --- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote --- setContext (Set.singleton InfixOp) $ markLocated n --- markAST _ (GHC.HsAppPrefix _ t) = do --- markOptional GHC.AnnTilde --- setContext (Set.singleton PrefixOp) $ markLocated t - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsSplice GHC.GhcPs) where - markAST l c = - case c of - GHC.HsQuasiQuote _ _ n _pos fs -> do - markExternal l GHC.AnnVal - -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") - - GHC.HsTypedSplice _ decoration _n b -> do - if (decoration == GHC.DollarSplice) - then do - mark GHC.AnnDollarDollar - markTightPrefix $ markLocated b - else markLocated b - - GHC.HsUntypedSplice _ decoration _n b -> do - if (decoration == GHC.DollarSplice) - then do - mark GHC.AnnDollar - markTightPrefix $ markLocated b - else markLocated b - - GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDeclField GHC.GhcPs) where - markAST _ (GHC.ConDeclField _ ns ty mdoc) = do - unsetContext Intercalate $ do - markListIntercalate ns - mark GHC.AnnDcolon - markLocated ty - markMaybe mdoc - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FieldOcc GHC.GhcPs) where - markAST _ (GHC.FieldOcc _ rn) = do - markLocated rn - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsDocString where - markAST l s = do - markExternal l GHC.AnnVal (GHC.unpackHDS s) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.Pat GHC.GhcPs) where - markAST loc typ = do - markPat loc typ - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") - where - markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" - markPat l (GHC.VarPat _ n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is - -- resolved, particularly for pretty printing where annotations are added. - let pun_RDR = "pun-right-hand-side" - when (showGhc n /= pun_RDR) $ - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) - -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n - markPat _ (GHC.LazyPat _ p) = do - mark GHC.AnnTilde - markTightPrefix $ markLocated p - - markPat _ (GHC.AsPat _ ln p) = do - markLocated ln - mark GHC.AnnAt - markTightPrefix $ markLocated p - - markPat _ (GHC.ParPat _ p) = do - mark GHC.AnnOpenP - markLocated p - mark GHC.AnnCloseP - - markPat _ (GHC.BangPat _ p) = do - mark GHC.AnnBang - markTightPrefix $ markLocated p - - markPat _ (GHC.ListPat _ ps) = do - mark GHC.AnnOpenS - markListIntercalateWithFunLevel markLocated 2 ps - mark GHC.AnnCloseS - - markPat _ (GHC.TuplePat _ pats b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevel markLocated 2 pats - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markPat _ (GHC.SumPat _ pat alt arity) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated pat - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markPat _ (GHC.ConPat _ n dets) = do - markHsConPatDetails n dets - - markPat _ (GHC.ViewPat _ e pat) = do - markLocated e - mark GHC.AnnRarrow - markLocated pat - - markPat l (GHC.SplicePat _ s) = do - markAST l s - - markPat l (GHC.LitPat _ lp) = markAST l lp - - markPat _ (GHC.NPat _ ol mn _) = do - when (isJust mn) $ mark GHC.AnnMinus - markLocated ol - - markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do - markLocated ln - markWithString GHC.AnnVal "+" -- "+" - markLocated ol - - markPat _ (GHC.SigPat _ pat (GHC.HsPS _ ty)) = do - markLocated pat - mark GHC.AnnDcolon - markLocated ty - --- --------------------------------------------------------------------- - -hsLit2String :: GHC.HsLit GHC.GhcPs -> String -hsLit2String lit = - case lit of - GHC.HsChar src v -> toSourceTextWithSuffix src v "" - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" - GHC.HsString src v -> toSourceTextWithSuffix src v "" - GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" - GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" - GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" - GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" - GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" - GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" - GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" - -toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String -toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix - --- -------------------------------------------------------------------- - -markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () -markHsConPatDetails ln dets = do - case dets of - GHC.PrefixCon args -> do - setContext (Set.singleton PrefixOp) $ markLocated ln - mapM_ markLocated args - GHC.RecCon (GHC.HsRecFields fs dd) -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - case dd of - Nothing -> markListIntercalateWithFunLevel markLocated 2 fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- '}' - GHC.InfixCon a1 a2 -> do - markLocated a1 - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln - markLocated a2 - -{- -type HsConDeclDetails pass - = HsConDetails (HsScaled pass (LBangType pass)) (Located [LConDeclField pass]) --} -markHsConDeclDetails :: - Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () -markHsConDeclDetails isDeprecated inGadt lns dets = do - case dets of - GHC.PrefixCon args -> - if inGadt - then setContextLevel (Set.fromList [InGadt,PrefixOp]) 2 $ - mapM_ markScaled args - else setContextLevel (Set.singleton PrefixOp ) 2 $ - mapM_ markScaled args - GHC.RecCon fs -> do - mark GHC.AnnOpenC - if inGadt - then do - if isDeprecated - then setContextLevel (Set.fromList [InGadt]) 2 $ markLocated fs - else setContextLevel (Set.fromList [InGadt,InRecCon]) 2 $ markLocated fs - else do - if isDeprecated - then markLocated fs - else setContextLevel (Set.fromList [InRecCon]) 2 $ markLocated fs - GHC.InfixCon a1 a2 -> do - markScaled a1 - setContext (Set.singleton InfixOp) $ mapM_ markLocated lns - markScaled a2 - --- --------------------------------------------------------------------- - --- markScaled :: (GHC.HsScaled GHC.GhcPs (GHC.Located a)) -> Annotated () -markScaled :: (GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)) -> Annotated () -markScaled a@(GHC.HsScaled _rr (GHC.L l _)) = markLocated (GHC.L l a) - -instance Annotate (GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)) where - markAST _ (GHC.HsScaled arrow a) = do - markLocated a - inContext (Set.singleton InGadt) $ do - markArrow arrow - -- -- AZ:TODO: fix this, with the new syntax - -- case arrow of - -- GHC.HsUnrestrictedArrow -> mark GHC.AnnRarrow -- a -> b - -- GHC.HsLinearArrow -> mark GHC.AnnLollyU -- a #-> b - -- GHC.HsExplicitMult _ -> mark GHC.AnnLollyU -- a #-> b - -- markOptional GHC.AnnRarrow -- See https://gitlab.haskell.org/ghc/ghc/-/commit/7f418acf61e#note_304011 --- --------------------------------------------------------------------- - -markArrow :: GHC.HsArrow GhcPs -> Annotated () -markArrow arrow = do - case arrow of - GHC.HsLinearArrow u -> do - case u of - GHC.NormalSyntax -> do - mark GHC.AnnPercentOne -- "%1" - mark GHC.AnnRarrow - GHC.UnicodeSyntax -> mark GHC.AnnLollyU - GHC.HsUnrestrictedArrow u -> - case u of - GHC.NormalSyntax -> mark GHC.AnnRarrow -- a -> b - GHC.UnicodeSyntax -> mark GHC.AnnRarrowU -- a ⊸ b - GHC.HsExplicitMult u t -> do - mark GHC.AnnPercent - setContextLevel (Set.fromList [NoPrecedingSpace, InTypeApp]) 2 $ markLocated t - case u of - GHC.NormalSyntax -> mark GHC.AnnRarrow -- -> - GHC.UnicodeSyntax -> mark GHC.AnnRarrowU -- ⊸ - --- data HsArrow pass --- = HsUnrestrictedArrow IsUnicodeSyntax --- -- ^ a -> b or a → b --- | HsLinearArrow IsUnicodeSyntax --- -- ^ a %1 -> b or a %1 → b, or a ⊸ b --- | HsExplicitMult IsUnicodeSyntax (LHsType pass) --- -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! - - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LConDeclField GHC.GhcPs] where - markAST _ fs = do - markOptional GHC.AnnOpenC -- '{' - markListIntercalate fs - markOptional GHC.AnnDotdot - inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' - -- inContext (Set.singleton InRecCon) $ do - -- mark GHC.AnnRarrow - inContext (Set.singleton InGadt) $ do - mark GHC.AnnRarrow - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsOverLit GHC.GhcPs) where - markAST l ol = - let str = case GHC.ol_val ol of - GHC.HsIntegral (GHC.IL src _ _) -> src - GHC.HsFractional (GHC.FL src _ _) -> src - GHC.HsIsString src _ -> src - in - markExternalSourceText l str "" - --- --------------------------------------------------------------------- - -instance (Annotate arg) - => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where - markAST _ (GHC.HsIB _ thing) = do - markLocated thing - --- --------------------------------------------------------------------- - -instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where - - markAST _ (GHC.LastStmt _ body _ _) - = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - markAST _ (GHC.BindStmt _ pat body) = do - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat - mark GHC.AnnLarrow - unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body - - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST _ GHC.ApplicativeStmt{} - = error "ApplicativeStmt should not appear in ParsedSource" - - markAST _ (GHC.BodyStmt _ body _ _) = do - unsetContext Intercalate $ markLocated body - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - markOptional GHC.AnnCloseC -- '}' - ifInContext (Set.singleton Intercalate) - (mark GHC.AnnComma) - (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) - markTrailingSemi - - markAST l (GHC.ParStmt _ pbs _ _) = do - -- Within a given parallel list comprehension,one of the sections to be done - -- in parallel. It is a normal list comprehension, so has a list of - -- ParStmtBlock, one for each part of the sub- list comprehension - - - ifInContext (Set.singleton Intercalate) - ( - - unsetContext Intercalate $ - markListWithContextsFunction - (LC (Set.singleton Intercalate) -- only - Set.empty -- first - Set.empty -- middle - (Set.singleton Intercalate) -- last - ) (markAST l) pbs - ) - ( - unsetContext Intercalate $ - markListWithContextsFunction - (LC Set.empty -- only - (Set.fromList [AddVbar]) -- first - (Set.fromList [AddVbar]) -- middle - Set.empty -- last - ) (markAST l) pbs - ) - markTrailingSemi - - markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do - setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts - case form of - GHC.ThenForm -> do - mark GHC.AnnThen - unsetContext Intercalate $ markLocated using - case by of - Just b -> do - mark GHC.AnnBy - unsetContext Intercalate $ markLocated b - Nothing -> return () - GHC.GroupForm -> do - mark GHC.AnnThen - mark GHC.AnnGroup - case by of - Just b -> mark GHC.AnnBy >> markLocated b - Nothing -> return () - mark GHC.AnnUsing - markLocated using - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - - markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do - mark GHC.AnnRec - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - markListWithLayout stmts - markOptional GHC.AnnCloseC - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - --- --------------------------------------------------------------------- - --- Note: We never have a located ParStmtBlock, so have nothing to hang the --- annotation on. This means there is no pushing of context from the parent ParStmt. -instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where - markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do - markListIntercalate stmts - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where - markAST _ lb = markHsLocalBinds lb - --- --------------------------------------------------------------------- - -markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () -markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) = - applyListAnnotationsLayout - (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ) -markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds -markHsLocalBinds GHC.EmptyLocalBinds{} = return () - -markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension" - --- --------------------------------------------------------------------- - -markMatchGroup :: (Annotate body) - => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) - -> Annotated () -markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _) - = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches - --- --------------------------------------------------------------------- - -instance (Annotate body) - => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsExpr GHC.GhcPs) where - markAST loc expr = do - markExpr loc expr - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - -- TODO: If the AnnComma is not needed, revert to markAST - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - where - markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do - ifInContext (Set.singleton PrefixOp) - (setContext (Set.singleton PrefixOp) $ markLocated n) - (ifInContext (Set.singleton InfixOp) - (setContext (Set.singleton InfixOp) $ markLocated n) - (markLocated n) - ) - - markExpr l (GHC.HsUnboundVar {}) = do - ifInContext (Set.fromList [InfixOp]) - (do mark GHC.AnnBackquote - markWithString GHC.AnnVal "_" - mark GHC.AnnBackquote) - (markExternal l GHC.AnnVal "_") - - markExpr l (GHC.HsRecFld _ f) = markAST l f - - markExpr l (GHC.HsOverLabel _ _ fs) - = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) - - - markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) = - markAST l n - markExpr l (GHC.HsOverLit _ ov) = markAST l ov - markExpr l (GHC.HsLit _ lit) = markAST l lit - - markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do - setContext (Set.singleton LambdaExpr) $ do - -- TODO: Change this, HsLam binds do not need obey layout rules. - -- And will only ever have a single match - markLocated match - markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match" - - markExpr l (GHC.HsLamCase _ match) = do - mark GHC.AnnLam - mark GHC.AnnCase - markOptional GHC.AnnSemi - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l match - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsApp _ e1 e2) = do - setContext (Set.singleton PrefixOp) $ markLocated e1 - setContext (Set.singleton PrefixOp) $ markLocated e2 - - -- ------------------------------- - - markExpr _ (GHC.OpApp _ e1 e2 e3) = do - let - isInfix = case e2 of - -- TODO: generalise this. Is it a fixity thing? - GHC.L _ (GHC.HsVar{}) -> True - _ -> False - - normal = - -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context - ifInContext (Set.singleton LeftMost) - (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) - (markLocated e1) - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - else normal - - unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 - - if isInfix - then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 - else markLocated e3 - - -- ------------------------------- - - markExpr _ (GHC.NegApp _ e _) = do - mark GHC.AnnMinus - markLocated e - - markExpr _ (GHC.HsPar _ e) = do - mark GHC.AnnOpenP -- '(' - markLocated e - mark GHC.AnnCloseP -- ')' - - markExpr _ (GHC.SectionL _ e1 e2) = do - markLocated e1 - setContext (Set.singleton InfixOp) $ markLocated e2 - - markExpr _ (GHC.SectionR _ e1 e2) = do - setContext (Set.singleton InfixOp) $ markLocated e1 - markLocated e2 - - markExpr _ (GHC.ExplicitTuple _ args b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args - - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markExpr _ (GHC.ExplicitSum _ alt arity e) = do - markWithString GHC.AnnOpen "(#" - replicateM_ (alt - 1) $ mark GHC.AnnVbar - markLocated e - replicateM_ (arity - alt) $ mark GHC.AnnVbar - markWithString GHC.AnnClose "#)" - - markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do - mark GHC.AnnCase - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - setContext (Set.singleton CaseAlt) $ markMatchGroup l matches - markOptional GHC.AnnCloseC - - -- We set the layout for HsIf even though it need not obey layout rules as - -- when moving these expressions it's useful that they maintain "internal - -- integrity", that is to say the subparts remain indented relative to each - -- other. - markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do - mark GHC.AnnIf - markLocated e1 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen - mark GHC.AnnThen - setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse - mark GHC.AnnElse - setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 - - markExpr _ (GHC.HsMultiIf _ rhs) = do - mark GHC.AnnIf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - -- mapM_ markLocated rhs - markListWithLayout rhs - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do - setLayoutFlag (do -- Make sure the 'in' gets indented too - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e) - - -- ------------------------------- - - markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do - case cts of - GHC.DoExpr Nothing -> mark GHC.AnnDo - GHC.DoExpr (Just mn) -> - markWithString GHC.AnnDo ((GHC.moduleNameString mn) ++ ".do") - GHC.MDoExpr Nothing -> mark GHC.AnnMdo - GHC.MDoExpr (Just mn) -> - markWithString GHC.AnnMdo ((GHC.moduleNameString mn) ++ ".mdo") - _ -> return () - let (ostr,cstr) = - if isListComp cts - then ("[", "]") - else ("{", "}") - - when (isListComp cts) $ markWithString GHC.AnnOpen ostr - markOptional GHC.AnnOpenS - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - if isListComp cts - then do - markLocated (last es) - mark GHC.AnnVbar - setLayoutFlag (markListIntercalate (init es)) - else do - markListWithLayout es - markOptional GHC.AnnCloseS - markOptional GHC.AnnCloseC - when (isListComp cts) $ markWithString GHC.AnnClose cstr - - -- ------------------------------- - - markExpr _ (GHC.ExplicitList _ _ es) = do - mark GHC.AnnOpenS - setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es - mark GHC.AnnCloseS - - markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do - markLocated n - mark GHC.AnnOpenC - case dd of - Nothing -> markListIntercalate fs - Just _ -> do - setContext (Set.singleton Intercalate) $ mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC - - markExpr _ (GHC.RecordUpd _ e fs) = do - markLocated e - mark GHC.AnnOpenC - markListIntercalate fs - mark GHC.AnnCloseC - - markExpr _ (GHC.ExprWithTySig _ e typ) = do - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e - mark GHC.AnnDcolon - markLHsSigWcType typ - - markExpr _ (GHC.ArithSeq _ _ seqInfo) = do - mark GHC.AnnOpenS -- '[' - case seqInfo of - GHC.From e -> do - markLocated e - mark GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - markLocated e1 - mark GHC.AnnDotdot - markLocated e2 - GHC.FromThen e1 e2 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - markLocated e3 - mark GHC.AnnCloseS -- ']' - - - -- markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do - -- -- markWithString GHC.AnnOpen src -- "{-# CORE" - -- markAnnOpen src "{-# CORE" - -- -- markWithString GHC.AnnVal (GHC.sl_st csFStr) - -- markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - -- markWithString GHC.AnnClose "#-}" - -- markLocated e - -- TODO: make monomorphic - markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do - mark GHC.AnnSimpleQuote - setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do - mark GHC.AnnThTyQuote - markLocatedFromKw GHC.AnnName (GHC.L l v) - markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do - markWithString GHC.AnnOpen "[d|" - markOptional GHC.AnnOpenC - setContext (Set.singleton NoAdvanceLine) - $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds - markOptional GHC.AnnCloseC - mark GHC.AnnCloseQ -- "|]" - -- Introduced after the renamer - markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) = - traceM "warning: DecBrG introduced after renamer" - markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do - mark GHC.AnnOpenEQ -- "[|" - markOptional GHC.AnnOpenE -- "[e|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do - markWithString GHC.AnnOpen "[||" - markWithStringOptional GHC.AnnOpenE "[e||" - markLocated e - markWithString GHC.AnnClose "||]" - markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do - markWithString GHC.AnnOpen "[t|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do - markWithString GHC.AnnOpen "[p|" - markLocated e - mark GHC.AnnCloseQ -- "|]" - - markExpr _ (GHC.HsRnBracketOut {}) = - traceM "warning: HsRnBracketOut introduced after renamer" - markExpr _ (GHC.HsTcBracketOut {}) = - traceM "warning: HsTcBracketOut introduced after renamer" - - markExpr l (GHC.HsSpliceE _ e) = markAST l e - - markExpr _ (GHC.HsProc _ p c) = do - mark GHC.AnnProc - markLocated p - mark GHC.AnnRarrow - markLocated c - - markExpr _ (GHC.HsStatic _ e) = do - mark GHC.AnnStatic - markLocated e - - markExpr _ (GHC.HsTick {}) = return () - markExpr _ (GHC.HsBinTick {}) = return () - markExpr _ (GHC.HsPragE _ prag e) = do - case prag of - (GHC.HsPragSCC _ src csFStr) -> do - markAnnOpen src "{-# SCC" - let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) - markWithStringOptional GHC.AnnVal txt - markWithString GHC.AnnValStr txt - markWithString GHC.AnnClose "#-}" - markLocated e - - (GHC.HsPragTick _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4))) -> do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markAnnOpen src "{-# GENERATED" - markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING - - let - markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) - markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s - - markOne 1 v1 s1 -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOne 2 v2 s2 -- INTEGER - mark GHC.AnnMinus -- '-' - markOne 3 v3 s3 -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOne 4 v4 s4 -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr _ (GHC.HsAppType _ e ty) = do - markLocated e - markInstead GHC.AnnAt AnnTypeApp - markTightPrefix $ markLHsWcType ty - - -- markExpr _ (GHC.HsWrap {}) = - -- traceM "warning: HsWrap introduced after renaming" - - markExpr _ (GHC.HsConLikeOut{}) = - traceM "warning: HsConLikeOut introduced after type checking" - - -- markExpr _ x = - -- error $ "markExpr: not matched for " ++ showAnnData mempty 0 x - --- --------------------------------------------------------------------- - -markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () -markLHsWcType (GHC.HsWC _ ty) = do - markLocated ty - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsLit GHC.GhcPs) where - markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where - markAST _ (GHC.HsRecField lbl expr punFlag) = do - unsetContext Intercalate $ markLocated lbl - when (punFlag == False) $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated expr - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - -instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where - markAST _ (GHC.Unambiguous _ n) = markLocated n - markAST _ (GHC.Ambiguous _ n) = markLocated n - --- --------------------------------------------------------------------- - --- |Used for declarations that need to be aligned together, e.g. in a --- do or let .. in statement/expr -instance Annotate [GHC.ExprLStmt GHC.GhcPs] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsTupArg GHC.GhcPs) where - markAST _ (GHC.Present _ (GHC.L l e)) = do - markLocated (GHC.L l e) - inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) - - markAST _ (GHC.Missing _) = do - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsCmdTop GHC.GhcPs) where - markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd - -instance Annotate (GHC.HsCmd GHC.GhcPs) where - markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do - -- The AnnOpen should be marked for a prefix usage, not for a postfix one, - -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm - - let isPrefixOp = case fixity of - GHC.Infix -> False - GHC.Prefix -> True - when isPrefixOp $ mark GHC.AnnOpenB -- "(|" - - -- This may be an infix operation - applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) - (Set.singleton InfixOp) (Set.singleton InfixOp)) - (prepareListAnnotation [e] - ++ prepareListAnnotation cs) - when isPrefixOp $ mark GHC.AnnCloseB -- "|)" - - markAST _ (GHC.HsCmdApp _ e1 e2) = do - markLocated e1 - markLocated e2 - - markAST l (GHC.HsCmdLam _ match) = do - setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match - - markAST _ (GHC.HsCmdPar _ e) = do - mark GHC.AnnOpenP - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsCmdCase _ e1 matches) = do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l matches - markOptional GHC.AnnCloseC - - markAST l (GHC.HsCmdLamCase _ matches) = do - mark GHC.AnnLam - mark GHC.AnnCase - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l matches - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do - mark GHC.AnnIf - markLocated e1 - markOffset GHC.AnnSemi 0 - mark GHC.AnnThen - markLocated e2 - markOffset GHC.AnnSemi 1 - mark GHC.AnnElse - markLocated e3 - - markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e - - markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do - mark GHC.AnnDo - markOptional GHC.AnnOpenC - markListWithLayout es - markOptional GHC.AnnCloseC - - -- markAST _ (GHC.HsCmdWrap {}) = - -- traceM "warning: HsCmdWrap introduced after renaming" - - -- markAST _ x = error $ "got HsCmd for:" ++ showAnnData mempty 0 x - --- --------------------------------------------------------------------- - -instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyClDecl GHC.GhcPs) where - - markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi -{- - SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs - , tcdLName :: Located (IdP pass) -- ^ Type constructor - , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an - -- associated type these - -- include outer binders - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType pass } -- ^ RHS of type declaration - --} - markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do - -- There may be arbitrary parens around parts of the constructor that are - -- infix. - -- Turn these into comments so that they feed into the right place automatically - -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - mark GHC.AnnType - - markTyClass fixity ln tyvars - mark GHC.AnnEqual - markLocated typ - markTrailingSemi - - markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity - (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do - if nd == GHC.DataType - then mark GHC.AnnData - else mark GHC.AnnNewtype - markMaybe mctyp - markLocated ctx - markTyClass fixity ln tyVars - case mk of - Nothing -> return () - Just k -> do - mark GHC.AnnDcolon - markLocated k - if isGadt cons - then mark GHC.AnnWhere - else unless (null cons) $ mark GHC.AnnEqual - -- markOptional GHC.AnnWhere - markOptional GHC.AnnOpenC - setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) - $ markListWithContexts' listContexts cons - markOptional GHC.AnnCloseC - setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs - markTrailingSemi - - -- ----------------------------------- - - markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds - sigs meths ats atdefs docs) = do - mark GHC.AnnClass - markLocated ctx - - markTyClass fixity ln tyVars - - unless (null fds) $ do - mark GHC.AnnVbar - markListIntercalateWithFunLevel markLocated 2 fds - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - -- AZ:TODO: we end up with both the tyVars and the following body of the - -- class defn in annSortKey for the class. This could cause problems when - -- changing things. - setContext (Set.singleton InClassDecl) $ - applyListAnnotationsLayout - (prepareListAnnotation sigs - ++ prepareListAnnotation (GHC.bagToList meths) - ++ prepareListAnnotation ats - ++ prepareListAnnotation atdefs - ++ prepareListAnnotation docs - ) - markOptional GHC.AnnCloseC -- '}' - markTrailingSemi -{- - | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdCtxt :: LHsContext pass, -- ^ Context... - tcdLName :: Located (IdP pass), -- ^ Name of the class - tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables - tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [Located (FunDep (Located (IdP pass)))], - -- ^ Functional deps - tcdSigs :: [LSig pass], -- ^ Methods' signatures - tcdMeths :: LHsBinds pass, -- ^ Default methods - tcdATs :: [LFamilyDecl pass], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltEqn pass], - -- ^ Associated type defaults - tcdDocs :: [LDocDecl] -- ^ Haddock docs - } - --} - --- --------------------------------------------------------------------- - -markTypeApp :: GHC.SrcSpan -> Annotated () -markTypeApp loc = do - let l = GHC.srcSpanFirstCharacter loc - markExternal l GHC.AnnVal "@" - --- --------------------------------------------------------------------- - -markTyClassArgs :: (Annotate a, Data flag) - => Maybe [GHC.LHsTyVarBndr flag GhcPs] -> GHC.LexicalFixity - -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated () -markTyClassArgs mbndrs fixity ln tyVars = do - let - cvt (GHC.HsValArg val) = markLocated val - cvt (GHC.HsTypeArg loc typ) = do - markTypeApp loc - markTightPrefix $ markLocated typ - cvt (GHC.HsArgPar _ss) = undefined - markTyClassWorker cvt mbndrs fixity ln tyVars - {- -type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) - -data HsArg tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg ty -- Argument is a visible type application (f @ty) - | HsArgPar SrcSpan -- See Note [HsArgPar] --} - --- TODO:AZ: simplify -markTyClass :: (Annotate a, Annotate ast) - => GHC.LexicalFixity -> GHC.Located a - -> [GHC.Located ast] -> Annotated () -markTyClass = markTyClassWorker markLocated (Nothing :: Maybe [GHC.LHsTyVarBndr () GhcPs]) - -markTyClassWorker :: (Annotate a, Data flag) - => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr flag GhcPs] -> GHC.LexicalFixity - -> GHC.Located a -> [b] -> Annotated () -markTyClassWorker markFn mbndrs fixity ln tyVars = do - let processBinders = - case mbndrs of - Nothing -> return () - Just bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - -- There may be arbitrary parens around parts of the constructor - -- Turn these into comments so that they feed into the right place automatically - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - let markParens = if fixity == GHC.Infix && length tyVars > 2 - then markMany - else markManyOptional - if fixity == GHC.Prefix - then do - markManyOptional GHC.AnnOpenP - processBinders - setContext (Set.singleton PrefixOp) $ markLocated ln - -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars - setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars - when (length tyVars >= 2) $ do - markParens GHC.AnnCloseP - setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars - markManyOptional GHC.AnnCloseP - else do - case tyVars of - (x:y:xs) -> do - markParens GHC.AnnOpenP - processBinders - markFn x - setContext (Set.singleton InfixOp) $ markLocated ln - markFn y - markParens GHC.AnnCloseP - mapM_ markFn xs - markManyOptional GHC.AnnCloseP - _ -> error $ "markTyClass: Infix op without operands" - --- --------------------------------------------------------------------- - -instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where - markAST _ ds = mapM_ markLocated ds - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where - markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do - mark GHC.AnnDeriving - case mstrategy of - Nothing -> return () - Just (GHC.L _ (GHC.ViaStrategy{})) -> return () - Just s -> markLocated s - markLocated typs - case mstrategy of - Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s - _ -> return () - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyDecl GHC.GhcPs) where - markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do - case info of - GHC.DataFamily -> mark GHC.AnnData - _ -> mark GHC.AnnType - - mark GHC.AnnFamily - - markTyClass fixity ln tyvars - case GHC.unLoc rsig of - GHC.NoSig _ -> return () - GHC.KindSig _ _ -> do - mark GHC.AnnDcolon - markLocated rsig - GHC.TyVarSig _ _ -> do - mark GHC.AnnEqual - markLocated rsig - case minj of - Nothing -> return () - Just inj -> do - mark GHC.AnnVbar - markLocated inj - case info of - GHC.ClosedTypeFamily (Just eqns) -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- { - markListWithLayout eqns - markOptional GHC.AnnCloseC -- } - GHC.ClosedTypeFamily Nothing -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- { - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- } - _ -> return () - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where - markAST _ (GHC.NoSig _) = return () - markAST _ (GHC.KindSig _ k) = markLocated k - markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv - --- --------------------------------------------------------------------- - -instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where - markAST _ (GHC.InjectivityAnn ln lns) = do - markLocated ln - mark GHC.AnnRarrow - mapM_ markLocated lns - --- --------------------------------------------------------------------- - -instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where -{- -type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) - -type FamInstEqn pass rhs - = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) - -type HsTyPats pass = [LHsTypeArg pass] - --} - markAST _ (GHC.HsIB _ eqn) = do - markFamEqn eqn - markTrailingSemi - --- --------------------------------------------------------------------- - --- instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where - --- markAST _ (GHC.FamEqn _ ln mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do --- mark GHC.AnnType --- mark GHC.AnnInstance --- markTyClass mbndrs fixity ln bndrs --- mark GHC.AnnEqual --- markLocated typ - - -- markAST _ (GHC.FamEqn _ _ _ (GHC.XLHsQTyVars _) _ _) - -- = error "TyFamDefltEqn hit extension point" - -- markAST _ (GHC.XFamEqn _) - -- = error "TyFamDefltEqn hit extension point" - --- --------------------------------------------------------------------- - --- TODO: modify lexer etc, in the meantime to not set haddock flag -instance Annotate GHC.DocDecl where - markAST l v = - let str = - case v of - (GHC.DocCommentNext ds) -> GHC.unpackHDS ds - (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds - (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds - (GHC.DocGroup _i ds) -> GHC.unpackHDS ds - in - markExternal l GHC.AnnVal str >> markTrailingSemi -{- -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - --} - --- --------------------------------------------------------------------- - -markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () -markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do - markLocated ctx - markMaybe typ - if isGadt cons - then markListWithLayout cons - else markListIntercalateWithFunLevel markLocated 2 cons - setContext (Set.singleton Deriving) $ markLocated derivs - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance Annotate [GHC.LHsType GHC.GhcPs] where - markAST l ts = do - -- Note: A single item in parens in a standalone deriving clause - -- is parsed as a HsSigType, which is always a HsForAllTy or - -- HsQualTy. Without parens it is always a HsVar. So for round - -- trip pretty printing we need to take this into account. - let - parenIfNeeded' pa = - case ts of - [] -> if l == GHC.noSrcSpan - then markManyOptional pa - else markMany pa - [GHC.L _ GHC.HsForAllTy{}] -> markMany pa - [GHC.L _ GHC.HsQualTy{}] -> markMany pa - [_] -> markManyOptional pa - _ -> markMany pa - - parenIfNeeded'' pa = - ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set? - (markMany pa) - (parenIfNeeded' pa) - - parenIfNeeded pa = - case ts of - [GHC.L _ GHC.HsParTy{}] -> markOptional pa - _ -> parenIfNeeded'' pa - - -- ------------- - - parenIfNeeded GHC.AnnOpenP - - unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts - - parenIfNeeded GHC.AnnCloseP - - ifInContext (Set.singleton NoDarrow) - (return ()) - (if null ts && (l == GHC.noSrcSpan) - then markOptional GHC.AnnDarrow - else mark GHC.AnnDarrow) - --- --------------------------------------------------------------------- - -instance Annotate (GHC.ConDecl GHC.GhcPs) where - markAST _ (GHC.ConDeclH98 _ ln (GHC.L _ fa) mqtvs mctx - dets _) = do - when fa $ do - mark GHC.AnnForall - mapM_ markLocated mqtvs - mark GHC.AnnDot - - case mctx of - Just ctx -> do - setContext (Set.fromList [NoDarrow]) $ markLocated ctx - mark GHC.AnnDarrow - Nothing -> return () - - case dets of - GHC.InfixCon _ _ -> return () - _ -> setContext (Set.singleton PrefixOp) $ markLocated ln - - markHsConDeclDetails False False [ln] dets - - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar - markTrailingSemi - - markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do - let - surroundParens - = case args of - GHC.PrefixCon [] -> null qvars && not (isJust mbCxt) - _ -> False - - -- null qvars && - -- mbCxt == Nothing && - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - annotationsToComments [GHC.AnnOpenP] - if surroundParens - then mark GHC.AnnOpenP - else return () - markLocated (GHC.L l (ResTyGADTHook forall qvars)) - markMaybe mbCxt - markHsConDeclDetails False True lns args - markLocated typ - if surroundParens - then mark GHC.AnnCloseP - else markManyOptional GHC.AnnCloseP - markTrailingSemi - --- --------------------------------------------------------------------- - --- ResTyGADT has a SrcSpan for the original sigtype, we need to create --- a type for exactPC and annotatePC -data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.Specificity GHC.GhcPs] - deriving (Typeable) -deriving instance Data (ResTyGADTHook) - -instance GHC.Outputable ResTyGADTHook where - ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs - - --- WildCardAnon exists because the GHC anonymous wildcard type is defined as --- = AnonWildCard (PostRn name Name) --- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but --- the instance doing this is parameterised on name, so we cannot put a value in --- for the (PostRn name Name) field. This is used instead. -data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable) - -instance Annotate WildCardAnon where - markAST l WildCardAnon = do - markExternal l GHC.AnnVal "_" - --- --------------------------------------------------------------------- - -instance Annotate ResTyGADTHook where - markAST _ (ResTyGADTHook forall bndrs) = do - -- markManyOptional GHC.AnnOpenP - when forall $ mark GHC.AnnForall - mapM_ markLocated bndrs - when forall $ mark GHC.AnnDot - -- markManyOptional GHC.AnnCloseP - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.Located (GHC.Pat GHC.GhcPs))) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - --- instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where --- markAST _ (GHC.HsRecField n e punFlag) = do --- unsetContext Intercalate $ markLocated n --- unless punFlag $ do --- mark GHC.AnnEqual --- unsetContext Intercalate $ markLocated e --- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - - -instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where - markAST _ (GHC.HsRecField n e punFlag) = do - unsetContext Intercalate $ markLocated n - unless punFlag $ do - mark GHC.AnnEqual - unsetContext Intercalate $ markLocated e - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - - markAST _ (ls,rss) = do - mapM_ markLocated ls - mark GHC.AnnRarrow - mapM_ markLocated rss - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate GHC.CType where - markAST _ (GHC.CType src mh f) = do - -- markWithString GHC.AnnOpen src - markAnnOpen src "" - case mh of - Nothing -> return () - Just (GHC.Header srcH _h) -> - -- markWithString GHC.AnnHeader srcH - markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") - -- markWithString GHC.AnnVal (fst f) - markSourceText (fst f) (GHC.unpackFS $ snd f) - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -stringLiteralToString :: GHC.StringLiteral -> String -stringLiteralToString (GHC.StringLiteral st fs) = - case st of - GHC.NoSourceText -> GHC.unpackFS fs - GHC.SourceText src -> src - --- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint.hs @@ -1,11 +1,8 @@ -{-# LANGUAGE LambdaCase #-} -- | @ghc-exactprint@ is a library to manage manipulating Haskell -- source files. There are four components. module Language.Haskell.GHC.ExactPrint ( -- * Relativising - relativiseApiAnns - , relativiseApiAnnsWithComments - , Anns + Anns , Comment , Annotation(..) , AnnKey(..) @@ -16,17 +13,12 @@ -- * Transformation , module Language.Haskell.GHC.ExactPrint.Transform - -- * Adding default annotations - , addAnnotationsForPretty - -- * Printing , exactPrint ) where -import Language.Haskell.GHC.ExactPrint.Delta -import Language.Haskell.GHC.ExactPrint.Pretty -import Language.Haskell.GHC.ExactPrint.Print +import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Parsers diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# 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.Annotate - ( - annotate - , AnnotationF(..) - , Annotated - , Annotate(..) - , withSortKeyContextsHelper - - ) 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 deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs +++ /dev/null @@ -1,387 +0,0 @@ -{-# 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 -{-# LANGUAGE ViewPatterns #-} - --- | 'annotate' is a function which given a GHC AST fragment, constructs --- a syntax tree which indicates which annotations belong to each specific --- part of the fragment. --- --- "Delta" and "Print" provide two interpreters for this structure. You --- should probably use those unless you know what you're doing! --- --- The functor 'AnnotationF' has a number of constructors which correspond --- to different sitations which annotations can arise. It is hoped that in --- future versions of GHC these can be simplified by making suitable --- modifications to the AST. - -module Language.Haskell.GHC.ExactPrint.AnnotateTypes - -- ( - -- AnnotationF(..) - -- , Annotated - -- , Annotate(..) - - -- ) - where - -#if __GLASGOW_HASKELL__ <= 710 -import Data.Ord ( comparing ) -import Data.List ( sortBy ) -#endif - -import Language.Haskell.GHC.ExactPrint.Types - -#if __GLASGOW_HASKELL__ >= 900 -import qualified GHC.Types.Basic as GHC -#elif __GLASGOW_HASKELL__ > 800 -import qualified BasicTypes as GHC -#endif -import qualified GHC as GHC -#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 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 -#if __GLASGOW_HASKELL__ >= 800 - MarkInstead :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next -#endif - 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 -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) - WithAST :: (Data a,Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => - a -> Annotated b -> next -> AnnotationF next -#else - WithAST :: Data a => GHC.Located a - -> Annotated b -> next -> AnnotationF next -#endif - CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next - WithSortKey :: [(AnnSpan, 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 -> [(AnnSpan, 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 -#if __GLASGOW_HASKELL__ >= 800 -makeFreeCon 'MarkInstead -#endif -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. -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) - => a -> Annotated () -> Annotated () -#else -withAST :: Data a => GHC.Located a -> Annotated () -> Annotated () -#endif -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 - --- --------------------------------------------------------------------- - -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -withLocated :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) - => a - -> (GHC.SrcSpan -> a -> Annotated ()) - -> Annotated () -withLocated a@(GHC.dL->GHC.L l _) action = - withAST a (action l a) -#else -withLocated :: Data a - => GHC.Located a - -> (GHC.SrcSpan -> a -> Annotated ()) - -> Annotated () -withLocated a@(GHC.L l t) action = - withAST a (action l t) -#endif - --- --------------------------------------------------------------------- - - -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 -> [(AnnSpan, 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 :: [(AnnSpan, Annotated ())] -> Annotated () -applyListAnnotations ls = withSortKey ls - -applyListAnnotationsContexts :: ListContexts -> [(AnnSpan, 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 :: [(AnnSpan, 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 deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs +++ /dev/null @@ -1,921 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} - --- | This module converts 'GHC.ApiAnns' into 'Anns' by traversing a --- structure created by the "Annotate" module. --- --- == Structure of an Annotation --- --- As a rule of thumb, every located element in the GHC AST will have --- a corresponding entry in 'Anns'. An 'Annotation' contains 6 fields which --- can be modifed to change how the AST is printed. --- --- == Layout Calculation --- --- 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: --- --- @ --- 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 --- 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 --- block. --- --- @ --- foo = do --- baz --- bar --- @ --- --- A useful way to think of these rules is that the 'DeltaPos' is relative --- to the further left an expression could have been placed. In the --- previous example, we could have placed @baz@ anywhere on the line as its --- position determines where the other statements must be. @bar@ could have --- not been placed any further left without resulting in a syntax error --- which is why the relative column is 0. --- --- === annTrueEntryDelta --- A very useful function is 'annTrueEntryDelta' which calculates the --- offset from the last syntactic element (ignoring comments). This is --- different to 'annEntryDelta' which does not ignore comments. --- --- --- -module Language.Haskell.GHC.ExactPrint.Delta - ( relativiseApiAnns - , relativiseApiAnnsWithComments - , relativiseApiAnnsWithOptions - - -- * Configuration - , DeltaOptions(drRigidity) - , deltaOptions - , normalLayout - ) where - --- import Control.Exception -import Control.Monad.RWS -import Control.Monad.Trans.Free - -import Data.Data (Data) -import Data.List (sort, nub, partition, sortBy, sortOn) - -import Data.Ord - -import Language.Haskell.GHC.ExactPrint.Utils -#if __GLASGOW_HASKELL__ <= 710 -import Language.Haskell.GHC.ExactPrint.Lookup -#endif -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Annotate - -import qualified GHC -#if __GLASGOW_HASKELL__ >= 900 --- import qualified GHC.Parser.Annotation as GHC --- import qualified GHC.Types.SrcLoc as GHC -#endif - -import qualified Data.Map as Map -import qualified Data.Set as Set - --- import Debug.Trace - -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} - --- --------------------------------------------------------------------- --- | Transform concrete annotations into relative annotations which are --- more useful when transforming an AST. -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -relativiseApiAnns :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => ast -#else -relativiseApiAnns :: Annotate ast - => GHC.Located ast -#endif - -> GHC.ApiAnns - -> Anns -relativiseApiAnns = relativiseApiAnnsWithComments [] - --- | Exactly the same as 'relativiseApiAnns' but with the possibilty to --- inject comments. This is typically used if the source has been preprocessed --- by e.g. CPP, and the parts stripped out of the original source are re-added --- as comments so they are not lost for round tripping. -relativiseApiAnnsWithComments :: -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) - (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => [Comment] - -> ast -#else - Annotate ast - => [Comment] - -> GHC.Located ast -#endif - -> GHC.ApiAnns - -> Anns -relativiseApiAnnsWithComments = - relativiseApiAnnsWithOptions normalLayout - -relativiseApiAnnsWithOptions :: -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) - (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) - => DeltaOptions - -> [Comment] - -> ast -#else - Annotate ast - => DeltaOptions - -> [Comment] - -> GHC.Located ast -#endif - -> GHC.ApiAnns - -> Anns -relativiseApiAnnsWithOptions opts cs modu ghcAnns - = runDeltaWithComments - opts cs (annotate modu) ghcAnns - (ss2pos $ GHC.getLoc modu) - --- --------------------------------------------------------------------- --- --- | Type used in the Delta Monad. -type Delta a = RWS DeltaOptions DeltaWriter DeltaState a - -runDeltaWithComments :: DeltaOptions -> [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns -runDeltaWithComments opts cs action ga priorEnd = - mkAnns . snd - . (\next -> execRWS next opts (defaultDeltaState cs priorEnd ga)) - . deltaInterpret $ action - where - mkAnns :: DeltaWriter -> Anns - mkAnns = f . dwAnns - f :: Monoid a => Endo a -> a - f = ($ mempty) . appEndo - --- --------------------------------------------------------------------- - --- TODO: rename this, it is the R part of the RWS -data DeltaOptions = DeltaOptions - { - -- | Current `SrcSpan, part of current AnnKey` - curSrcSpan :: !GHC.SrcSpan - - -- | Constuctor of current AST element, part of current AnnKey - , annConName :: !AnnConName - - -- | Whether to use rigid or normal layout rules - , drRigidity :: !Rigidity - - -- | Current higher level context. e.g. whether a Match is part of a - -- LambdaExpr or a FunBind - , drContext :: !AstContextSet - } - -data DeltaWriter = DeltaWriter - { -- | Final list of annotations, and sort keys - dwAnns :: Endo (Map.Map AnnKey Annotation) - - -- | Used locally to pass Keywords, delta pairs relevant to a specific - -- subtree to the parent. - , annKds :: ![(KeywordId, DeltaPos)] - , sortKeys :: !(Maybe [AnnSpan]) - , dwCapturedSpan :: !(First AnnKey) - } - -data DeltaState = DeltaState - { -- | Position reached when processing the last element - priorEndPosition :: !Pos - - -- | Ordered list of comments still to be allocated - , apComments :: ![Comment] - - -- | The original GHC Delta Annotations - , apAnns :: !GHC.ApiAnns - - , apMarkLayout :: Bool - , apLayoutStart :: LayoutStartCol - - } - --- --------------------------------------------------------------------- - -deltaOptions :: Rigidity -> DeltaOptions -deltaOptions ridigity = - DeltaOptions - { curSrcSpan = GHC.noSrcSpan - , annConName = annGetConstr () - , drRigidity = ridigity - , drContext = defaultACS - } - -normalLayout :: DeltaOptions -normalLayout = deltaOptions NormalLayout - -defaultDeltaState :: [Comment] -> Pos -> GHC.ApiAnns -> DeltaState -defaultDeltaState injectedComments priorEnd ga = - DeltaState - { priorEndPosition = priorEnd - , apComments = cs ++ injectedComments - , apAnns = ga - , apLayoutStart = 1 - , apMarkLayout = False - } - where - cs :: [Comment] - cs = extractComments ga - - --- Writer helpers - -tellFinalAnn :: (AnnKey, Annotation) -> Delta () -tellFinalAnn (k, v) = - -- tell (mempty { dwAnns = Endo (Map.insertWith (<>) k v) }) - tell (mempty { dwAnns = Endo (Map.insert k v) }) - -tellSortKey :: [AnnSpan] -> Delta () -tellSortKey xs = tell (mempty { sortKeys = Just xs } ) - -tellCapturedSpan :: AnnKey -> Delta () -tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key }) - -tellKd :: (KeywordId, DeltaPos) -> Delta () -tellKd kd = tell (mempty { annKds = [kd] }) - -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup DeltaWriter where - (<>) = mappend -#endif - -instance Monoid DeltaWriter where - mempty = DeltaWriter mempty mempty mempty mempty - (DeltaWriter a b e g) `mappend` (DeltaWriter c d f h) - = DeltaWriter (a <> c) (b <> d) (e <> f) (g <> h) - ------------------------------------ --- Free Monad Interpretation code - -deltaInterpret :: Annotated a -> Delta a -deltaInterpret = iterTM go - where - go :: AnnotationF (Delta a) -> Delta a - go (MarkEOF next) = addEofAnnotation >> next - go (MarkPrim kwid _ next) = addDeltaAnnotation kwid >> next - go (MarkPPOptional kwid _ next) = addDeltaAnnotation kwid >> next -#if __GLASGOW_HASKELL__ >= 800 - go (MarkInstead akwid kwid next) = addDeltaAnnotationInstead akwid kwid >> next -#endif - go (MarkOutside akwid kwid next) = addDeltaAnnotationsOutside akwid kwid >> next - go (MarkInside akwid next) = addDeltaAnnotationsInside akwid >> next - 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 (WithAST lss prog next) = withAST lss (deltaInterpret prog) >> next - go (CountAnns kwid next) = countAnnsDelta kwid >>= next - go (SetLayoutFlag r action next) = do - rigidity <- asks drRigidity - (if r <= rigidity then setLayoutFlag else id) (deltaInterpret action) - next - go (MarkAnnBeforeAnn ann1 ann2 next) = deltaMarkAnnBeforeAnn ann1 ann2 >> next - go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt (rs ss) akwid >> next - go (StoreOriginalSrcSpan _ key next) = storeOriginalSrcSpanDelta key >>= next - go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next -#if __GLASGOW_HASKELL__ <= 710 - go (StoreString s ss next) = storeString s ss >> next -#endif - go (AnnotationsToComments kws next) = annotationsToCommentsDelta kws >> next -#if __GLASGOW_HASKELL__ <= 710 - go (AnnotationsToCommentsBF _ kws next) = annotationsToCommentsDelta kws >> next - go (FinalizeBF _ next) = next -#endif - go (WithSortKey kws next) = withSortKey kws >> next - go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next - - go (SetContextLevel ctxt lvl action next) = setContextDelta ctxt lvl (deltaInterpret action) >> next - go (UnsetContext _ctxt action next) = deltaInterpret action >> next - go (IfInContext ctxt ifAction elseAction next) = ifInContextDelta ctxt ifAction elseAction >> next - go (TellContext _ next) = next - -withSortKey :: [(AnnSpan, Annotated b)] -> Delta () -withSortKey kws = - let order = sortBy (comparing fst) kws - in do - tellSortKey (map fst order) - mapM_ (deltaInterpret . snd) order - - -withSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Delta () -withSortKeyContexts ctxts kws = do - tellSortKey (map fst order) - withSortKeyContextsHelper deltaInterpret ctxts order - where - order = sortBy (comparing fst) kws - - -setLayoutFlag :: Delta () -> Delta () -setLayoutFlag action = do - oldLay <- gets apLayoutStart - modify (\s -> s { apMarkLayout = True } ) - let reset = do - modify (\s -> s { apMarkLayout = False - , apLayoutStart = oldLay }) - action <* reset - --- --------------------------------------------------------------------- - -setContextDelta :: Set.Set AstContext -> Int -> Delta () -> Delta () -setContextDelta ctxt lvl = - local (\s -> s { drContext = setAcsWithLevel ctxt lvl (drContext s) } ) - -ifInContextDelta :: Set.Set AstContext -> Annotated () -> Annotated () -> Delta () -ifInContextDelta ctxt ifAction elseAction = do - cur <- asks drContext - let inContext = inAcs ctxt cur - if inContext - then deltaInterpret ifAction - else deltaInterpret elseAction - --- --------------------------------------------------------------------- - -storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey -storeOriginalSrcSpanDelta key = do - tellCapturedSpan key - return key - -#if __GLASGOW_HASKELL__ <= 710 -storeString :: String -> GHC.SrcSpan -> Delta () -storeString s ss = addAnnotationWorker (AnnString s) ss -#endif - --- --------------------------------------------------------------------- - --- |In order to interleave annotations into the stream, we turn them into --- comments. -annotationsToCommentsDelta :: [GHC.AnnKeywordId] -> Delta () -annotationsToCommentsDelta kws = do - ss <- getSrcSpan - cs <- gets apComments - let - doOne :: GHC.AnnKeywordId -> Delta [Comment] - doOne kw = do - (spans,_) <- getAndRemoveAnnotationDelta ss kw - return $ map (mkKWComment kw . sr) spans - -- TODO:AZ make sure these are sorted/merged properly when the invariant for - -- allocateComments is re-established. - newComments <- mapM doOne kws - putUnallocatedComments (cs ++ concat newComments) - --- --------------------------------------------------------------------- - --- | This function exists to overcome a shortcoming in the GHC AST for 7.10.1 -getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta GHC.SrcSpan -getSrcSpanForKw _ kw = do - ga <- gets apAnns - ss <- getSrcSpan - case GHC.getAnnotation ga (rs ss) kw of - [] -> return GHC.noSrcSpan -#if __GLASGOW_HASKELL__ >= 900 - (sp:_) -> return (GHC.RealSrcSpan sp Nothing) -#else - (sp:_) -> return sp -#endif - --- --------------------------------------------------------------------- - -getSrcSpan :: Delta GHC.SrcSpan -getSrcSpan = asks curSrcSpan - -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -withSrcSpanDelta :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b -withSrcSpanDelta (GHC.dL->GHC.L l a) = -#else -withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b -withSrcSpanDelta (GHC.L l a) = -#endif - local (\s -> s { curSrcSpan = l - , annConName = annGetConstr a - , drContext = pushAcs (drContext s) - `debug` ("withSrcSpanDelta: (l,annConName,drContext)=" ++ showGhc (l,annGetConstr a, pushAcs (drContext s))) - }) - - -getUnallocatedComments :: Delta [Comment] -getUnallocatedComments = gets apComments - -putUnallocatedComments :: [Comment] -> Delta () -putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) - --- --------------------------------------------------------------------- - -adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos -adjustDeltaForOffsetM dp = do - colOffset <- gets apLayoutStart - return (adjustDeltaForOffset colOffset dp) - -adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos -adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp -- same line -adjustDeltaForOffset (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset) - --- --------------------------------------------------------------------- - -getPriorEnd :: Delta Pos -getPriorEnd = gets priorEndPosition - -setPriorEnd :: Pos -> Delta () -setPriorEnd pe = - modify (\s -> s { priorEndPosition = pe }) - -setPriorEndAST :: AnnSpan -> Delta () -setPriorEndAST pe = do - setLayoutStart (snd (ss2pos (sr pe))) - modify (\s -> s { priorEndPosition = ss2posEnd (sr pe) } ) - -setLayoutStart :: Int -> Delta () -setLayoutStart p = do - DeltaState{apMarkLayout} <- get - when apMarkLayout ( - modify (\s -> s { apMarkLayout = False - , apLayoutStart = LayoutStartCol p})) - - --- ------------------------------------- - -peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [AnnSpan] -peekAnnotationDelta an = do - ga <- gets apAnns - ss <- getSrcSpan -#if __GLASGOW_HASKELL__ <= 710 - return $ GHC.getAnnotation ga ss an -#else - let unicodeAnns = case unicodeEquivalent an of - [] -> [] - [kw] -> GHC.getAnnotation ga (rs ss) kw - (kw:_) -> GHC.getAnnotation ga (rs ss) kw -- Keep exhaustiveness checker happy - return $ unicodeAnns ++ GHC.getAnnotation ga (rs ss) an -#endif - -getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) -getAnnotationDelta an = do - ss <- getSrcSpan - getAndRemoveAnnotationDelta ss an - -getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) -getAndRemoveAnnotationDelta sp an = do - ga <- gets apAnns -#if __GLASGOW_HASKELL__ <= 710 - let (r,ga') = GHC.getAndRemoveAnnotation ga sp an - kw = an -#else - let (r,ga',kw) = case GHC.getAndRemoveAnnotation ga (rs sp) an of - ([],_) -> (ss,g,k) - where - k = GHC.unicodeAnn an - (ss,g) = GHC.getAndRemoveAnnotation ga (rs sp) k - (ss,g) -> (ss,g,an) -#endif - modify (\s -> s { apAnns = ga' }) - return (r,kw) - -getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) -getOneAnnotationDelta an = do - ss <- getSrcSpan - getAndRemoveOneAnnotationDelta ss an - -getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) -getAndRemoveOneAnnotationDelta sp an = do -#if __GLASGOW_HASKELL__ >= 900 - ann <- gets apAnns - let anns = GHC.apiAnnItems ann - let cs = GHC.apiAnnComments ann -- TODO:AZ: what about apiAnnRogueComments? -#else - (anns,cs) <- gets apAnns -#endif - -#if __GLASGOW_HASKELL__ <= 710 - let (r,ga',kw) = case Map.lookup (sp,an) anns of - Nothing -> ([],(anns,cs),an) - Just [] -> ([], (Map.delete (sp,an) anns,cs),an) - Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs),an) -#else - let getKw kw = - case Map.lookup (rs sp,kw) anns of - Nothing -> ([],(anns,cs),kw) - Just [] -> ([], (Map.delete (rs sp,kw) anns,cs),kw) - Just (s:ss) -> ([s],(Map.insert (rs sp,kw) ss anns,cs),kw) - - let (r,(a',c'),kw) = - case getKw an of - ([],_,_) -> getKw (GHC.unicodeAnn an) - v -> v -#if __GLASGOW_HASKELL__ >= 900 - let ga' = ann { GHC.apiAnnItems = a', GHC.apiAnnComments = c' } -#else - let ga' = (a',c') -#endif -#endif - modify (\s -> s { apAnns = ga' }) - return (r,kw) - --- --------------------------------------------------------------------- - --- |Add some annotation to the currently active SrcSpan -addAnnotationsDelta :: Annotation -> Delta () -addAnnotationsDelta ann = do - l <- ask - tellFinalAnn (getAnnKey l,ann) - -getAnnKey :: DeltaOptions -> AnnKey -getAnnKey DeltaOptions {curSrcSpan, annConName} - = AnnKey (rs curSrcSpan) annConName - --- ------------------------------------- - -addAnnDeltaPos :: KeywordId -> DeltaPos -> Delta () -addAnnDeltaPos kw dp = tellKd (kw, dp) - --- ------------------------------------- - --- | Enter a new AST element. Maintain SrcSpan stack -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) - => a - -> Delta b -> Delta b -withAST lss@(GHC.dL->GHC.L ss _) action = do -#else -withAST :: Data a - => GHC.Located a - -> Delta b -> Delta b -withAST lss@(GHC.L ss _) action = do -#endif - -- Calculate offset required to get to the start of the SrcSPan - off <- gets apLayoutStart - (resetAnns . withSrcSpanDelta lss) (do - - let maskWriter s = s { annKds = [] - , sortKeys = Nothing - , dwCapturedSpan = mempty } - - -- make sure all kds are relative to the start of the SrcSpan - let spanStart = ss2pos ss - - cs <- do - priorEndBeforeComments <- getPriorEnd - if GHC.isGoodSrcSpan ss && priorEndBeforeComments < ss2pos ss - then - commentAllocation (priorComment spanStart) return - else - return [] - priorEndAfterComments <- getPriorEnd - let edp = adjustDeltaForOffset - -- Use the propagated offset if one is set - -- Note that we need to use the new offset if it has - -- changed. - off (ss2delta priorEndAfterComments ss) - -- Preparation complete, perform the action - when (GHC.isGoodSrcSpan ss && priorEndAfterComments < ss2pos ss) (do - modify (\s -> s { priorEndPosition = ss2pos ss } )) - (res, w) <- censor maskWriter (listen action) - - let kds = annKds w - an = Ann - { annEntryDelta = edp - , annPriorComments = cs - , annFollowingComments = [] -- only used in Transform and Print - , annsDP = kds - , annSortKey = sortKeys w - , annCapturedSpan = getFirst $ dwCapturedSpan w } - - addAnnotationsDelta an - `debug` ("leaveAST:(annkey,an)=" ++ show (mkAnnKey lss,an)) - return res) - -resetAnns :: Delta a -> Delta a -resetAnns action = do - ans <- gets apAnns - action <* modify (\s -> s { apAnns = ans }) - - --- --------------------------------------------------------------------- --- |Split the ordered list of comments into ones that occur prior to --- the give SrcSpan and the rest -priorComment :: Pos -> Comment -> Bool -priorComment start c = (ss2pos . sr . commentIdentifier $ c) < start - --- TODO:AZ: We scan the entire comment list here. It may be better to impose an --- invariant that the comments are sorted, and consume them as the pos --- advances. It then becomes a process of using `takeWhile p` rather than a full --- partition. -allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment]) -allocateComments = partition - --- --------------------------------------------------------------------- - -addAnnotationWorker :: KeywordId -> AnnSpan -> Delta () -addAnnotationWorker ann pa = - -- Zero-width source spans are injected by the GHC Lexer when it puts virtual - -- '{', ';' and '}' tokens in for layout - unless (isPointSrcSpan pa) $ - do - pe <- getPriorEnd - ss <- getSrcSpan - let p = ss2delta pe (sr pa) - case (ann,isGoodDelta p) of - (G GHC.AnnComma,False) -> return () - (G GHC.AnnSemi, False) -> return () - (G GHC.AnnOpen, False) -> return () - (G GHC.AnnClose,False) -> return () - _ -> do - p' <- adjustDeltaForOffsetM p - commentAllocation (priorComment (ss2pos (sr pa))) (mapM_ (uncurry addDeltaComment)) -#if __GLASGOW_HASKELL__ <= 710 - addAnnDeltaPos (checkUnicode ann pa) p' -#else - addAnnDeltaPos ann p' -#endif - setPriorEndAST pa - `debug` ("addAnnotationWorker:(ss,ss,pe,pa,p,p',ann)=" ++ show (showGhc ss,showGhc ss,pe,showGhc pa,p,p',ann)) - -#if __GLASGOW_HASKELL__ <= 710 -checkUnicode :: KeywordId -> GHC.SrcSpan -> KeywordId -checkUnicode gkw@(G kw) ss = - if kw `Set.member` unicodeSyntax - then - let s = keywordToString gkw in - if length s /= spanLength ss - then AnnUnicode kw - else gkw - else - gkw - where - unicodeSyntax = Set.fromList - [ GHC.AnnDcolon - , GHC.AnnDarrow - , GHC.AnnForall - , GHC.AnnRarrow - , GHC.AnnLarrow - , GHC.Annlarrowtail - , GHC.Annrarrowtail - , GHC.AnnLarrowtail - , GHC.AnnRarrowtail] -checkUnicode kwid _ = kwid -#else - -unicodeEquivalent :: GHC.AnnKeywordId -> [GHC.AnnKeywordId] -unicodeEquivalent kw = - case Map.lookup kw unicodeSyntax of - Nothing -> [] - Just kwu -> [kwu] - where - unicodeSyntax = Map.fromList - [ (GHC.AnnDcolon, GHC.AnnDcolonU) - , (GHC.AnnDarrow, GHC.AnnDarrowU) - , (GHC.AnnForall, GHC.AnnForallU) - , (GHC.AnnRarrow, GHC.AnnRarrowU) - , (GHC.AnnLarrow, GHC.AnnLarrowU) - , (GHC.Annlarrowtail, GHC.AnnlarrowtailU) - , (GHC.Annrarrowtail, GHC.AnnrarrowtailU) - , (GHC.AnnLarrowtail, GHC.AnnLarrowtailU) - , (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 - - --- --------------------------------------------------------------------- - -commentAllocation :: (Comment -> Bool) - -> ([(Comment, DeltaPos)] -> Delta a) - -> Delta a -commentAllocation p k = do - cs <- getUnallocatedComments - let (allocated,cs') = allocateComments p cs - putUnallocatedComments cs' - k =<< mapM makeDeltaComment (sortOn (unpack . commentIdentifier) allocated) - where - -- unpack a RealSrcSpan into ((start line, start col), (end line, end col)). - -- The file name is ignored. -#if __GLASGOW_HASKELL__ >= 900 - unpack :: GHC.RealSrcSpan -> Maybe ((Int, Int), (Int, Int)) - unpack x = -#else - unpack :: GHC.SrcSpan -> Maybe ((Int, Int), (Int, Int)) - unpack (GHC.RealSrcSpan x) = -#endif - Just ( (GHC.srcSpanStartLine x, GHC.srcSpanStartCol x) - , (GHC.srcSpanEndLine x, GHC.srcSpanEndCol x) ) - unpack _ = Nothing - -makeDeltaComment :: Comment -> Delta (Comment, DeltaPos) -makeDeltaComment c = do - let pa = commentIdentifier c - pe <- getPriorEnd - let p = ss2delta pe (sr pa) - p' <- adjustDeltaForOffsetM p - setPriorEnd (ss2posEnd (sr pa)) - return (c, p') - -addDeltaComment :: Comment -> DeltaPos -> Delta () -addDeltaComment d p = do - addAnnDeltaPos (AnnComment d) p - --- --------------------------------------------------------------------- - --- |If the first annotation has a smaller SrcSpan than the second, then mark it. -deltaMarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> Delta () -deltaMarkAnnBeforeAnn annBefore annAfter = do - ss <- getSrcSpan - mb <- peekAnnotationDelta annBefore - ma <- peekAnnotationDelta annAfter - let - before = sort $ filter (\s -> GHC.isSubspanOf (sr s) ss) mb - after = sort $ filter (\s -> GHC.isSubspanOf (sr s) ss) ma - case (before,after) of - (b:_, a:_) -> when (b < a) $ addDeltaAnnotation annBefore - _ -> return () - --- --------------------------------------------------------------------- - --- | Look up and add a Delta annotation at the current position, and --- advance the position to the end of the annotation -addDeltaAnnotation :: GHC.AnnKeywordId -> Delta () -addDeltaAnnotation ann' = do - ss <- getSrcSpan - (ma,ann) <- getOneAnnotationDelta ann' - case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier - [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann)) - [pa] -> addAnnotationWorker (G ann) pa - (pa:_) -> addAnnotationWorker (G ann) pa `warn` ("addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma)) - --- | Look up and add a Delta annotation at the current position, and --- advance the position to the end of the annotation -addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> Delta () -addDeltaAnnotationLs ann off = do - ss <- getSrcSpan - ma <- peekAnnotationDelta ann - let ma' = filter (\s -> GHC.isSubspanOf (sr s) ss) ma - case drop off ma' of - [] -> return () - `debug` ("addDeltaAnnotationLs:missed:(off,ann,ma)=" ++ showGhc (off,ss,ann)) - (pa:_) -> addAnnotationWorker (G ann) pa - --- | Look up and add possibly multiple Delta annotation at the current --- position, and advance the position to the end of the annotations -addDeltaAnnotations :: GHC.AnnKeywordId -> Delta () -addDeltaAnnotations ann = do - (ma,kw) <- getAnnotationDelta ann - let do_one ap' = addAnnotationWorker (G kw) ap' - `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) - mapM_ do_one (sort ma) - --- | Look up and add possibly multiple Delta annotations enclosed by --- the current SrcSpan at the current position, and advance the --- position to the end of the annotations -addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta () -addDeltaAnnotationsInside ann = do - ss <- getSrcSpan - ma <- peekAnnotationDelta ann - let do_one ap' = addAnnotationWorker (G ann) ap' - -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) - let filtered = sort $ filter (\s -> GHC.isSubspanOf (sr s) ss) ma - mapM_ do_one filtered - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 800 -addDeltaAnnotationInstead :: GHC.AnnKeywordId -> KeywordId -> Delta () -addDeltaAnnotationInstead ann' kw = do - ss <- getSrcSpan - (ma,ann) <- getOneAnnotationDelta ann' - case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier - [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann)) - [pa] -> addAnnotationWorker kw pa - (pa:_) -> addAnnotationWorker kw pa `warn` ("addDeltaAnnotationInstead:(ss,ann,kw,ma)=" ++ showGhc (ss,ann,kw,ma)) -#endif --- --------------------------------------------------------------------- - --- | Look up and add possibly multiple Delta annotations not enclosed by --- the current SrcSpan at the current position, and advance the --- position to the end of the annotations --- The first argument (gann) is the one to look up in the GHC annotations, the --- second is the one to apply in the ghc-exactprint ones. These are different --- for GHC.AnnSemi mapping to AnnSemiSep, to ensure that it reflects the ';' --- outside the current span. -addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta () -addDeltaAnnotationsOutside gann ann = do - ss <- getSrcSpan - (ma,kw) <- getAndRemoveAnnotationDelta ss gann - let do_one ap' = if ann == AnnSemiSep - then addAnnotationWorker ann ap' - else addAnnotationWorker (G kw) ap' - mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf (sr s) ss)) ma) - --- | Add a Delta annotation at the current position, and advance the --- position to the end of the annotation -addDeltaAnnotationExt :: AnnSpan -> GHC.AnnKeywordId -> Delta () -addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s - -addEofAnnotation :: Delta () -#if __GLASGOW_HASKELL__ >= 900 -addEofAnnotation = do - pe <- getPriorEnd - ga <- gets apAnns - let Just pa = GHC.apiAnnEofPos ga - commentAllocation (const True) (mapM_ (uncurry addDeltaComment)) - let DP (r,c) = ss2delta pe (sr pa) - addAnnDeltaPos AnnEofPos (DP (r, c - 1)) - setPriorEndAST pa -#else -addEofAnnotation = do - pe <- getPriorEnd - (ma,_kw) <- withSrcSpanDelta (GHC.noLoc () :: GHC.GenLocated GHC.SrcSpan ()) - (getAnnotationDelta GHC.AnnEofPos) - case ma of - [] -> return () - (pa:pss) -> do - commentAllocation (const True) (mapM_ (uncurry addDeltaComment)) - let DP (r,c) = ss2delta pe pa - addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1)) - setPriorEndAST pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss) -#endif - --- --------------------------------------------------------------------- - -countAnnsDelta :: GHC.AnnKeywordId -> Delta Int -countAnnsDelta ann = do - ma <- peekAnnotationDelta ann - return (length ma) diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -0,0 +1,3884 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance + +module Language.Haskell.GHC.ExactPrint.ExactPrint + ( + ExactPrint(..) + , exactPrint + -- , exactPrintWithOptions + ) where + +import GHC +import GHC.Core.Coercion.Axiom (Role(..)) +import GHC.Data.Bag +import qualified GHC.Data.BooleanFormula as BF +import GHC.Data.FastString +import GHC.Types.Basic hiding (EP) +import GHC.Types.Fixity +import GHC.Types.ForeignCall +import GHC.Types.SourceText +import GHC.Types.Var +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Unit.Module.Warnings +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Control.Monad.Identity +import Control.Monad.RWS +import Data.Data ( Data ) +import Data.Foldable +import qualified Data.Set.Ordered as OSet +import Data.Typeable +import Data.List ( partition, sort, sortBy) +import Data.Maybe ( isJust ) + +import Data.Void + +import Language.Haskell.GHC.ExactPrint.Lookup +import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types + +-- import Debug.Trace + +-- --------------------------------------------------------------------- + +exactPrint :: ExactPrint ast => Located ast -> String +exactPrint ast = runIdentity (runEP stringOptions (markAnnotated ast)) + +type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a +type EPP a = EP String Identity a + +runEP :: PrintOptions Identity String + -> Annotated () -> Identity String +runEP epReader action = + fmap (output . snd) . + (\next -> execRWST next epReader defaultEPState) + . xx $ action + +xx :: Annotated () -> EP String Identity () +-- xx :: Annotated() -> RWST (PrintOptions m w) (EPWriter w) EPState m () +xx = id + +-- --------------------------------------------------------------------- + +defaultEPState :: EPState +defaultEPState = EPState + { epPos = (1,1) + , dLHS = 0 + , pMarkLayout = False + , pLHS = 0 + , dMarkLayout = False + , dPriorEndPosition = (1,1) + , uAnchorSpan = badRealSrcSpan + , uExtraDP = Nothing + , epComments = [] + } + + +-- --------------------------------------------------------------------- +-- The EP monad and basic combinators + +-- | The R part of RWS. The environment. Updated via 'local' as we +-- enter a new AST element, having a different anchor point. +data PrintOptions m a = PrintOptions + { + epAnn :: !Annotation + , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a + , epTokenPrint :: String -> m a + , epWhitespacePrint :: String -> m a + , epRigidity :: Rigidity + } + +-- | Helper to create a 'PrintOptions' +printOptions :: + (forall ast . Data ast => GHC.Located ast -> a -> m a) + -> (String -> m a) + -> (String -> m a) + -> Rigidity + -> PrintOptions m a +printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions + { + epAnn = annNone + , epAstPrint = astPrint + , epWhitespacePrint = wsPrint + , epTokenPrint = tokenPrint + , epRigidity = rigidity + } + +-- | Options which can be used to print as a normal String. +stringOptions :: PrintOptions Identity String +stringOptions = printOptions (\_ b -> return b) return return NormalLayout + +data EPWriter a = EPWriter + { output :: !a } + +instance Monoid w => Semigroup (EPWriter w) where + (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) + +instance Monoid w => Monoid (EPWriter w) where + mempty = EPWriter mempty + +data EPState = EPState + { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST + -- reference frame, from + -- Annotation + , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a + -- list + + -- Print phase + , epPos :: !Pos -- ^ Current output position + , pMarkLayout :: !Bool + , pLHS :: !LayoutStartCol + + -- Delta phase + , dPriorEndPosition :: !Pos -- ^ End of Position reached + -- when processing the + -- preceding element + , dMarkLayout :: !Bool + , dLHS :: !LayoutStartCol + + -- Shared + , epComments :: ![Comment] + } + +-- --------------------------------------------------------------------- + +-- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry +class HasEntry ast where + fromAnn :: ast -> Entry + +-- --------------------------------------------------------------------- + +-- type Annotated = FreeT AnnotationF Identity +type Annotated a = EP String Identity a + +-- --------------------------------------------------------------------- + +-- | Key entry point. Switches to an independent AST element with its +-- own annotation, calculating new offsets, etc +markAnnotated :: ExactPrint a => a -> Annotated () +markAnnotated a = enterAnn (getAnnotationEntry a) a + +-- | For HsModule, because we do not have a proper SrcSpan, we must +-- indicate to flush trailing comments when done. +data FlushComments = FlushComments + | NoFlushComments + deriving (Eq, Show) + +data Entry = Entry Anchor EpAnnComments FlushComments + | NoEntryVal + +instance HasEntry (SrcSpanAnn' (EpAnn an)) where + fromAnn (SrcSpanAnn EpAnnNotUsed ss) = Entry (spanAsAnchor ss) emptyComments NoFlushComments + fromAnn (SrcSpanAnn an _) = fromAnn an + +instance HasEntry (EpAnn a) where + fromAnn (EpAnn anchor _ cs) = Entry anchor cs NoFlushComments + fromAnn EpAnnNotUsed = NoEntryVal + +-- --------------------------------------------------------------------- + +fromAnn' :: (HasEntry a) => a -> Entry +fromAnn' an = case fromAnn an of + NoEntryVal -> NoEntryVal + Entry a c _ -> Entry a c FlushComments + +-- --------------------------------------------------------------------- + +astId :: (Typeable a) => a -> String +astId a = show (typeOf a) + +-- | "Enter" an annotation, by using the associated 'anchor' field as +-- the new reference point for calculating all DeltaPos positions. +-- +-- This is combination of the ghc=exactprint Delta.withAST and +-- Print.exactPC functions and effectively does the delta processing +-- immediately followed by the print processing. JIT ghc-exactprint. +enterAnn :: (ExactPrint a) => Entry -> a -> Annotated () +enterAnn NoEntryVal a = do + p <- getPosP + debugM $ "enterAnn:NO ANN:(p,a) =" ++ show (p, astId a) ++ " starting" + exact a + debugM $ "enterAnn:NO ANN:p =" ++ show (p, astId a) ++ " done" +enterAnn (Entry anchor' cs flush) a = do + p <- getPosP + debugM $ "enterAnn:(p,a) =" ++ show (p, astId a) ++ " starting" + -- debugM $ "enterAnn:(cs) =" ++ showGhc (cs) + let curAnchor = anchor anchor' -- As a base for the current AST element + debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) + addCommentsA (priorComments cs) + printComments curAnchor + -- ------------------------- + case anchor_op anchor' of + MovedAnchor dp -> do + debugM $ "enterAnn: MovedAnchor:" ++ show dp + -- Set the original anchor as prior end, so the rest of this AST + -- fragment has a reference + -- BUT: this means the entry DP can be calculated incorrectly too, + -- for immediately nested items. + setPriorEndNoLayoutD (ss2pos curAnchor) + _ -> do + return () + -- ------------------------- + setAnchorU curAnchor + -- ------------------------------------------------------------------- + -- The first part corresponds to the delta phase, so should only use + -- delta phase variables + -- ----------------------------------- + -- Calculate offset required to get to the start of the SrcSPan + off <- gets dLHS + let spanStart = ss2pos curAnchor + priorEndAfterComments <- getPriorEndD + let edp' = adjustDeltaForOffset 0 + -- Use the propagated offset if one is set + -- Note that we need to use the new offset if it has + -- changed. + off (ss2delta priorEndAfterComments curAnchor) + debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) + let edp'' = case anchor_op anchor' of + MovedAnchor dp -> dp + _ -> edp' + -- --------------------------------------------- + -- let edp = edp'' + med <- getExtraDP + setExtraDP Nothing + let edp = case med of + Nothing -> edp'' + Just (Anchor _ (MovedAnchor dp)) -> dp + -- Replace original with desired one. Allows all + -- list entry values to be DP (1,0) + Just (Anchor r _) -> dp + where + dp = adjustDeltaForOffset 0 + off (ss2delta priorEndAfterComments r) + when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp) + -- --------------------------------------------- + -- Preparation complete, perform the action + when (priorEndAfterComments < spanStart) (do + debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart + modify (\s -> s { dPriorEndPosition = spanStart } )) + + debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor) + debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) + + -- end of delta phase processing + -- ------------------------------------------------------------------- + -- start of print phase processing + + let mflush = when (flush == FlushComments) $ do + debugM $ "flushing comments in enterAnn" + flushComments (getFollowingComments cs) + -- flushComments [] + + let + st = annNone { annEntryDelta = edp } + withOffset st (advance edp >> exact a >> mflush) + + when (flush == NoFlushComments) $ do + when ((getFollowingComments cs) /= []) $ do + debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs) + mapM_ printOneComment (map tokComment $ getFollowingComments cs) + debugM $ "ending trailing comments" + +-- --------------------------------------------------------------------- + +addCommentsA :: [LEpaComment] -> EPP () +addCommentsA csNew = addComments (map tokComment csNew) + +addComments :: [Comment] -> EPP () +addComments csNew = do + debugM $ "addComments:" ++ show csNew + cs <- getUnallocatedComments + -- Make sure we merge duplicates while sorting, needed until + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20239 is resolved + let ocs = OSet.fromList cs + let ncs = OSet.fromList csNew + putUnallocatedComments (OSet.toAscList (ocs OSet.<>| ncs)) + + +-- --------------------------------------------------------------------- + +-- | Just before we print out the EOF comments, flush the remaining +-- ones in the state. +flushComments :: [LEpaComment] -> EPP () +flushComments trailing = do + addCommentsA trailing + cs <- getUnallocatedComments + -- Must compare without span filenames, for CPP injected comments with fake filename + let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) + debugM $ "flushing comments starting" + mapM_ printOneComment (sortBy cmp cs) + debugM $ "flushing comments done" + +-- --------------------------------------------------------------------- + +-- |In order to interleave annotations into the stream, we turn them into +-- comments. +annotationsToComments :: [AddEpAnn] -> [AnnKeywordId] -> EPP () +annotationsToComments ans kws = do + let + getSpans _ [] = [] + getSpans k1 (AddEpAnn k2 ss:as) + | k1 == k2 = ss : getSpans k1 as + | otherwise = getSpans k1 as + doOne :: AnnKeywordId -> EPP [Comment] + doOne kw = do + let sps =getSpans kw ans + return $ map (mkKWComment kw ) sps + -- TODO:AZ make sure these are sorted/merged properly when the invariant for + -- allocateComments is re-established. + newComments <- mapM doOne kws + addComments (concat newComments) + +annotationsToCommentsA :: EpAnn [AddEpAnn] -> [AnnKeywordId] -> EPP () +annotationsToCommentsA EpAnnNotUsed _ = return () +annotationsToCommentsA an kws = annotationsToComments (anns an) kws + +-- --------------------------------------------------------------------- + +-- Temporary function to simply reproduce the "normal" pretty printer output +withPpr :: (Outputable a) => a -> Annotated () +withPpr a = do + ss <- getAnchorU + debugM $ "withPpr: ss=" ++ show ss + printStringAtKw' ss (showPprUnsafe a) + +-- --------------------------------------------------------------------- +-- Modeled on Outputable + +-- | An AST fragment with an annotation must be able to return the +-- requirements for nesting another one, captured in an 'Entry', and +-- to be able to use the rest of the exactprint machinery to print the +-- element. In the analogy to Outputable, 'exact' plays the role of +-- 'ppr'. +class (Typeable a) => ExactPrint a where + getAnnotationEntry :: a -> Entry + exact :: a -> Annotated () + +-- --------------------------------------------------------------------- + +-- | Bare Located elements are simply stripped off without further +-- processing. +instance (ExactPrint a) => ExactPrint (Located a) where + getAnnotationEntry (L l _) = Entry (spanAsAnchor l) emptyComments NoFlushComments + exact (L _ a) = markAnnotated a + +instance (ExactPrint a) => ExactPrint (LocatedA a) where + getAnnotationEntry = entryFromLocatedA + exact (L la a) = do + debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) + markAnnotated a + markALocatedA (ann la) + +instance (ExactPrint a) => ExactPrint [a] where + getAnnotationEntry = const NoEntryVal + exact ls = mapM_ markAnnotated ls + +instance (ExactPrint a) => ExactPrint (Maybe a) where + getAnnotationEntry = const NoEntryVal + exact Nothing = return () + exact (Just a) = markAnnotated a + +-- --------------------------------------------------------------------- + +-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' +instance ExactPrint HsModule where + getAnnotationEntry hsmod = fromAnn' (hsmodAnn hsmod) + + exact hsmod@(HsModule EpAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod + exact (HsModule an _lo mmn mexports imports decls mdeprec mbDoc) = do + + markAnnotated mbDoc + + case mmn of + Nothing -> return () + Just (L ln mn) -> do + markEpAnn' an am_main AnnModule + markAnnotated (L ln mn) + + -- forM_ mdeprec markLocated + setLayoutTopLevelP $ markAnnotated mdeprec + + setLayoutTopLevelP $ markAnnotated mexports + + debugM $ "HsModule.AnnWhere coming" + setLayoutTopLevelP $ markEpAnn' an am_main AnnWhere + + markAnnList' False (am_decls $ anns an) $ do + markTopLevelList imports + markTopLevelList decls + +-- --------------------------------------------------------------------- + +-- TODO:AZ: do we *need* the following, or can we capture it in the AST? +-- | We can have a list with its own entry point defined. Create a +-- data structure to capture this, for defining an ExactPrint instance +data AnnotatedList a = AnnotatedList (Maybe Anchor) a + deriving (Eq,Show) + +instance (ExactPrint a) => ExactPrint (AnnotatedList a) where + getAnnotationEntry (AnnotatedList (Just anc) _) = Entry anc (EpaComments []) NoFlushComments + getAnnotationEntry (AnnotatedList Nothing _) = NoEntryVal + + exact (AnnotatedList an ls) = do + debugM $ "AnnotatedList:an=" ++ show an + markAnnotatedWithLayout ls + + +-- --------------------------------------------------------------------- +-- Start of utility functions +-- --------------------------------------------------------------------- + +printSourceText :: SourceText -> String -> EPP () +printSourceText NoSourceText txt = printStringAdvance txt +printSourceText (SourceText txt) _ = printStringAdvance txt + +-- --------------------------------------------------------------------- + +printStringAtRs :: RealSrcSpan -> String -> EPP () +printStringAtRs ss str = printStringAtKw' ss str + +printStringAtSs :: SrcSpan -> String -> EPP () +printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str + +-- --------------------------------------------------------------------- + +-- AZ:TODO get rid of this +printStringAtMkw :: Maybe EpaLocation -> String -> EPP () +printStringAtMkw (Just aa) s = printStringAtAA aa s +printStringAtMkw Nothing s = printStringAtLsDelta (SameLine 1) s + + +printStringAtAA :: EpaLocation -> String -> EPP () +printStringAtAA (EpaSpan r) s = printStringAtKw' r s +printStringAtAA (EpaDelta d) s = do + pe <- getPriorEndD + p1 <- getPosP + printStringAtLsDelta d s + p2 <- getPosP + debugM $ "printStringAtAA:(pe,p1,p2)=" ++ show (pe,p1,p2) + setPriorEndASTPD True (p1,p2) + +-- Based on Delta.addAnnotationWorker +printStringAtKw' :: RealSrcSpan -> String -> EPP () +printStringAtKw' pa str = do + printComments pa + pe <- getPriorEndD + debugM $ "printStringAtKw':pe=" ++ show pe + let p = ss2delta pe pa + p' <- adjustDeltaForOffsetM p + printStringAtLsDelta p' str + setPriorEndASTD True pa + +-- --------------------------------------------------------------------- + +markExternalSourceText :: SrcSpan -> SourceText -> String -> EPP () +markExternalSourceText l NoSourceText txt = printStringAtKw' (realSrcSpan l) txt +markExternalSourceText l (SourceText txt) _ = printStringAtKw' (realSrcSpan l) txt + +-- --------------------------------------------------------------------- + +markAddEpAnn :: AddEpAnn -> EPP () +markAddEpAnn a@(AddEpAnn kw _) = mark [a] kw + +markLocatedMAA :: EpAnn a -> (a -> Maybe AddEpAnn) -> EPP () +markLocatedMAA EpAnnNotUsed _ = return () +markLocatedMAA (EpAnn _ a _) f = + case f a of + Nothing -> return () + Just aa -> markAddEpAnn aa + +markLocatedAA :: EpAnn a -> (a -> AddEpAnn) -> EPP () +markLocatedAA EpAnnNotUsed _ = return () +markLocatedAA (EpAnn _ a _) f = markKw (f a) + +markLocatedAAL :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> EPP () +markLocatedAAL EpAnnNotUsed _ _ = return () +markLocatedAAL (EpAnn _ a _) f kw = go (f a) + where + go [] = return () + go (aa@(AddEpAnn kw' _):as) + | kw' == kw = mark [aa] kw + | otherwise = go as + +markLocatedAALS :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> Maybe String -> EPP () +markLocatedAALS an f kw Nothing = markLocatedAAL an f kw +markLocatedAALS EpAnnNotUsed _ _ _ = return () +markLocatedAALS (EpAnn _ a _) f kw (Just str) = go (f a) + where + go [] = return () + go (AddEpAnn kw' r:as) + | kw' == kw = printStringAtAA r str + | otherwise = go as + +-- --------------------------------------------------------------------- + +markArrow :: EpAnn TrailingAnn -> HsArrow GhcPs -> EPP () +markArrow an arr = do + case arr of + HsUnrestrictedArrow _u -> + return () + HsLinearArrow _u ma -> do + mapM_ markAddEpAnn ma + HsExplicitMult _u ma t -> do + mapM_ markAddEpAnn ma + markAnnotated t + + case an of + EpAnnNotUsed -> pure () + _ -> markKwT (anns an) + +-- --------------------------------------------------------------------- + +markAnnCloseP :: EpAnn AnnPragma -> EPP () +markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}") + +markAnnOpenP :: EpAnn AnnPragma -> SourceText -> String -> EPP () +markAnnOpenP an NoSourceText txt = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) +markAnnOpenP an (SourceText txt) _ = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) + +markAnnOpen :: EpAnn [AddEpAnn] -> SourceText -> String -> EPP () +markAnnOpen an NoSourceText txt = markLocatedAALS an id AnnOpen (Just txt) +markAnnOpen an (SourceText txt) _ = markLocatedAALS an id AnnOpen (Just txt) + +markAnnOpen' :: Maybe EpaLocation -> SourceText -> String -> EPP () +markAnnOpen' ms NoSourceText txt = printStringAtMkw ms txt +markAnnOpen' ms (SourceText txt) _ = printStringAtMkw ms txt + +-- --------------------------------------------------------------------- + +markOpeningParen, markClosingParen :: EpAnn AnnParen -> EPP () +markOpeningParen an = markParen an fst +markClosingParen an = markParen an snd + +markParen :: EpAnn AnnParen -> (forall a. (a,a) -> a) -> EPP () +markParen EpAnnNotUsed _ = return () +markParen (EpAnn _ (AnnParen pt o c) _) f = markKwA (f $ kw pt) (f (o, c)) + where + kw AnnParens = (AnnOpenP, AnnCloseP) + kw AnnParensHash = (AnnOpenPH, AnnClosePH) + kw AnnParensSquare = (AnnOpenS, AnnCloseS) + + +markAnnKw :: EpAnn a -> (a -> EpaLocation) -> AnnKeywordId -> EPP () +markAnnKw EpAnnNotUsed _ _ = return () +markAnnKw (EpAnn _ a _) f kw = markKwA kw (f a) + +markAnnKwAll :: EpAnn a -> (a -> [EpaLocation]) -> AnnKeywordId -> EPP () +markAnnKwAll EpAnnNotUsed _ _ = return () +markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) + +markAnnKwM :: EpAnn a -> (a -> Maybe EpaLocation) -> AnnKeywordId -> EPP () +markAnnKwM EpAnnNotUsed _ _ = return () +markAnnKwM (EpAnn _ a _) f kw = go (f a) + where + go Nothing = return () + go (Just s) = markKwA kw s + +markALocatedA :: EpAnn AnnListItem -> EPP () +markALocatedA EpAnnNotUsed = return () +markALocatedA (EpAnn _ a _) = markTrailing (lann_trailing a) + +markEpAnn :: EpAnn [AddEpAnn] -> AnnKeywordId -> EPP () +markEpAnn EpAnnNotUsed _ = return () +markEpAnn (EpAnn _ a _) kw = mark a kw + +markEpAnn' :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () +markEpAnn' EpAnnNotUsed _ _ = return () +markEpAnn' (EpAnn _ a _) f kw = mark (f a) kw + +markEpAnnAll :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () +markEpAnnAll EpAnnNotUsed _ _ = return () +markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sort anns) + where + anns = filter (\(AddEpAnn ka _) -> ka == kw) (f a) + +markAnnAll :: [AddEpAnn] -> AnnKeywordId -> EPP () +markAnnAll a kw = mapM_ markKw (sort anns) + where + anns = filter (\(AddEpAnn ka _) -> ka == kw) a + +mark :: [AddEpAnn] -> AnnKeywordId -> EPP () +mark anns kw = do + case find (\(AddEpAnn k _) -> k == kw) anns of + Just aa -> markKw aa + Nothing -> case find (\(AddEpAnn k _) -> k == (unicodeAnn kw)) anns of + Just aau -> markKw aau + Nothing -> return () + +markKwT :: TrailingAnn -> EPP () +markKwT (AddSemiAnn ss) = markKwA AnnSemi ss +markKwT (AddCommaAnn ss) = markKwA AnnComma ss +markKwT (AddVbarAnn ss) = markKwA AnnVbar ss +markKwT (AddRarrowAnn ss) = markKwA AnnRarrow ss +markKwT (AddRarrowAnnU ss) = markKwA AnnRarrowU ss +markKwT (AddLollyAnnU ss) = markKwA AnnLollyU ss + +markKw :: AddEpAnn -> EPP () +markKw (AddEpAnn kw ss) = markKwA kw ss + +-- | This should be the main driver of the process, managing comments +markKwA :: AnnKeywordId -> EpaLocation -> EPP () +markKwA kw aa = printStringAtAA aa (keywordToString (G kw)) + +-- --------------------------------------------------------------------- + +markAnnList :: Bool -> EpAnn AnnList -> EPP () -> EPP () +markAnnList _ EpAnnNotUsed action = action +markAnnList reallyTrail (EpAnn _ ann _) action = markAnnList' reallyTrail ann action + +markAnnList' :: Bool -> AnnList -> EPP () -> EPP () +markAnnList' reallyTrail ann action = do + p <- getPosP + debugM $ "markAnnList : " ++ showPprUnsafe (p, ann) + mapM_ markAddEpAnn (al_open ann) + unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule. + markAnnAll (sort $ al_rest ann) AnnSemi + action + mapM_ markAddEpAnn (al_close ann) + debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann) + when reallyTrail $ markTrailing (al_trailing ann) -- normal case + +-- --------------------------------------------------------------------- + +printComments :: RealSrcSpan -> EPP () +printComments ss = do + cs <- commentAllocation ss + debugM $ "printComments: (ss): " ++ showPprUnsafe (rs2range ss) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + mapM_ printOneComment cs + +-- --------------------------------------------------------------------- + +printOneComment :: Comment -> EPP () +printOneComment c@(Comment _str loc _mo) = do + debugM $ "printOneComment:c=" ++ showGhc c + dp <-case anchor_op loc of + MovedAnchor dp -> return dp + _ -> do + pe <- getPriorEndD + let dp = ss2delta pe (anchor loc) + debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc) + return dp + dp'' <- adjustDeltaForOffsetM dp + mep <- getExtraDP + dp' <- case mep of + Just (Anchor _ (MovedAnchor edp)) -> do + debugM $ "printOneComment:edp=" ++ show edp + return edp + _ -> return dp'' + LayoutStartCol dOff <- gets dLHS + debugM $ "printOneComment:(dp,dp',dp'',dOff)=" ++ showGhc (dp,dp',dp'',dOff) + setPriorEndD (ss2posEnd (anchor loc)) + printQueuedComment (anchor loc) c dp' + +-- --------------------------------------------------------------------- + +commentAllocation :: RealSrcSpan -> EPP [Comment] +commentAllocation ss = do + cs <- getUnallocatedComments + -- Note: The CPP comment injection may change the file name in the + -- RealSrcSpan, which affects comparison, as the Ord instance for + -- RealSrcSpan compares the file first. So we sort via ss2pos + -- TODO: this is inefficient, use Pos all the way through + let (earlier,later) = partition (\(Comment _str loc _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs + putUnallocatedComments later + -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) + return earlier + +-- --------------------------------------------------------------------- + + +markAnnotatedWithLayout :: ExactPrint ast => ast -> EPP () +markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a + +-- --------------------------------------------------------------------- + +markTopLevelList :: ExactPrint ast => [ast] -> EPP () +markTopLevelList ls = mapM_ (\a -> setLayoutTopLevelP $ markAnnotated a) ls + +-- --------------------------------------------------------------------- + +instance ExactPrint ModuleName where + getAnnotationEntry _ = NoEntryVal + exact n = do + debugM $ "ModuleName: " ++ showPprUnsafe n + withPpr n + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP WarningTxt) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn an _) (WarningTxt (L _ src) ws)) = do + markAnnOpenP an src "{-# WARNING" + markLocatedAAL an apr_rest AnnOpenS + markAnnotated ws + markLocatedAAL an apr_rest AnnCloseS + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (DeprecatedTxt (L _ src) ws)) = do + markAnnOpenP an src "{-# DEPRECATED" + markLocatedAAL an apr_rest AnnOpenS + markAnnotated ws + markLocatedAAL an apr_rest AnnCloseS + markAnnCloseP an + +-- --------------------------------------------------------------------- + +instance ExactPrint (ImportDecl GhcPs) where + getAnnotationEntry idecl = fromAnn (ideclExt idecl) + exact x@(ImportDecl EpAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x + exact (ImportDecl ann@(EpAnn _ an _) msrc (L lm modname) mpkg _src safeflag qualFlag _impl mAs hiding) = do + + markAnnKw ann importDeclAnnImport AnnImport + + -- "{-# SOURCE" and "#-}" + case msrc of + SourceText _txt -> do + debugM $ "ImportDecl sourcetext" + let mo = fmap fst $ importDeclAnnPragma an + let mc = fmap snd $ importDeclAnnPragma an + markAnnOpen' mo msrc "{-# SOURCE" + printStringAtMkw mc "#-}" + NoSourceText -> return () + when safeflag (markAnnKwM ann importDeclAnnSafe AnnSafe) + case qualFlag of + QualifiedPre -- 'qualified' appears in prepositive position. + -> printStringAtMkw (importDeclAnnQualified an) "qualified" + _ -> return () + case mpkg of + Just (StringLiteral src v _) -> + printStringAtMkw (importDeclAnnPackage an) (sourceTextToString src (show v)) + _ -> return () + + printStringAtKw' (realSrcSpan lm) (moduleNameString modname) + + case qualFlag of + QualifiedPost -- 'qualified' appears in postpositive position. + -> printStringAtMkw (importDeclAnnQualified an) "qualified" + _ -> return () + + case mAs of + Nothing -> return () + Just (L l mn) -> do + printStringAtMkw (importDeclAnnAs an) "as" + printStringAtKw' (realSrcSpan l) (moduleNameString mn) + + case hiding of + Nothing -> return () + Just (_isHiding,lie) -> markAnnotated lie + -- markTrailingSemi + + +-- --------------------------------------------------------------------- + +instance ExactPrint HsDocString where + getAnnotationEntry _ = NoEntryVal + exact = withPpr -- TODO:AZ use annotations + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDecl GhcPs) where + getAnnotationEntry (TyClD _ _) = NoEntryVal + getAnnotationEntry (InstD _ _) = NoEntryVal + getAnnotationEntry (DerivD _ _) = NoEntryVal + getAnnotationEntry (ValD _ _) = NoEntryVal + getAnnotationEntry (SigD _ _) = NoEntryVal + getAnnotationEntry (KindSigD _ _) = NoEntryVal + getAnnotationEntry (DefD _ _) = NoEntryVal + getAnnotationEntry (ForD _ _) = NoEntryVal + getAnnotationEntry (WarningD _ _) = NoEntryVal + getAnnotationEntry (AnnD _ _) = NoEntryVal + getAnnotationEntry (RuleD _ _) = NoEntryVal + getAnnotationEntry (SpliceD _ _) = NoEntryVal + getAnnotationEntry (DocD _ _) = NoEntryVal + getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal + + exact (TyClD _ d) = markAnnotated d + exact (InstD _ d) = markAnnotated d + exact (DerivD _ d) = markAnnotated d + exact (ValD _ d) = markAnnotated d + exact (SigD _ d) = markAnnotated d + exact (KindSigD _ d) = markAnnotated d + exact (DefD _ d) = markAnnotated d + exact (ForD _ d) = markAnnotated d + exact (WarningD _ d) = markAnnotated d + exact (AnnD _ d) = markAnnotated d + exact (RuleD _ d) = markAnnotated d + exact (SpliceD _ d) = markAnnotated d + exact (DocD _ d) = markAnnotated d + exact (RoleAnnotD _ d) = markAnnotated d + +-- --------------------------------------------------------------------- + +instance ExactPrint (InstDecl GhcPs) where + getAnnotationEntry (ClsInstD _ _) = NoEntryVal + getAnnotationEntry (DataFamInstD an _) = fromAnn an + getAnnotationEntry (TyFamInstD _ _) = NoEntryVal + + + exact (ClsInstD _ cid) = markAnnotated cid + exact (DataFamInstD an decl) = do + exactDataFamInstDecl an TopLevel decl + exact (TyFamInstD _ eqn) = do + markAnnotated eqn + +-- --------------------------------------------------------------------- + +exactDataFamInstDecl :: EpAnn [AddEpAnn] -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP () +exactDataFamInstDecl an top_lvl + (DataFamInstDecl ( FamEqn { feqn_ext = an2 + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn })) + = markAnnotated (DataDefnWithContext an2 pp_hdr defn) -- See Note [an and an2 in exactDataFamInstDecl] + where + pp_hdr mctxt = do + case top_lvl of + TopLevel -> markEpAnn an AnnInstance -- TODO: maybe in toplevel + NotTopLevel -> return () + exactHsFamInstLHS an tycon bndrs pats fixity mctxt + +{- +Note [an and an2 in exactDataFamInstDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The exactDataFamInstDecl function is called to render a +DataFamInstDecl within its surrounding context. This context is +rendered via the 'pp_hdr' function, which uses the exact print +annotations from that context, named 'an'. The EPAs used for +rendering the DataDefn are contained in the FamEqn, and are called +'an2'. + +-} + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivDecl GhcPs) where + getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an + exact (DerivDecl an typ ms mov) = do + markEpAnn an AnnDeriving + mapM_ markAnnotated ms + markEpAnn an AnnInstance + mapM_ markAnnotated mov + markAnnotated typ + -- markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do + -- mark GHC.AnnDeriving + -- markMaybe ms + -- mark GHC.AnnInstance + -- markMaybe mov + -- markLocated typ + -- markTrailingSemi + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignDecl GhcPs) where + getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an + getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an + + exact (ForeignImport an n ty fimport) = do + markEpAnn an AnnForeign + markEpAnn an AnnImport + + markAnnotated fimport + + markAnnotated n + markEpAnn an AnnDcolon + markAnnotated ty + + exact (ForeignExport an n ty fexport) = do + markEpAnn an AnnForeign + markEpAnn an AnnExport + markAnnotated fexport + markAnnotated n + markEpAnn an AnnDcolon + markAnnotated ty + +-- --------------------------------------------------------------------- + +instance ExactPrint ForeignImport where + getAnnotationEntry = const NoEntryVal + exact (CImport cconv safety@(L ll _) _mh _imp (L ls src)) = do + markAnnotated cconv + unless (ll == noSrcSpan) $ markAnnotated safety + unless (ls == noSrcSpan) $ markExternalSourceText ls src "" + +-- --------------------------------------------------------------------- + +instance ExactPrint ForeignExport where + getAnnotationEntry = const NoEntryVal + exact (CExport spec (L ls src)) = do + debugM $ "CExport starting" + markAnnotated spec + unless (ls == noSrcSpan) $ markExternalSourceText ls src "" + +-- --------------------------------------------------------------------- + +instance ExactPrint CExportSpec where + getAnnotationEntry = const NoEntryVal + exact (CExportStatic _st _lbl cconv) = do + debugM $ "CExportStatic starting" + markAnnotated cconv + +-- --------------------------------------------------------------------- + +instance ExactPrint Safety where + getAnnotationEntry = const NoEntryVal + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint CCallConv where + getAnnotationEntry = const NoEntryVal + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecls GhcPs) where + getAnnotationEntry (Warnings an _ _) = fromAnn an + exact (Warnings an src warns) = do + markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED + markAnnotated warns + markLocatedAALS an id AnnClose (Just "#-}") + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecl GhcPs) where + getAnnotationEntry (Warning an _ _) = fromAnn an + + exact (Warning an lns txt) = do + markAnnotated lns + markEpAnn an AnnOpenS -- "[" + case txt of + WarningTxt _src ls -> markAnnotated ls + DeprecatedTxt _src ls -> markAnnotated ls + markEpAnn an AnnCloseS -- "]" + +-- --------------------------------------------------------------------- + +instance ExactPrint StringLiteral where + getAnnotationEntry = const NoEntryVal + + exact (StringLiteral src fs mcomma) = do + printSourceText src (show (unpackFS fs)) + mapM_ (\r -> printStringAtKw' r ",") mcomma + +-- --------------------------------------------------------------------- + +instance ExactPrint FastString where + getAnnotationEntry = const NoEntryVal + + -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. + -- exact fs = printStringAdvance (show (unpackFS fs)) + exact fs = printStringAdvance (unpackFS fs) + + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecls GhcPs) where + getAnnotationEntry (HsRules an _ _) = fromAnn an + exact (HsRules an src rules) = do + case src of + NoSourceText -> markLocatedAALS an id AnnOpen (Just "{-# RULES") + SourceText srcTxt -> markLocatedAALS an id AnnOpen (Just srcTxt) + markAnnotated rules + markLocatedAALS an id AnnClose (Just "#-}") + -- markTrailingSemi + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecl GhcPs) where + getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an + exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do + debugM "HsRule entered" + markAnnotated ln + debugM "HsRule after ln" + markActivation an ra_rest act + debugM "HsRule after act" + case mtybndrs of + Nothing -> return () + Just bndrs -> do + markLocatedMAA an (\a -> fmap fst (ra_tyanns a)) -- AnnForall + mapM_ markAnnotated bndrs + markLocatedMAA an (\a -> fmap snd (ra_tyanns a)) -- AnnDot + + markLocatedMAA an (\a -> fmap fst (ra_tmanns a)) -- AnnForall + mapM_ markAnnotated termbndrs + markLocatedMAA an (\a -> fmap snd (ra_tmanns a)) -- AnnDot + + markAnnotated lhs + markEpAnn' an ra_rest AnnEqual + markAnnotated rhs + -- markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do + -- markLocated ln + -- setContext (Set.singleton ExplicitNeverActive) $ markActivation l act + + + -- mark GHC.AnnForall + -- mapM_ markLocated termbndrs + -- mark GHC.AnnDot + + -- markLocated lhs + -- mark GHC.AnnEqual + -- markLocated rhs + -- inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + -- markTrailingSemi + +markActivation :: EpAnn a -> (a -> [AddEpAnn]) -> Activation -> Annotated () +markActivation an fn act = do + case act of + ActiveBefore src phase -> do + markEpAnn' an fn AnnOpenS -- '[' + markEpAnn' an fn AnnTilde -- ~ + markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + markEpAnn' an fn AnnCloseS -- ']' + ActiveAfter src phase -> do + markEpAnn' an fn AnnOpenS -- '[' + markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + markEpAnn' an fn AnnCloseS -- ']' + NeverActive -> do + markEpAnn' an fn AnnOpenS -- '[' + markEpAnn' an fn AnnTilde -- ~ + markEpAnn' an fn AnnCloseS -- ']' + _ -> return () + +-- --------------------------------------------------------------------- + +instance ExactPrint (SpliceDecl GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (SpliceDecl _ splice _flag) = do + markAnnotated splice + +-- --------------------------------------------------------------------- + +instance ExactPrint DocDecl where + getAnnotationEntry = const NoEntryVal + + exact v = + let str = + case v of + (DocCommentNext ds) -> unpackHDS ds + (DocCommentPrev ds) -> unpackHDS ds + (DocCommentNamed _s ds) -> unpackHDS ds + (DocGroup _i ds) -> unpackHDS ds + in + printStringAdvance str + +-- --------------------------------------------------------------------- + +instance ExactPrint (RoleAnnotDecl GhcPs) where + getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an + exact (RoleAnnotDecl an ltycon roles) = do + markEpAnn an AnnType + markEpAnn an AnnRole + markAnnotated ltycon + let markRole (L l (Just r)) = markAnnotated (L l r) + markRole (L l Nothing) = printStringAtSs l "_" + mapM_ markRole roles + +-- --------------------------------------------------------------------- + +instance ExactPrint Role where + getAnnotationEntry = const NoEntryVal + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleBndr GhcPs) where + getAnnotationEntry = const NoEntryVal + +{- + = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass) +-} + exact (RuleBndr _ ln) = markAnnotated ln + exact (RuleBndrSig an ln (HsPS _ ty)) = do + markEpAnn an AnnOpenP -- "(" + markAnnotated ln + markEpAnn an AnnDcolon + markAnnotated ty + markEpAnn an AnnCloseP -- ")" + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where + getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an + exact (FamEqn { feqn_ext = an + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }) = do + exactHsFamInstLHS an tycon bndrs pats fixity Nothing + markEpAnn an AnnEqual + markAnnotated rhs + +-- --------------------------------------------------------------------- + +exactHsFamInstLHS :: + EpAnn [AddEpAnn] + -> LocatedN RdrName + -- -> Maybe [LHsTyVarBndr () GhcPs] + -> HsOuterTyVarBndrs () GhcPs + -> HsTyPats GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EPP () +exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do + markEpAnn an AnnForall + markAnnotated bndrs + markEpAnn an AnnDot + mapM_ markAnnotated mb_ctxt + exact_pats typats + where + exact_pats :: HsTyPats GhcPs -> EPP () + exact_pats (patl:patr:pats) + | Infix <- fixity + = let exact_op_app = do + markAnnAll (epAnnAnns an) AnnOpenP + markAnnotated patl + markAnnotated thing + markAnnotated patr + markAnnAll (epAnnAnns an) AnnCloseP + in case pats of + [] -> exact_op_app + _ -> do + -- markEpAnn an AnnOpenP + exact_op_app + -- markEpAnn an AnnCloseP + mapM_ markAnnotated pats + + exact_pats pats = do + markAnnAll (epAnnAnns an) AnnOpenP + markAnnotated thing + markAnnotated pats + markAnnAll (epAnnAnns an) AnnCloseP + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (LHsTypeArg GhcPs) where +instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) + => ExactPrint (HsArg tm ty) where + getAnnotationEntry = const NoEntryVal + + exact (HsValArg tm) = markAnnotated tm + exact (HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty + exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source + +-- --------------------------------------------------------------------- + +-- instance ExactPrint [LHsTyVarBndr () GhcPs] where +-- getAnnotationEntry = const NoEntryVal +-- exact bs = mapM_ markAnnotated bs + +-- --------------------------------------------------------------------- + +instance ExactPrint (ClsInstDecl GhcPs) where + getAnnotationEntry cid = fromAnn (fst $ cid_ext cid) + + exact (ClsInstDecl { cid_ext = (an, sortKey) + , cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + -- | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part + -- = top_matter + + -- | otherwise -- Laid out + = do + top_matter + markEpAnn an AnnWhere + markEpAnn an AnnOpenC + markEpAnnAll an id AnnSemi + withSortKey sortKey + (prepareListAnnotationA ats + ++ prepareListAnnotationF (exactDataFamInstDecl an NotTopLevel ) adts + ++ prepareListAnnotationA (bagToList binds) + ++ prepareListAnnotationA sigs + ) + markEpAnn an AnnCloseC -- '}' + + where + top_matter = do + markEpAnn an AnnInstance + mapM_ markAnnotated mbOverlap + markAnnotated inst_ty + markEpAnn an AnnWhere -- Optional + -- text "instance" <+> ppOverlapPragma mbOverlap + -- <+> ppr inst_ty + -- markEpAnn an AnnOpenC -- Optional '{' + -- markEpAnn an AnnCloseC -- Optional '}' + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyFamInstDecl GhcPs) where + getAnnotationEntry (TyFamInstDecl an _) = fromAnn an + + exact (TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do + markEpAnn an AnnType + markEpAnn an AnnInstance + markAnnotated eqn + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP OverlapMode) where + getAnnotationEntry = entryFromLocatedA + + -- NOTE: NoOverlap is only used in the typechecker + exact (L (SrcSpanAnn an _) (NoOverlap src)) = do + markAnnOpenP an src "{-# NO_OVERLAP" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Overlappable src)) = do + markAnnOpenP an src "{-# OVERLAPPABLE" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Overlapping src)) = do + markAnnOpenP an src "{-# OVERLAPPING" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Overlaps src)) = do + markAnnOpenP an src "{-# OVERLAPS" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Incoherent src)) = do + markAnnOpenP an src "{-# INCOHERENT" + markAnnCloseP an + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsBind GhcPs) where + getAnnotationEntry FunBind{} = NoEntryVal + getAnnotationEntry PatBind{pat_ext=an} = fromAnn an + getAnnotationEntry VarBind{} = NoEntryVal + getAnnotationEntry AbsBinds{} = NoEntryVal + getAnnotationEntry PatSynBind{} = NoEntryVal + + exact (FunBind _ _ matches _) = do + markAnnotated matches + exact (PatBind _ pat grhss _) = do + markAnnotated pat + markAnnotated grhss + exact (PatSynBind _ bind) = markAnnotated bind + + exact x = error $ "HsBind: exact for " ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (PatSynBind GhcPs GhcPs) where + getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an + + exact (PSB{ psb_ext = an + , psb_id = psyn, psb_args = details + , psb_def = pat + , psb_dir = dir }) = do + markEpAnn an AnnPattern + case details of + InfixCon v1 v2 -> do + markAnnotated v1 + markAnnotated psyn + markAnnotated v2 + PrefixCon tvs vs -> do + markAnnotated psyn + markAnnotated tvs + markAnnotated vs + RecCon vs -> do + markAnnotated psyn + markEpAnn an AnnOpenC -- '{' + markAnnotated vs + markEpAnn an AnnCloseC -- '}' + + case dir of + Unidirectional -> do + markEpAnn an AnnLarrow + markAnnotated pat + ImplicitBidirectional -> do + markEpAnn an AnnEqual + markAnnotated pat + ExplicitBidirectional mg -> do + markEpAnn an AnnLarrow + markAnnotated pat + markEpAnn an AnnWhere + markAnnotated mg + + -- case dir of + -- GHC.ImplicitBidirectional -> mark GHC.AnnEqual + -- _ -> mark GHC.AnnLarrow + + -- markLocated def + -- case dir of + -- GHC.Unidirectional -> return () + -- GHC.ImplicitBidirectional -> return () + -- GHC.ExplicitBidirectional mg -> do + -- mark GHC.AnnWhere + -- mark GHC.AnnOpenC -- '{' + -- markMatchGroup l mg + -- mark GHC.AnnCloseC -- '}' + + -- markTrailingSemi + + +-- --------------------------------------------------------------------- + +instance ExactPrint (RecordPatSynField GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (RecordPatSynField { recordPatSynField = v }) = markAnnotated v + +-- --------------------------------------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (Match ann _ _ _) = fromAnn ann + + -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match + exact (Match an mctxt pats grhss) = do + exactMatch (Match an mctxt pats grhss) + +-- ------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (Match ann _ _ _) = fromAnn ann + + -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match + exact (Match an mctxt pats grhss) = do + exactMatch (Match an mctxt pats grhss) + +-- --------------------------------------------------------------------- + +exactMatch :: (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> Annotated () +exactMatch (Match an mctxt pats grhss) = do +-- Based on Expr.pprMatch + + debugM $ "exact Match entered" + + -- herald + case mctxt of + FunRhs fun fixity strictness -> do + debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun + case strictness of + SrcStrict -> markEpAnn an AnnBang + _ -> pure () + case fixity of + Prefix -> do + annotationsToCommentsA an [AnnOpenP,AnnCloseP] + markAnnotated fun + markAnnotated pats + Infix -> + case pats of + (p1:p2:rest) + | null rest -> do + markAnnotated p1 + markAnnotated fun + markAnnotated p2 + | otherwise -> do + markEpAnn an AnnOpenP + markAnnotated p1 + markAnnotated fun + markAnnotated p2 + markEpAnn an AnnCloseP + mapM_ markAnnotated rest + _ -> panic "FunRhs" + LambdaExpr -> do + markEpAnn an AnnLam + markAnnotated pats + GHC.CaseAlt -> do + markAnnotated pats + _ -> withPpr mctxt + + markAnnotated grhss + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + + exact (GRHSs _ grhss binds) = do + markAnnotated grhss + markAnnotated binds + + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + + exact (GRHSs _an grhss binds) = do + markAnnotated grhss + markAnnotated binds + +-- --------------------------------------------------------------------- + +-- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/20247 +-- is fixed +fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList +fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed +fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) + = (EpAnn (widenAnchor anchor (map toEpaAnn t)) (AnnList ma o c r t) cs) + where + toEpaAnn (AddSemiAnn ss) = AddEpAnn AnnSemi ss + toEpaAnn (AddCommaAnn ss) = AddEpAnn AnnComma ss + toEpaAnn (AddVbarAnn ss) = AddEpAnn AnnVbar ss + toEpaAnn (AddRarrowAnn ss) = AddEpAnn AnnRarrow ss + toEpaAnn (AddRarrowAnnU ss) = AddEpAnn AnnRarrowU ss + toEpaAnn (AddLollyAnnU ss) = AddEpAnn AnnLollyU ss + +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 +fixAnnListAnn :: EpAnn AnnList -> EpAnn AnnList +fixAnnListAnn EpAnnNotUsed = EpAnnNotUsed +fixAnnListAnn (EpAnn anchor (AnnList ma o c r t) cs) + = (EpAnn (widenAnchor anchor r) (AnnList ma o c r t) cs) + +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 +fixSrcAnnL :: SrcSpanAnnL -> SrcSpanAnnL +fixSrcAnnL (SrcSpanAnn an l) = SrcSpanAnn (fixAnnListAnn an) l + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsLocalBinds GhcPs) where + getAnnotationEntry (HsValBinds an _) = fromAnn (fixValbindsAnn an) + getAnnotationEntry (HsIPBinds{}) = NoEntryVal + getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal + + exact (HsValBinds an' valbinds) = do + let an = fixValbindsAnn an' + markLocatedAAL an al_rest AnnWhere + let manc = case an of + EpAnnNotUsed -> Nothing + _ -> al_anchor $ anns an + + case manc of + Just anc -> do + when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) + _ -> return () + + markAnnList False an $ markAnnotatedWithLayout valbinds + + exact (HsIPBinds an bs) + = markAnnList True an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs) + exact (EmptyLocalBinds _) = return () + + +-- --------------------------------------------------------------------- +instance ExactPrint (HsValBindsLR GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + + exact (ValBinds sortKey binds sigs) = do + setLayoutBoth $ withSortKey sortKey + (prepareListAnnotationA (bagToList binds) + ++ prepareListAnnotationA sigs + ) + exact (XValBindsLR _) = panic "XValBindsLR" + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsIPBinds GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (IPBinds _ binds) = setLayoutBoth $ markAnnotated binds + +-- --------------------------------------------------------------------- + +instance ExactPrint (IPBind GhcPs) where + getAnnotationEntry (IPBind an _ _) = fromAnn an + + exact (IPBind an (Left lr) rhs) = do + markAnnotated lr + markEpAnn an AnnEqual + markAnnotated rhs + + exact (IPBind _ (Right _) _) = error $ "ExactPrint IPBind: Right only after typechecker" + +-- --------------------------------------------------------------------- + +instance ExactPrint HsIPName where + getAnnotationEntry = const NoEntryVal + + exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotationF :: (a -> EPP ()) -> [LocatedAn an a] -> [(RealSrcSpan,EPP ())] +prepareListAnnotationF f ls + = map (\b -> (realSrcSpan $ getLocA b, f (unLoc b))) ls + +prepareListAnnotationA :: ExactPrint (LocatedAn an a) + => [LocatedAn an a] -> [(RealSrcSpan,EPP ())] +prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,markAnnotated b)) ls + +withSortKey :: AnnSortKey -> [(RealSrcSpan, EPP ())] -> EPP () +withSortKey annSortKey xs = do + debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey + let ordered = case annSortKey of + NoAnnSortKey -> sortBy orderByFst xs + -- Just keys -> error $ "withSortKey: keys" ++ show keys + AnnSortKey keys -> orderByKey xs keys + -- `debug` ("withSortKey:" ++ + -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), + -- map fst xs, + -- keys) + -- ) + mapM_ snd ordered + +orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering +orderByFst (a,_) (b,_) = compare a b + +-- --------------------------------------------------------------------- + +instance ExactPrint (Sig GhcPs) where + getAnnotationEntry (TypeSig a _ _) = fromAnn a + getAnnotationEntry (PatSynSig a _ _) = fromAnn a + getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a + getAnnotationEntry (IdSig {}) = NoEntryVal + getAnnotationEntry (FixSig a _) = fromAnn a + getAnnotationEntry (InlineSig a _ _) = fromAnn a + getAnnotationEntry (SpecSig a _ _ _) = fromAnn a + getAnnotationEntry (SpecInstSig a _ _) = fromAnn a + getAnnotationEntry (MinimalSig a _ _) = fromAnn a + getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a + getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a + +-- instance Annotate (Sig GhcPs) where + + exact (TypeSig an vars ty) = exactVarSig an vars ty + + exact (PatSynSig an lns typ) = do + markLocatedAAL an asRest AnnPattern + markAnnotated lns + markLocatedAA an asDcolon + markAnnotated typ + + exact (ClassOpSig an is_deflt vars ty) + | is_deflt = markLocatedAAL an asRest AnnDefault >> exactVarSig an vars ty + | otherwise = exactVarSig an vars ty + +-- markAST _ (IdSig {}) = +-- traceM "warning: Introduced after renaming" + + exact (FixSig an (FixitySig _ names (Fixity src v fdir))) = do + let fixstr = case fdir of + InfixL -> "infixl" + InfixR -> "infixr" + InfixN -> "infix" + markLocatedAALS an id AnnInfix (Just fixstr) +-- markSourceText src (show v) + markLocatedAALS an id AnnVal (Just (sourceTextToString src (show v))) + markAnnotated names + + + exact (InlineSig an ln inl) = do + markAnnOpen an (inl_src inl) "{-# INLINE" + -- markActivation l (inl_act inl) + markActivation an id (inl_act inl) + markAnnotated ln + -- markWithString AnnClose "#-}" -- '#-}' + debugM $ "InlineSig:an=" ++ showAst an + p <- getPosP + debugM $ "InlineSig: p=" ++ show p + markLocatedAALS an id AnnClose (Just "#-}") + debugM $ "InlineSig:done" + + exact (SpecSig an ln typs inl) = do + markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + markActivation an id (inl_act inl) + markAnnotated ln + markEpAnn an AnnDcolon + markAnnotated typs + markLocatedAALS an id AnnClose (Just "#-}") + + exact (SpecInstSig an src typ) = do + markAnnOpen an src "{-# SPECIALISE" + markEpAnn an AnnInstance + markAnnotated typ + markLocatedAALS an id AnnClose (Just "#-}") + +-- markAST _ (SpecInstSig _ src typ) = do +-- markAnnOpen src "{-# SPECIALISE" +-- mark AnnInstance +-- markLHsSigType typ +-- markWithString AnnClose "#-}" -- '#-}' +-- markTrailingSemi + + exact (MinimalSig an src formula) = do + markAnnOpen an src "{-# MINIMAL" + markAnnotated formula + markLocatedAALS an id AnnClose (Just "#-}") + +-- markAST _ (MinimalSig _ src formula) = do +-- markAnnOpen src "{-# MINIMAL" +-- markLocated formula +-- markWithString AnnClose "#-}" +-- markTrailingSemi + + exact (SCCFunSig an src ln ml) = do + markAnnOpen an src "{-# SCC" + markAnnotated ln + markAnnotated ml + markLocatedAALS an id AnnClose (Just "#-}") + + exact (CompleteMatchSig an src cs mty) = do + markAnnOpen an src "{-# COMPLETE" + markAnnotated cs + case mty of + Nothing -> return () + Just ty -> do + markEpAnn an AnnDcolon + markAnnotated ty + markLocatedAALS an id AnnClose (Just "#-}") + + exact x = error $ "exact Sig for:" ++ showAst x + +-- --------------------------------------------------------------------- + +exactVarSig :: (ExactPrint a) => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EPP () +exactVarSig an vars ty = do + mapM_ markAnnotated vars + markLocatedAA an asDcolon + markAnnotated ty + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (FixitySig GhcPs) where +-- getAnnotationEntry = const NoEntryVal + +-- exact (FixitySig an names (Fixity src v fdir)) = do +-- let fixstr = case fdir of +-- InfixL -> "infixl" +-- InfixR -> "infixr" +-- InfixN -> "infix" +-- markAnnotated names +-- markLocatedAALS an id AnnInfix (Just fixstr) +-- -- markAST _ (FixSig _ (FixitySig _ lns (Fixity src v fdir))) = do +-- -- let fixstr = case fdir of +-- -- InfixL -> "infixl" +-- -- InfixR -> "infixr" +-- -- InfixN -> "infix" +-- -- markWithString AnnInfix fixstr +-- -- markSourceText src (show v) +-- -- setContext (Set.singleton InfixOp) $ markListIntercalate lns +-- -- markTrailingSemi +-- --------------------------------------------------------------------- + +instance ExactPrint (StandaloneKindSig GhcPs) where + getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an + + exact (StandaloneKindSig an vars sig) = do + markEpAnn an AnnType + markAnnotated vars + markEpAnn an AnnDcolon + markAnnotated sig + +-- --------------------------------------------------------------------- + +instance ExactPrint (DefaultDecl GhcPs) where + getAnnotationEntry (DefaultDecl an _) = fromAnn an + + exact (DefaultDecl an tys) = do + markEpAnn an AnnDefault + markEpAnn an AnnOpenP + markAnnotated tys + markEpAnn an AnnCloseP + +-- --------------------------------------------------------------------- + +instance ExactPrint (AnnDecl GhcPs) where + getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an + + exact (HsAnnotation an src prov e) = do + markAnnOpenP an src "{-# ANN" + case prov of + (ValueAnnProvenance n) -> markAnnotated n + (TypeAnnProvenance n) -> do + markLocatedAAL an apr_rest AnnType + markAnnotated n + ModuleAnnProvenance -> markLocatedAAL an apr_rest AnnModule + + markAnnotated e + markAnnCloseP an + +-- --------------------------------------------------------------------- + +instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where + getAnnotationEntry = const NoEntryVal + + exact (BF.Var x) = do + markAnnotated x + exact (BF.Or ls) = markAnnotated ls + exact (BF.And ls) = do + markAnnotated ls + exact (BF.Parens x) = do + -- mark AnnOpenP -- '(' + markAnnotated x + -- mark 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 ExactPrint (LHsSigWcType GhcPs) where +-- instance ExactPrint (HsWildCardBndrs GhcPs (LHsSigType GhcPs)) where +instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where + getAnnotationEntry = const NoEntryVal + exact (HsWC _ ty) = markAnnotated ty + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHS an _ _) = fromAnn an + + exact (GRHS an guards expr) = do + debugM $ "GRHS comments:" ++ showGhc (comments an) + markAnnKwM an ga_vbar AnnVbar + markAnnotated guards + debugM $ "GRHS before matchSeparator" + markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs + debugM $ "GRHS after matchSeparator" + markAnnotated expr + -- markLocatedAA an ga_sep + +instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHS ann _ _) = fromAnn ann + + exact (GRHS an guards expr) = do + markAnnKwM an ga_vbar AnnVbar + markAnnotated guards + markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs + markAnnotated expr + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsExpr GhcPs) where + getAnnotationEntry (HsVar{}) = NoEntryVal + getAnnotationEntry (HsUnboundVar an _) = fromAnn an + getAnnotationEntry (HsConLikeOut{}) = NoEntryVal + getAnnotationEntry (HsRecFld{}) = NoEntryVal + getAnnotationEntry (HsOverLabel an _) = fromAnn an + getAnnotationEntry (HsIPVar an _) = fromAnn an + getAnnotationEntry (HsOverLit an _) = fromAnn an + getAnnotationEntry (HsLit an _) = fromAnn an + getAnnotationEntry (HsLam _ _) = NoEntryVal + getAnnotationEntry (HsLamCase an _) = fromAnn an + getAnnotationEntry (HsApp an _ _) = fromAnn an + getAnnotationEntry (HsAppType _ _ _) = NoEntryVal + getAnnotationEntry (OpApp an _ _ _) = fromAnn an + getAnnotationEntry (NegApp an _ _) = fromAnn an + getAnnotationEntry (HsPar an _) = fromAnn an + getAnnotationEntry (SectionL an _ _) = fromAnn an + getAnnotationEntry (SectionR an _ _) = fromAnn an + getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an + getAnnotationEntry (ExplicitSum an _ _ _) = fromAnn an + getAnnotationEntry (HsCase an _ _) = fromAnn an + getAnnotationEntry (HsIf an _ _ _) = fromAnn an + getAnnotationEntry (HsMultiIf an _) = fromAnn an + getAnnotationEntry (HsLet an _ _) = fromAnn an + getAnnotationEntry (HsDo an _ _) = fromAnn an + getAnnotationEntry (ExplicitList an _) = fromAnn an + getAnnotationEntry (RecordCon an _ _) = fromAnn an + getAnnotationEntry (RecordUpd an _ _) = fromAnn an + getAnnotationEntry (HsGetField an _ _) = fromAnn an + getAnnotationEntry (HsProjection an _) = fromAnn an + getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an + getAnnotationEntry (ArithSeq an _ _) = fromAnn an + getAnnotationEntry (HsBracket an _) = fromAnn an + getAnnotationEntry (HsRnBracketOut{}) = NoEntryVal + getAnnotationEntry (HsTcBracketOut{}) = NoEntryVal + getAnnotationEntry (HsSpliceE an _) = fromAnn an + getAnnotationEntry (HsProc an _ _) = fromAnn an + getAnnotationEntry (HsStatic an _) = fromAnn an + getAnnotationEntry (HsTick {}) = NoEntryVal + getAnnotationEntry (HsBinTick {}) = NoEntryVal + getAnnotationEntry (HsPragE{}) = NoEntryVal + + + exact (HsVar _ n) = markAnnotated n + exact x@(HsUnboundVar an _v) = do + case an of + EpAnnNotUsed -> withPpr x + EpAnn _ (EpAnnUnboundVar (ob,cb) l) _ -> do + printStringAtAA ob "`" + printStringAtAA l "_" + printStringAtAA cb "`" + -- exact x@(HsConLikeOut{}) = withPpr x + -- exact x@(HsRecFld{}) = withPpr x + exact x@(HsOverLabel _ _) = withPpr x + + exact (HsIPVar _ (HsIPName n)) + = printStringAdvance ("?" ++ unpackFS n) + + exact x@(HsOverLit _an ol) = do + let str = case ol_val ol of + HsIntegral (IL src _ _) -> src + HsFractional (FL { fl_text = src }) -> src + HsIsString src _ -> src + -- markExternalSourceText l str "" + case str of + SourceText s -> printStringAdvance s + NoSourceText -> withPpr x + + exact (HsLit _an lit) = withPpr lit + exact (HsLam _ (MG _ (L _ [match]) _)) = do + markAnnotated match + -- markExpr _ (HsLam _ (MG _ (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 _ (HsLam _ _) = error $ "HsLam with other than one match" + exact (HsLam _ _) = error $ "HsLam with other than one match" + + exact (HsLamCase an mg) = do + markEpAnn an AnnLam + markEpAnn an AnnCase + markAnnotated mg + + exact (HsApp _an e1 e2) = do + p <- getPosP + debugM $ "HsApp entered. p=" ++ show p + markAnnotated e1 + markAnnotated e2 + exact (HsAppType ss fun arg) = do + markAnnotated fun + printStringAtSs ss "@" + markAnnotated arg + exact (OpApp _an e1 e2 e3) = do + markAnnotated e1 + markAnnotated e2 + markAnnotated e3 + + exact (NegApp an e _) = do + markEpAnn an AnnMinus + markAnnotated e + + exact (HsPar an e) = do + markOpeningParen an + markAnnotated e + debugM $ "HsPar closing paren" + markClosingParen an + debugM $ "HsPar done" + + exact (SectionL _an expr op) = do + markAnnotated expr + markAnnotated op + + exact (SectionR _an op expr) = do + markAnnotated op + markAnnotated expr + + exact (ExplicitTuple an args b) = do + if b == Boxed then markEpAnn an AnnOpenP + else markEpAnn an AnnOpenPH + + mapM_ markAnnotated args + + if b == Boxed then markEpAnn an AnnCloseP + else markEpAnn an AnnClosePH + debugM $ "ExplicitTuple done" + + exact (ExplicitSum an _alt _arity expr) = do + -- markEpAnn an AnnOpenPH + markAnnKw an aesOpen AnnOpenPH + markAnnKwAll an aesBarsBefore AnnVbar + markAnnotated expr + markAnnKwAll an aesBarsAfter AnnVbar + markAnnKw an aesClose AnnClosePH + + exact (HsCase an e alts) = do + markAnnKw an hsCaseAnnCase AnnCase + markAnnotated e + markAnnKw an hsCaseAnnOf AnnOf + markEpAnn' an hsCaseAnnsRest AnnOpenC + markEpAnnAll an hsCaseAnnsRest AnnSemi + setLayoutBoth $ markAnnotated alts + markEpAnn' an hsCaseAnnsRest AnnCloseC + + -- exact x@(HsCase EpAnnNotUsed _ _) = withPpr x + exact (HsIf an e1 e2 e3) = do + markAnnKw an aiIf AnnIf + markAnnotated e1 + markAnnKwM an aiThenSemi AnnSemi + markAnnKw an aiThen AnnThen + markAnnotated e2 + markAnnKwM an aiElseSemi AnnSemi + markAnnKw an aiElse AnnElse + markAnnotated e3 + + exact (HsMultiIf an mg) = do + markEpAnn an AnnIf + markEpAnn an AnnOpenC -- optional + markAnnotated mg + markEpAnn an AnnCloseC -- optional + + exact (HsLet an binds e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + markAnnKw an alLet AnnLet + debugM $ "HSlet:binds coming" + setLayoutBoth $ markAnnotated binds + debugM $ "HSlet:binds done" + markAnnKw an alIn AnnIn + debugM $ "HSlet:expr coming" + markAnnotated e + + exact (HsDo an do_or_list_comp stmts) = do + debugM $ "HsDo" + markAnnList True an $ exactDo an do_or_list_comp stmts + + exact (ExplicitList an es) = do + debugM $ "ExplicitList start" + markLocatedMAA an al_open + markAnnotated es + markLocatedMAA an al_close + debugM $ "ExplicitList end" + exact (RecordCon an con_id binds) = do + markAnnotated con_id + markEpAnn an AnnOpenC + markAnnotated binds + markEpAnn an AnnCloseC + exact (RecordUpd an expr fields) = do + markAnnotated expr + markEpAnn an AnnOpenC + markAnnotated fields + markEpAnn an AnnCloseC + exact (HsGetField _an expr field) = do + markAnnotated expr + markAnnotated field + exact (HsProjection an flds) = do + markAnnKw an apOpen AnnOpenP + markAnnotated flds + markAnnKw an apClose AnnCloseP + exact (ExprWithTySig an expr sig) = do + markAnnotated expr + markEpAnn an AnnDcolon + markAnnotated sig + exact (ArithSeq an _ seqInfo) = do + markEpAnn an AnnOpenS -- '[' + case seqInfo of + From e -> do + markAnnotated e + markEpAnn an AnnDotdot + FromTo e1 e2 -> do + markAnnotated e1 + markEpAnn an AnnDotdot + markAnnotated e2 + FromThen e1 e2 -> do + markAnnotated e1 + markEpAnn an AnnComma + markAnnotated e2 + markEpAnn an AnnDotdot + FromThenTo e1 e2 e3 -> do + markAnnotated e1 + markEpAnn an AnnComma + markAnnotated e2 + markEpAnn an AnnDotdot + markAnnotated e3 + markEpAnn an AnnCloseS -- ']' + + + exact (HsBracket an (ExpBr _ e)) = do + markEpAnn an AnnOpenEQ -- "[|" + markEpAnn an AnnOpenE -- "[e|" -- optional + markAnnotated e + markEpAnn an AnnCloseQ -- "|]" + exact (HsBracket an (PatBr _ e)) = do + markLocatedAALS an id AnnOpen (Just "[p|") + markAnnotated e + markEpAnn an AnnCloseQ -- "|]" + exact (HsBracket an (DecBrL _ e)) = do + + markLocatedAALS an id AnnOpen (Just "[d|") + -- See https://gitlab.haskell.org/ghc/ghc/-/issues/20257, we need + -- to mark braces here for the time being + markEpAnn an AnnOpenC -- "{" + markAnnotated e + markEpAnn an AnnCloseC -- "}" + markEpAnn an AnnCloseQ -- "|]" + -- -- exact (HsBracket an (DecBrG _ _)) = + -- -- traceM "warning: DecBrG introduced after renamer" + exact (HsBracket an (TypBr _ e)) = do + markLocatedAALS an id AnnOpen (Just "[t|") + markAnnotated e + markEpAnn an AnnCloseQ -- "|]" + exact (HsBracket an (VarBr _ b e)) = do + if b + then do + markEpAnn an AnnSimpleQuote + markAnnotated e + else do + markEpAnn an AnnThTyQuote + markAnnotated e + exact (HsBracket an (TExpBr _ e)) = do + markLocatedAALS an id AnnOpen (Just "[||") + markLocatedAALS an id AnnOpenE (Just "[e||") + markAnnotated e + markLocatedAALS an id AnnClose (Just "||]") + + + -- exact x@(HsRnBracketOut{}) = withPpr x + -- exact x@(HsTcBracketOut{}) = withPpr x + exact (HsSpliceE _ sp) = markAnnotated sp + + exact (HsProc an p c) = do + debugM $ "HsProc start" + markEpAnn an AnnProc + markAnnotated p + markEpAnn an AnnRarrow + debugM $ "HsProc after AnnRarrow" + markAnnotated c + + exact (HsStatic an e) = do + markEpAnn an AnnStatic + markAnnotated e + + -- exact x@(HsTick {}) = withPpr x + -- exact x@(HsBinTick {}) = withPpr x + exact (HsPragE _ prag e) = do + markAnnotated prag + markAnnotated e + exact x = error $ "exact HsExpr for:" ++ showAst x + +-- --------------------------------------------------------------------- + +exactDo :: (ExactPrint body) + => EpAnn AnnList -> (HsStmtContext any) -> body -> EPP () +exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >> markAnnotatedWithLayout stmts +exactDo an GhciStmtCtxt stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts +exactDo an ArrowExpr stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts +exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >> markAnnotatedWithLayout stmts +exactDo _ ListComp stmts = markAnnotatedWithLayout stmts +exactDo _ MonadComp stmts = markAnnotatedWithLayout stmts +exactDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +exactMdo :: EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP () +exactMdo an Nothing kw = markLocatedAAL an al_rest kw +exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n) + where + n = (moduleNameString module_name) ++ "." ++ (keywordToString (G kw)) + + +-- --------------------------------------------------------------------- +instance ExactPrint (HsPragE GhcPs) where + getAnnotationEntry HsPragSCC{} = NoEntryVal + + exact (HsPragSCC an st sl) = do + markAnnOpenP an st "{-# SCC" + let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) + markLocatedAALS an apr_rest AnnVal (Just txt) -- optional + markLocatedAALS an apr_rest AnnValStr (Just txt) -- optional + markAnnCloseP an + + -- markExpr _ (GHC.HsPragE _ prag e) = do + -- case prag of + -- (GHC.HsPragSCC _ src csFStr) -> do + -- markAnnOpen src "{-# SCC" + -- let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) + -- markWithStringOptional GHC.AnnVal txt + -- markWithString GHC.AnnValStr txt + -- markWithString GHC.AnnClose "#-}" + -- markLocated e + + -- (GHC.HsPragTick _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4))) -> do + -- -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + -- markAnnOpen src "{-# GENERATED" + -- markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING + + -- let + -- markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) + -- markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s + + -- markOne 1 v1 s1 -- INTEGER + -- markOffset GHC.AnnColon 0 -- ':' + -- markOne 2 v2 s2 -- INTEGER + -- mark GHC.AnnMinus -- '-' + -- markOne 3 v3 s3 -- INTEGER + -- markOffset GHC.AnnColon 1 -- ':' + -- markOne 4 v4 s4 -- INTEGER + -- markWithString GHC.AnnClose "#-}" + -- markLocated e + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsSplice GhcPs) where + getAnnotationEntry (HsTypedSplice an _ _ _) = fromAnn an + getAnnotationEntry (HsUntypedSplice an _ _ _) = fromAnn an + getAnnotationEntry (HsQuasiQuote _ _ _ _ _) = NoEntryVal + getAnnotationEntry (HsSpliced _ _ _) = NoEntryVal + + exact (HsTypedSplice an DollarSplice _n e) = do + markEpAnn an AnnDollarDollar + markAnnotated e + + -- = ppr_splice (text "$$") n e empty + -- exact (HsTypedSplice _ BareSplice _ _ ) + -- = panic "Bare typed splice" -- impossible + exact (HsUntypedSplice an decoration _n b) = do + when (decoration == DollarSplice) $ markEpAnn an AnnDollar + markAnnotated b + + -- exact (HsUntypedSplice _ DollarSplice n e) + -- = ppr_splice (text "$") n e empty + -- exact (HsUntypedSplice _ BareSplice n e) + -- = ppr_splice empty n e empty + + exact (HsQuasiQuote _ _ q ss fs) = do + -- The quasiquote string does not honour layout offsets. Store + -- the colOffset for now. + -- TODO: use local? + oldOffset <- getLayoutOffsetP + EPState{pMarkLayout} <- get + unless pMarkLayout $ setLayoutOffsetP 0 + printStringAdvance + -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 + ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") + unless pMarkLayout $ setLayoutOffsetP oldOffset + p <- getPosP + debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss) + + -- exact (HsSpliced _ _ thing) = ppr thing + -- exact (XSplice x) = case ghcPass @p of + exact x = error $ "exact HsSplice for:" ++ showAst x + +-- --------------------------------------------------------------------- + +-- TODO:AZ: combine these instances +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry = const NoEntryVal + exact (MG _ matches _) = do + -- TODO:AZ use SortKey, in MG ann. + markAnnotated matches + +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry = const NoEntryVal + exact (MG _ matches _) = do + -- TODO:AZ use SortKey, in MG ann. + markAnnotated matches + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where + getAnnotationEntry = const NoEntryVal + exact (HsRecFields fields mdot) = do + markAnnotated fields + case mdot of + Nothing -> return () + Just (L ss _) -> + printStringAtSs ss ".." + -- Note: mdot contains the SrcSpan where the ".." appears, if present + +-- --------------------------------------------------------------------- + +-- instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where +instance (ExactPrint body) + => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecField" + markAnnotated f + if isPun then return () + else do + markEpAnn an AnnEqual + markAnnotated arg + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsRecField' (FieldLabelStrings GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecField FieldLabelStrings" + markAnnotated f + if isPun then return () + else do + markEpAnn an AnnEqual + markAnnotated arg + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (HsRecUpdField GhcPs ) where +instance (ExactPrint (LocatedA body)) + => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) (LocatedA body)) where +-- instance (ExactPrint body) + -- => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecUpdField" + markAnnotated f + if isPun then return () + else markEpAnn an AnnEqual + unless ((locA $ getLoc arg) == noSrcSpan ) $ markAnnotated arg + +-- --------------------------------------------------------------------- +instance + (ExactPrint (HsRecField' (a GhcPs) body), + ExactPrint (HsRecField' (b GhcPs) body)) + => ExactPrint + (Either [LocatedA (HsRecField' (a GhcPs) body)] + [LocatedA (HsRecField' (b GhcPs) body)]) where + getAnnotationEntry = const NoEntryVal + exact (Left rbinds) = markAnnotated rbinds + exact (Right pbinds) = markAnnotated pbinds + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldLabelStrings GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (FieldLabelStrings fs) = markAnnotated fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsFieldLabel GhcPs) where + getAnnotationEntry (HsFieldLabel an _) = fromAnn an + + exact (HsFieldLabel an fs) = do + markAnnKwM an afDot AnnDot + markAnnotated fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsTupArg GhcPs) where + getAnnotationEntry (Present an _) = fromAnn an + getAnnotationEntry (Missing an) = fromAnn an + + exact (Present _ e) = markAnnotated e + + exact (Missing EpAnnNotUsed) = return () + exact (Missing _) = printStringAdvance "," + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmdTop GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (HsCmdTop _ cmd) = markAnnotated cmd + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmd GhcPs) where + getAnnotationEntry (HsCmdArrApp an _ _ _ _) = fromAnn an + getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an + getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an + getAnnotationEntry (HsCmdLam {}) = NoEntryVal + getAnnotationEntry (HsCmdPar an _) = fromAnn an + getAnnotationEntry (HsCmdCase an _ _) = fromAnn an + getAnnotationEntry (HsCmdLamCase an _) = fromAnn an + getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an + getAnnotationEntry (HsCmdLet an _ _) = fromAnn an + getAnnotationEntry (HsCmdDo an _) = fromAnn an + + + + exact (HsCmdArrApp an arr arg _o isRightToLeft) = do + if isRightToLeft + then do + markAnnotated arr + markKw (anns an) + markAnnotated arg + else do + markAnnotated arg + markKw (anns an) + markAnnotated arr + + exact (HsCmdArrForm an e fixity _mf cs) = do + markLocatedMAA an al_open + case (fixity, cs) of + (Infix, (arg1:argrest)) -> do + markAnnotated arg1 + markAnnotated e + markAnnotated argrest + (Prefix, _) -> do + markAnnotated e + markAnnotated cs + (Infix, []) -> error "Not possible" + markLocatedMAA an al_close + + exact (HsCmdApp _an e1 e2) = do + markAnnotated e1 + markAnnotated e2 + + exact (HsCmdLam _ match) = markAnnotated match + + exact (HsCmdPar an e) = do + markOpeningParen an + markAnnotated e + markClosingParen an + + exact (HsCmdCase an e alts) = do + markAnnKw an hsCaseAnnCase AnnCase + markAnnotated e + markAnnKw an hsCaseAnnOf AnnOf + markEpAnn' an hsCaseAnnsRest AnnOpenC + markEpAnnAll an hsCaseAnnsRest AnnSemi + markAnnotated alts + markEpAnn' an hsCaseAnnsRest AnnCloseC + + exact (HsCmdLamCase an matches) = do + markEpAnn an AnnLam + markEpAnn an AnnCase + markAnnotated matches + + exact (HsCmdIf an _ e1 e2 e3) = do + markAnnKw an aiIf AnnIf + markAnnotated e1 + markAnnKwM an aiThenSemi AnnSemi + markAnnKw an aiThen AnnThen + markAnnotated e2 + markAnnKwM an aiElseSemi AnnSemi + markAnnKw an aiElse AnnElse + markAnnotated e3 + + exact (HsCmdLet an binds e) = do + markAnnKw an alLet AnnLet + markAnnotated binds + markAnnKw an alIn AnnIn + markAnnotated e + +-- markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do +-- mark GHC.AnnLet +-- markOptional GHC.AnnOpenC +-- markLocalBindsWithLayout binds +-- markOptional GHC.AnnCloseC +-- mark GHC.AnnIn +-- markLocated e + + exact (HsCmdDo an es) = do + debugM $ "HsCmdDo" + markEpAnn' an al_rest AnnDo + markAnnotated es + + -- exact x = error $ "exact HsCmd for:" ++ showAst x + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (CmdLStmt GhcPs) where +-- getAnnotationEntry = const NoEntryVal +-- exact (L _ a) = markAnnotated a + +-- --------------------------------------------------------------------- + +instance ( + ExactPrint (LocatedA (body GhcPs)), + Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL, + (ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where + getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (BindStmt an _ _) = fromAnn an + getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal + getAnnotationEntry (BodyStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (LetStmt an _) = fromAnn an + getAnnotationEntry (ParStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an + getAnnotationEntry (RecStmt an _ _ _ _ _ _) = fromAnn an + + ----------------------------------------------------------------- + + exact (LastStmt _ body _ _) = do + debugM $ "LastStmt" + markAnnotated body + + exact (BindStmt an pat body) = do + debugM $ "BindStmt" + markAnnotated pat + markEpAnn an AnnLarrow + markAnnotated body + + exact (ApplicativeStmt _ _body _) = do + debugM $ "ApplicativeStmt" + -- TODO: ApplicativeStmt + -- markAnnotated body + error $ "need to complete ApplicativeStmt" + + exact (BodyStmt _ body _ _) = do + debugM $ "BodyStmt" + markAnnotated body + + exact (LetStmt an binds) = do + debugM $ "LetStmt" + markEpAnn an AnnLet + markAnnotated binds + + exact (ParStmt _ pbs _ _) = do + debugM $ "ParStmt" + markAnnotated pbs + + -- 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 + + +-- pprStmt (TransStmt { trS_stmts = stmts, trS_by = by +-- , trS_using = using, trS_form = form }) +-- = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + + exact (TransStmt an form stmts _b using by _ _ _) = do + debugM $ "TransStmt" + markAnnotated stmts + exactTransStmt an by using form + + -- 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 + + exact (RecStmt an stmts _ _ _ _ _) = do + debugM $ "RecStmt" + markLocatedAAL an al_rest AnnRec + markAnnList True an (markAnnotated stmts) + + -- markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do + -- mark GHC.AnnRec + -- markOptional GHC.AnnOpenC + -- markInside GHC.AnnSemi + -- markListWithLayout stmts + -- markOptional GHC.AnnCloseC + -- inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + -- markTrailingSemi + + -- exact x = error $ "exact CmdLStmt for:" ++ showAst x + -- exact x = error $ "exact CmdLStmt for:" + + +-- --------------------------------------------------------------------- + +instance ExactPrint (ParStmtBlock GhcPs GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (ParStmtBlock _ stmts _ _) = markAnnotated stmts + +exactTransStmt :: EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP () +exactTransStmt an by using ThenForm = do + debugM $ "exactTransStmt:ThenForm" + markEpAnn an AnnThen + markAnnotated using + case by of + Nothing -> return () + Just b -> do + markEpAnn an AnnBy + markAnnotated b +exactTransStmt an by using GroupForm = do + debugM $ "exactTransStmt:GroupForm" + markEpAnn an AnnThen + markEpAnn an AnnGroup + case by of + Just b -> do + markEpAnn an AnnBy + markAnnotated b + Nothing -> return () + markEpAnn an AnnUsing + markAnnotated using + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyClDecl GhcPs) where + getAnnotationEntry (FamDecl { }) = NoEntryVal + getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an + getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an + getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an + + exact (FamDecl _ decl) = do + markAnnotated decl + + exact (SynDecl { tcdSExt = an + , tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdRhs = rhs }) = do + -- There may be arbitrary parens around parts of the constructor + -- that are infix. Turn these into comments so that they feed + -- into the right place automatically + annotationsToComments (epAnnAnns an) [AnnOpenP,AnnCloseP] + markEpAnn an AnnType + + exactVanillaDeclHead ltycon tyvars fixity Nothing + markEpAnn an AnnEqual + markAnnotated rhs + + exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars + , tcdFixity = fixity, tcdDataDefn = defn }) = + exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn + + -- ----------------------------------- + + exact (ClassDecl {tcdCExt = (an, sortKey, _), + tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = _docs}) + -- TODO: add a test that demonstrates tcdDocs + | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part + = do + top_matter + markEpAnn an AnnOpenC + markEpAnn an AnnCloseC + + | otherwise -- Laid out + = do + top_matter + markEpAnn an AnnOpenC + markEpAnnAll an id AnnSemi + withSortKey sortKey + (prepareListAnnotationA sigs + ++ prepareListAnnotationA (bagToList methods) + ++ prepareListAnnotationA ats + ++ prepareListAnnotationA at_defs + -- ++ prepareListAnnotation docs + ) + markEpAnn an AnnCloseC + where + top_matter = do + annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] + markEpAnn an AnnClass + exactVanillaDeclHead lclas tyvars fixity context + unless (null fds) $ do + markEpAnn an AnnVbar + markAnnotated fds + markEpAnn an AnnWhere + +-- --------------------------------------------------------------------- + +instance ExactPrint (FunDep GhcPs) where + getAnnotationEntry (FunDep an _ _) = fromAnn an + + exact (FunDep an ls rs') = do + markAnnotated ls + markEpAnn an AnnRarrow + markAnnotated rs' + +-- --------------------------------------------------------------------- + +instance ExactPrint (FamilyDecl GhcPs) where + getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an + + exact (FamilyDecl { fdExt = an + , fdInfo = info + , fdTopLevel = top_level + , fdLName = ltycon + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L _ result + , fdInjectivityAnn = mb_inj }) = do + -- = vcat [ pprFlavour info <+> pp_top_level <+> + -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> + -- pp_kind <+> pp_inj <+> pp_where + -- , nest 2 $ pp_eqns ] + exactFlavour an info + exact_top_level + annotationsToCommentsA an [AnnOpenP,AnnCloseP] + exactVanillaDeclHead ltycon tyvars fixity Nothing + exact_kind + case mb_inj of + Nothing -> return () + Just inj -> do + markEpAnn an AnnVbar + markAnnotated inj + case info of + ClosedTypeFamily mb_eqns -> do + markEpAnn an AnnWhere + markEpAnn an AnnOpenC + case mb_eqns of + Nothing -> markEpAnn an AnnDotdot + Just eqns -> markAnnotated eqns + markEpAnn an AnnCloseC + _ -> return () + where + exact_top_level = case top_level of + TopLevel -> markEpAnn an AnnFamily + NotTopLevel -> do + -- It seems that in some kind of legacy + -- mode the 'family' keyword is still + -- accepted. + markEpAnn an AnnFamily + return () + + exact_kind = case result of + NoSig _ -> return () + KindSig _ kind -> markEpAnn an AnnDcolon >> markAnnotated kind + TyVarSig _ tv_bndr -> markEpAnn an AnnEqual >> markAnnotated tv_bndr + + -- exact_inj = case mb_inj of + -- Just (L _ (InjectivityAnn _ lhs rhs)) -> + -- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + -- Nothing -> empty + -- (pp_where, pp_eqns) = case info of + -- ClosedTypeFamily mb_eqns -> + -- ( text "where" + -- , case mb_eqns of + -- Nothing -> text ".." + -- Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) + -- _ -> (empty, empty) + +exactFlavour :: EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EPP () +exactFlavour an DataFamily = markEpAnn an AnnData +exactFlavour an OpenTypeFamily = markEpAnn an AnnType +exactFlavour an (ClosedTypeFamily {}) = markEpAnn an AnnType + +-- instance Outputable (FamilyInfo pass) where +-- ppr info = pprFlavour info <+> text "family" + +-- --------------------------------------------------------------------- + +data DataDefnWithContext + = DataDefnWithContext + { ddwc_an :: EpAnn [AddEpAnn] + , ddwc_hdr:: (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header + , ddwc_defn:: HsDataDefn GhcPs + } + +instance ExactPrint DataDefnWithContext where + getAnnotationEntry DataDefnWithContext{ddwc_an = an} = fromAnn an + + exact (DataDefnWithContext an exactHdr defn) + = exactDataDefn an exactHdr defn + +exactDataDefn :: EpAnn [AddEpAnn] + -> (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header + -> HsDataDefn GhcPs + -> EPP () +exactDataDefn an exactHdr + (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) = do + annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] + if new_or_data == DataType + then markEpAnn an AnnData + else markEpAnn an AnnNewtype + markEpAnn an AnnInstance -- optional + mapM_ markAnnotated mb_ct + exactHdr context + case mb_sig of + Nothing -> return () + Just kind -> do + markEpAnn an AnnDcolon + markAnnotated kind + when (isGadt condecls) $ markEpAnn an AnnWhere + markEpAnn an AnnOpenC + exact_condecls an condecls + markEpAnn an AnnCloseC + mapM_ markAnnotated derivings + return () + + +exactVanillaDeclHead :: LocatedN RdrName + -> LHsQTyVars GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EPP () +exactVanillaDeclHead thing (HsQTvs { hsq_explicit = tyvars }) fixity context = do + let + exact_tyvars :: [LHsTyVarBndr () GhcPs] -> EPP () + exact_tyvars (varl:varsr) + | fixity == Infix && length varsr > 1 = do + -- = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) + -- , (ppr.unLoc) (head varsr), char ')' + -- , hsep (map (ppr.unLoc) (tail vaprsr))] + markAnnotated varl + markAnnotated thing + markAnnotated (head varsr) + markAnnotated (tail varsr) + return () + | fixity == Infix = do + -- = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) + -- , hsep (map (ppr.unLoc) varsr)] + markAnnotated varl + markAnnotated thing + markAnnotated varsr + return () + | otherwise = do + -- hsep [ pprPrefixOcc (unLoc thing) + -- , hsep (map (ppr.unLoc) (varl:varsr))] + markAnnotated thing + mapM_ markAnnotated (varl:varsr) + return () + exact_tyvars [] = do + -- pprPrefixOcc (unLoc thing) + markAnnotated thing + mapM_ markAnnotated context + exact_tyvars tyvars + +-- --------------------------------------------------------------------- + +instance ExactPrint (InjectivityAnn GhcPs) where + getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an + exact (InjectivityAnn an lhs rhs) = do + markEpAnn an AnnVbar + markAnnotated lhs + markEpAnn an AnnRarrow + mapM_ markAnnotated rhs + -- Just (L _ (InjectivityAnn _ lhs rhs)) -> + -- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + -- Nothing -> empty + +-- --------------------------------------------------------------------- + +class Typeable flag => ExactPrintTVFlag flag where + exactTVDelimiters :: EpAnn [AddEpAnn] -> flag -> Annotated () -> Annotated () + +instance ExactPrintTVFlag () where + exactTVDelimiters an _ thing_inside = do + markEpAnnAll an id AnnOpenP + thing_inside + markEpAnnAll an id AnnCloseP + +instance ExactPrintTVFlag Specificity where + exactTVDelimiters an s thing_inside = do + markEpAnnAll an id open + thing_inside + markEpAnnAll an id close + where + (open, close) = case s of + SpecifiedSpec -> (AnnOpenP, AnnCloseP) + InferredSpec -> (AnnOpenC, AnnCloseC) + +instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where + getAnnotationEntry (UserTyVar an _ _) = fromAnn an + getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an + + exact (UserTyVar an flag n) = + exactTVDelimiters an flag $ markAnnotated n + exact (KindedTyVar an flag n k) = exactTVDelimiters an flag $ do + markAnnotated n + markEpAnn an AnnDcolon + markAnnotated k + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsType GhcPs) where + getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal + getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal + getAnnotationEntry (HsTyVar an _ _) = fromAnn an + getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal + getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal + getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an + getAnnotationEntry (HsListTy an _) = fromAnn an + getAnnotationEntry (HsTupleTy an _ _) = fromAnn an + getAnnotationEntry (HsSumTy an _) = fromAnn an + getAnnotationEntry (HsOpTy _ _ _ _) = NoEntryVal + getAnnotationEntry (HsParTy an _) = fromAnn an + getAnnotationEntry (HsIParamTy an _ _) = fromAnn an + getAnnotationEntry (HsStarTy _ _) = NoEntryVal + getAnnotationEntry (HsKindSig an _ _) = fromAnn an + getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal + getAnnotationEntry (HsDocTy an _ _) = fromAnn an + getAnnotationEntry (HsBangTy an _ _) = fromAnn an + getAnnotationEntry (HsRecTy an _) = fromAnn an + getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an + getAnnotationEntry (HsExplicitTupleTy an _) = fromAnn an + getAnnotationEntry (HsTyLit _ _) = NoEntryVal + getAnnotationEntry (HsWildCardTy _) = NoEntryVal + getAnnotationEntry (XHsType _) = NoEntryVal + + + exact (HsForAllTy { hst_xforall = _an + , hst_tele = tele, hst_body = ty }) = do + markAnnotated tele + markAnnotated ty + + exact (HsQualTy _ ctxt ty) = do + markAnnotated ctxt + -- markEpAnn an AnnDarrow + markAnnotated ty + exact (HsTyVar an promoted name) = do + when (promoted == IsPromoted) $ markEpAnn an AnnSimpleQuote + markAnnotated name + + exact (HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2 + exact (HsAppKindTy ss ty ki) = do + markAnnotated ty + printStringAtSs ss "@" + markAnnotated ki + exact (HsFunTy an mult ty1 ty2) = do + markAnnotated ty1 + markArrow an mult + markAnnotated ty2 + exact (HsListTy an tys) = do + markOpeningParen an + markAnnotated tys + markClosingParen an + exact (HsTupleTy an _con tys) = do + markOpeningParen an + markAnnotated tys + markClosingParen an + exact (HsSumTy an tys) = do + markOpeningParen an + markAnnotated tys + markClosingParen an + exact (HsOpTy _an t1 lo t2) = do + markAnnotated t1 + markAnnotated lo + markAnnotated t2 + exact (HsParTy an ty) = do + markOpeningParen an + markAnnotated ty + markClosingParen an + exact (HsIParamTy an n t) = do + markAnnotated n + markEpAnn an AnnDcolon + markAnnotated t + exact (HsStarTy _an isUnicode) + = if isUnicode + then printStringAdvance "\x2605" -- Unicode star + else printStringAdvance "*" + exact (HsKindSig an ty k) = do + markAnnotated ty + markEpAnn an AnnDcolon + markAnnotated k + exact (HsSpliceTy _ splice) = do + markAnnotated splice + -- exact x@(HsDocTy an _ _) = withPpr x + exact (HsBangTy an (HsSrcBang mt _up str) ty) = do + case mt of + NoSourceText -> return () + SourceText src -> do + debugM $ "HsBangTy: src=" ++ showAst src + markLocatedAALS an id AnnOpen (Just src) + markLocatedAALS an id AnnClose (Just "#-}") + debugM $ "HsBangTy: done unpackedness" + case str of + SrcLazy -> markEpAnn an AnnTilde + SrcStrict -> markEpAnn an AnnBang + NoSrcStrict -> return () + markAnnotated ty + -- exact x@(HsRecTy an _) = withPpr x + exact (HsExplicitListTy an prom tys) = do + when (isPromoted prom) $ markEpAnn an AnnSimpleQuote + markEpAnn an AnnOpenS + markAnnotated tys + markEpAnn an AnnCloseS + exact (HsExplicitTupleTy an tys) = do + markEpAnn an AnnSimpleQuote + markEpAnn an AnnOpenP + markAnnotated tys + markEpAnn an AnnCloseP + exact (HsTyLit _ lit) = do + case lit of + (HsNumTy src v) -> printSourceText src (show v) + (HsStrTy src v) -> printSourceText src (show v) + (HsCharTy src v) -> printSourceText src (show v) + exact (HsWildCardTy _) = printStringAdvance "_" + exact x = error $ "missing match for HsType:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsForAllTelescope GhcPs) where + getAnnotationEntry (HsForAllVis an _) = fromAnn an + getAnnotationEntry (HsForAllInvis an _) = fromAnn an + + exact (HsForAllVis an bndrs) = do + markLocatedAA an fst -- AnnForall + markAnnotated bndrs + markLocatedAA an snd -- AnnRarrow + + exact (HsForAllInvis an bndrs) = do + markLocatedAA an fst -- AnnForall + markAnnotated bndrs + markLocatedAA an snd -- AnnDot + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDerivingClause GhcPs) where + getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d) + + exact (HsDerivingClause { deriv_clause_ext = an + , deriv_clause_strategy = dcs + , deriv_clause_tys = dct }) = do + -- = hsep [ text "deriving" + -- , pp_strat_before + -- , pp_dct dct + -- , pp_strat_after ] + markEpAnn an AnnDeriving + exact_strat_before + markAnnotated dct + exact_strat_after + where + -- -- This complexity is to distinguish between + -- -- deriving Show + -- -- deriving (Show) + -- pp_dct [HsIB { hsib_body = ty }] + -- = ppr (parenthesizeHsType appPrec ty) + -- pp_dct _ = parens (interpp'SP dct) + + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (exact_strat_before, exact_strat_after) = + case dcs of + Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v) + _ -> (mapM_ markAnnotated dcs, pure ()) + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivStrategy GhcPs) where + getAnnotationEntry (StockStrategy an) = fromAnn an + getAnnotationEntry (AnyclassStrategy an) = fromAnn an + getAnnotationEntry (NewtypeStrategy an) = fromAnn an + getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an + + exact (StockStrategy an) = markEpAnn an AnnStock + exact (AnyclassStrategy an) = markEpAnn an AnnAnyclass + exact (NewtypeStrategy an) = markEpAnn an AnnNewtype + exact (ViaStrategy (XViaStrategyPs an ty)) + = markEpAnn an AnnVia >> markAnnotated ty + +-- --------------------------------------------------------------------- + +instance (ExactPrint a) => ExactPrint (LocatedC a) where + getAnnotationEntry (L sann _) = fromAnn sann + + exact (L (SrcSpanAnn EpAnnNotUsed _) a) = markAnnotated a + exact (L (SrcSpanAnn (EpAnn _ (AnnContext ma opens closes) _) _) a) = do + -- case ma of + -- Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs + -- Just (NormalSyntax, rs) -> markKw' AnnDarrow rs + -- Nothing -> pure () + mapM_ (markKwA AnnOpenP) (sort opens) + markAnnotated a + mapM_ (markKwA AnnCloseP) (sort closes) + case ma of + Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r + Just (NormalSyntax, r) -> markKwA AnnDarrow r + Nothing -> pure () + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivClauseTys GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (DctSingle _ ty) = markAnnotated ty + exact (DctMulti _ tys) = do + -- parens (interpp'SP tys) + markAnnotated tys + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (HsSig _ bndrs ty) = do + markAnnotated bndrs + markAnnotated ty + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedN RdrName) where + getAnnotationEntry (L sann _) = fromAnn sann + + exact (L (SrcSpanAnn EpAnnNotUsed l) n) = do + p <- getPosP + debugM $ "LocatedN RdrName:NOANN: (p,l,str)=" ++ show (p,ss2range l, showPprUnsafe n) + let str = case (showPprUnsafe n) of + -- TODO: unicode support? + "forall" -> if spanLength (realSrcSpan l) == 1 then "∀" else "forall" + s -> s + printStringAtSs l str + exact (L (SrcSpanAnn (EpAnn _anchor ann _cs) _ll) n) = do + case ann of + NameAnn a o l c t -> do + markName a o (Just (l,n)) c + markTrailing t + NameAnnCommas a o cs c t -> do + let (kwo,kwc) = adornments a + markKw (AddEpAnn kwo o) + forM_ cs (\loc -> markKw (AddEpAnn AnnComma loc)) + markKw (AddEpAnn kwc c) + markTrailing t + NameAnnOnly a o c t -> do + markName a o Nothing c + markTrailing t + NameAnnRArrow nl t -> do + markKw (AddEpAnn AnnRarrow nl) + markTrailing t + NameAnnQuote q name t -> do + debugM $ "NameAnnQuote" + markKw (AddEpAnn AnnSimpleQuote q) + markAnnotated (L name n) + markTrailing t + NameAnnTrailing t -> do + printStringAdvance (showPprUnsafe n) + markTrailing t + +markName :: NameAdornment + -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation -> EPP () +markName adorn open mname close = do + let (kwo,kwc) = adornments adorn + markKw (AddEpAnn kwo open) + case mname of + Nothing -> return () + Just (name, a) -> printStringAtAA name (showPprUnsafe a) + markKw (AddEpAnn kwc close) + +adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId) +adornments NameParens = (AnnOpenP, AnnCloseP) +adornments NameParensHash = (AnnOpenPH, AnnClosePH) +adornments NameBackquotes = (AnnBackquote, AnnBackquote) +adornments NameSquare = (AnnOpenS, AnnCloseS) + +markTrailing :: [TrailingAnn] -> EPP () +markTrailing ts = do + p <- getPosP + debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) + mapM_ markKwT (sort ts) + +-- --------------------------------------------------------------------- + +-- based on pp_condecls in Decls.hs +exact_condecls :: EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EPP () +exact_condecls an cs + | gadt_syntax -- In GADT syntax + -- = hang (text "where") 2 (vcat (map ppr cs)) + = do + -- printStringAdvance "exact_condecls:gadt" + mapM_ markAnnotated cs + | otherwise -- In H98 syntax + -- = equals <+> sep (punctuate (text " |") (map ppr cs)) + = do + -- printStringAdvance "exact_condecls:not gadt" + markEpAnn an AnnEqual + mapM_ markAnnotated cs + where + gadt_syntax = case cs of + [] -> False + (L _ ConDeclH98{} : _) -> False + (L _ ConDeclGADT{} : _) -> True + +-- --------------------------------------------------------------------- + +instance ExactPrint (ConDecl GhcPs) where + getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x) + getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x) + +-- based on pprConDecl + exact (ConDeclH98 { con_ext = an + , con_name = con + , con_forall = has_forall + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) = do + -- = sep [ ppr_mbDoc doc + -- , pprHsForAll (mkHsForAllInvisTele ex_tvs) mcxt + -- , ppr_details args ] + mapM_ markAnnotated doc + when has_forall $ markEpAnn an AnnForall + mapM_ markAnnotated ex_tvs + when has_forall $ markEpAnn an AnnDot + -- exactHsForall (mkHsForAllInvisTele ex_tvs) mcxt + mapM_ markAnnotated mcxt + when (isJust mcxt) $ markEpAnn an AnnDarrow + + exact_details args + + -- case args of + -- InfixCon _ _ -> return () + -- _ -> markAnnotated con + where + -- -- In ppr_details: let's not print the multiplicities (they are always 1, by + -- -- definition) as they do not appear in an actual declaration. + exact_details (InfixCon t1 t2) = do + markAnnotated t1 + markAnnotated con + markAnnotated t2 + exact_details (PrefixCon tyargs tys) = do + markAnnotated con + markAnnotated tyargs + markAnnotated tys + exact_details (RecCon fields) = do + markAnnotated con + markAnnotated fields + + -- ----------------------------------- + + exact (ConDeclGADT { con_g_ext = an + , con_names = cons + , con_bndrs = bndrs + , con_mb_cxt = mcxt, con_g_args = args + , con_res_ty = res_ty, con_doc = doc }) = do + mapM_ markAnnotated doc + mapM_ markAnnotated cons + markEpAnn an AnnDcolon + annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] + -- when has_forall $ markEpAnn an AnnForall + markAnnotated bndrs + -- mapM_ markAnnotated qvars + -- when has_forall $ markEpAnn an AnnDot + mapM_ markAnnotated mcxt + when (isJust mcxt) $ markEpAnn an AnnDarrow + -- mapM_ markAnnotated args + case args of + (PrefixConGADT args') -> mapM_ markScaled args' + (RecConGADT fields) -> markAnnotated fields + -- mapM_ markAnnotated (unLoc fields) + markAnnotated res_ty + +-- --------------------------------------------------------------------- + +instance ExactPrint Void where + getAnnotationEntry = const NoEntryVal + exact _ = return () + +-- --------------------------------------------------------------------- + +instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where + getAnnotationEntry (HsOuterImplicit _) = NoEntryVal + getAnnotationEntry (HsOuterExplicit an _) = fromAnn an + + exact (HsOuterImplicit _) = pure () + exact (HsOuterExplicit an bndrs) = do + markLocatedAA an fst -- "forall" + markAnnotated bndrs + markLocatedAA an snd -- "." + +-- --------------------------------------------------------------------- + +instance ExactPrint (ConDeclField GhcPs) where + getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f) + + exact (ConDeclField an names ftype mdoc) = do + markAnnotated names + markEpAnn an AnnDcolon + markAnnotated ftype + mapM_ markAnnotated mdoc + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldOcc GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (FieldOcc _ n) = markAnnotated n + +-- --------------------------------------------------------------------- + +instance ExactPrint (AmbiguousFieldOcc GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (Unambiguous _ n) = markAnnotated n + exact (Ambiguous _ n) = markAnnotated n + +-- --------------------------------------------------------------------- + +markScaled :: (HsScaled GhcPs (LBangType GhcPs)) -> Annotated () +markScaled (HsScaled arr (L l c)) = + markAnnotated ((L l (HsScaled arr (L (noAnnSrcSpan $ locA l) c))) + :: LocatedA (HsScaled GhcPs (LBangType GhcPs))) + +instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where + getAnnotationEntry = const NoEntryVal + exact (HsScaled arr t) = do + markAnnotated t + markArrow EpAnnNotUsed arr + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (LHsContext GhcPs) where +-- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann +-- exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP CType) where + getAnnotationEntry = entryFromLocatedA + + exact (L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct + exact (L (SrcSpanAnn an _ll) + (CType stp mh (stct,ct))) = do + markAnnOpenP an stp "{-# CTYPE" + case mh of + Nothing -> return () + Just (Header srcH _h) -> + markLocatedAALS an apr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" "")) + markLocatedAALS an apr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) "")) + markAnnCloseP an + +-- --------------------------------------------------------------------- + +instance ExactPrint (SourceText, RuleName) where + -- We end up at the right place from the Located wrapper + getAnnotationEntry = const NoEntryVal + + exact (st, rn) + = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") + + +-- ===================================================================== +-- LocatedL instances start -- +-- +-- Each is dealt with specifically, as they have +-- different wrapping annotations in the al_rest zone. +-- +-- In future, the annotation could perhaps be improved, with an +-- 'al_pre' and 'al_post' set of annotations to be simply sorted and +-- applied. +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + + exact (L (SrcSpanAnn ann _) ies) = do + debugM $ "LocatedL [LIE" + markLocatedAAL ann al_rest AnnHiding + p <- getPosP + debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p + markAnnList True ann (markAnnotated ies) + +instance (ExactPrint (Match GhcPs (LocatedA body))) + => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where + getAnnotationEntry = entryFromLocatedA + exact (L la a) = do + debugM $ "LocatedL [LMatch" + -- TODO: markAnnList? + markEpAnnAll (ann la) al_rest AnnWhere + markLocatedMAA (ann la) al_open + markEpAnnAll (ann la) al_rest AnnSemi + markAnnotated a + markLocatedMAA (ann la) al_close + +-- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where +instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where + getAnnotationEntry = entryFromLocatedAFixed + exact (L (SrcSpanAnn an' _) stmts) = do + let an = fixAnnListAnn an' + debugM $ "LocatedL [ExprLStmt" + markAnnList True an $ do + -- markLocatedMAA an al_open + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + markAnnotated ls + markAnnotated initStmts + _ -> markAnnotated stmts + -- x -> error $ "pprDo:ListComp" ++ showAst x + -- markLocatedMAA an al_close + +-- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where +instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where + getAnnotationEntry = entryFromLocatedAFixed + exact (L (SrcSpanAnn ann' _) es) = do + let ann = fixAnnListAnn ann' + debugM $ "LocatedL [CmdLStmt" + markLocatedMAA ann al_open + mapM_ markAnnotated es + markLocatedMAA ann al_close + +instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn an _) fs) = do + debugM $ "LocatedL [LConDeclField" + markAnnList True an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_ + +instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn an _) bf) = do + debugM $ "LocatedL [LBooleanFormula" + markAnnList True an (markAnnotated bf) + +-- --------------------------------------------------------------------- +-- LocatedL instances end -- +-- ===================================================================== + +instance ExactPrint (IE GhcPs) where + getAnnotationEntry (IEVar _ _) = NoEntryVal + getAnnotationEntry (IEThingAbs an _) = fromAnn an + getAnnotationEntry (IEThingAll an _) = fromAnn an + getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an + getAnnotationEntry (IEModuleContents an _)= fromAnn an + getAnnotationEntry (IEGroup _ _ _) = NoEntryVal + getAnnotationEntry (IEDoc _ _) = NoEntryVal + getAnnotationEntry (IEDocNamed _ _) = NoEntryVal + + exact (IEVar _ ln) = markAnnotated ln + exact (IEThingAbs _ thing) = markAnnotated thing + exact (IEThingAll an thing) = do + markAnnotated thing + markEpAnn an AnnOpenP + markEpAnn an AnnDotdot + markEpAnn an AnnCloseP + + exact (IEThingWith an thing wc withs) = do + markAnnotated thing + markEpAnn an AnnOpenP + case wc of + NoIEWildcard -> markAnnotated withs + IEWildcard pos -> do + let (bs, as) = splitAt pos withs + markAnnotated bs + markEpAnn an AnnDotdot + markEpAnn an AnnComma + markAnnotated as + markEpAnn an AnnCloseP + + exact (IEModuleContents an (L lm mn)) = do + markEpAnn an AnnModule + printStringAtSs lm (moduleNameString mn) + + -- exact (IEGroup _ _ _) = NoEntryVal + -- exact (IEDoc _ _) = NoEntryVal + -- exact (IEDocNamed _ _) = NoEntryVal + exact x = error $ "missing match for IE:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (IEWrappedName RdrName) where + getAnnotationEntry = const NoEntryVal + + exact (IEName n) = markAnnotated n + exact (IEPattern r n) = do + printStringAtAA r "pattern" + markAnnotated n + exact (IEType r n) = do + printStringAtAA r "type" + markAnnotated n + +-- markIEWrapped :: EpAnn -> LIEWrappedName RdrName -> EPP () +-- markIEWrapped an (L _ (IEName n)) +-- = markAnnotated n +-- markIEWrapped an (L _ (IEPattern n)) +-- = markEpAnn an AnnPattern >> markAnnotated n +-- markIEWrapped an (L _ (IEType n)) +-- = markEpAnn an AnnType >> markAnnotated n + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (LocatedA (Pat GhcPs)) where +-- -- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann +-- getAnnotationEntry = entryFromLocatedA +-- exact (L _ a) = do +-- debugM $ "exact:LPat:" ++ showPprUnsafe a +-- markAnnotated a + +instance ExactPrint (Pat GhcPs) where + getAnnotationEntry (WildPat _) = NoEntryVal + getAnnotationEntry (VarPat _ _) = NoEntryVal + getAnnotationEntry (LazyPat an _) = fromAnn an + getAnnotationEntry (AsPat an _ _) = fromAnn an + getAnnotationEntry (ParPat an _) = fromAnn an + getAnnotationEntry (BangPat an _) = fromAnn an + getAnnotationEntry (ListPat an _) = fromAnn an + getAnnotationEntry (TuplePat an _ _) = fromAnn an + getAnnotationEntry (SumPat an _ _ _) = fromAnn an + getAnnotationEntry (ConPat an _ _) = fromAnn an + getAnnotationEntry (ViewPat an _ _) = fromAnn an + getAnnotationEntry (SplicePat _ _) = NoEntryVal + getAnnotationEntry (LitPat _ _) = NoEntryVal + getAnnotationEntry (NPat an _ _ _) = fromAnn an + getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an + getAnnotationEntry (SigPat an _ _) = fromAnn an + + exact (WildPat _) = do + anchor <- getAnchorU + debugM $ "WildPat:anchor=" ++ show anchor + printStringAtRs anchor "_" + exact (VarPat _ n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered. + let pun_RDR = "pun-right-hand-side" + when (showPprUnsafe n /= pun_RDR) $ markAnnotated n + exact (LazyPat an pat) = do + markEpAnn an AnnTilde + markAnnotated pat + exact (AsPat an n pat) = do + markAnnotated n + markEpAnn an AnnAt + markAnnotated pat + exact (ParPat an pat) = do + markAnnKw an ap_open AnnOpenP + markAnnotated pat + markAnnKw an ap_close AnnCloseP + + exact (BangPat an pat) = do + markEpAnn an AnnBang + markAnnotated pat + + exact (ListPat an pats) = markAnnList True an (markAnnotated pats) + + exact (TuplePat an pats boxity) = do + case boxity of + Boxed -> markEpAnn an AnnOpenP + Unboxed -> markEpAnn an AnnOpenPH + markAnnotated pats + case boxity of + Boxed -> markEpAnn an AnnCloseP + Unboxed -> markEpAnn an AnnClosePH + + exact (SumPat an pat _alt _arity) = do + markLocatedAAL an sumPatParens AnnOpenPH + markAnnKwAll an sumPatVbarsBefore AnnVbar + markAnnotated pat + markAnnKwAll an sumPatVbarsAfter AnnVbar + markLocatedAAL an sumPatParens AnnClosePH + + -- | ConPat an con args) + exact (ConPat an con details) = exactUserCon an con details + exact (ViewPat an expr pat) = do + markAnnotated expr + markEpAnn an AnnRarrow + markAnnotated pat + exact (SplicePat _ splice) = markAnnotated splice + exact (LitPat _ lit) = printStringAdvance (hsLit2String lit) + exact (NPat an ol mn _) = do + when (isJust mn) $ markEpAnn an AnnMinus + markAnnotated ol + + -- | NPlusKPat an n lit1 lit2 _ _) + exact (NPlusKPat an n k lit2 _ _) = do + markAnnotated n + -- We need a fix for + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20243 to complete + -- this + markAnnotated k + + exact (SigPat an pat sig) = do + markAnnotated pat + markEpAnn an AnnDcolon + markAnnotated sig + -- exact x = error $ "missing match for Pat:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsPatSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (HsPS an ty) = do + markAnnKw an id AnnAt + markAnnotated ty + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsOverLit GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact ol = + let str = case ol_val ol of + HsIntegral (IL src _ _) -> src + HsFractional (FL{ fl_text = src }) -> src + HsIsString src _ -> src + in + case str of + SourceText s -> printStringAdvance s + NoSourceText -> return () + +-- --------------------------------------------------------------------- + +hsLit2String :: HsLit GhcPs -> String +hsLit2String lit = + case lit of + HsChar src v -> toSourceTextWithSuffix src v "" + -- It should be included here + -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 + HsCharPrim src p -> toSourceTextWithSuffix src p "#" + HsString src v -> toSourceTextWithSuffix src v "" + HsStringPrim src v -> toSourceTextWithSuffix src v "" + HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" + HsIntPrim src v -> toSourceTextWithSuffix src v "" + HsWordPrim src v -> toSourceTextWithSuffix src v "" + HsInt64Prim src v -> toSourceTextWithSuffix src v "" + HsWord64Prim src v -> toSourceTextWithSuffix src v "" + HsInteger src v _ -> toSourceTextWithSuffix src v "" + HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" + HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" + HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" + -- (XLit x) -> error $ "got XLit for:" ++ showPprUnsafe x + +toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String +toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix +toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix + +sourceTextToString :: SourceText -> String -> String +sourceTextToString NoSourceText alt = alt +sourceTextToString (SourceText txt) _ = txt + +-- --------------------------------------------------------------------- + +exactUserCon :: (ExactPrint con) => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs -> EPP () +exactUserCon _ c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2 +exactUserCon an c details = do + markAnnotated c + markEpAnn an AnnOpenC + exactConArgs details + markEpAnn an AnnCloseC + + +exactConArgs ::HsConPatDetails GhcPs -> EPP () +exactConArgs (PrefixCon tyargs pats) = markAnnotated tyargs >> markAnnotated pats +exactConArgs (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated p2 +exactConArgs (RecCon rpats) = markAnnotated rpats + +-- --------------------------------------------------------------------- + +entryFromLocatedA :: LocatedAn ann a -> Entry +entryFromLocatedA (L la _) = fromAnn la + +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 +entryFromLocatedAFixed :: LocatedL a -> Entry +entryFromLocatedAFixed (L la _) + = fromAnn (fixSrcAnnL la) + +-- ===================================================================== +-- Utility stuff +-- --------------------------------------------------------------------- + +-- |This should be the final point where things are mode concrete, +-- before output. +-- NOTE: despite the name, this is the ghc-exactprint final output for +-- the PRINT phase. +printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m () +printStringAtLsDelta cl s = do + p <- getPosP + colOffset <- getLayoutOffsetP + if isGoodDeltaWithOffset cl colOffset + then do + printStringAt (undelta p cl colOffset) s + `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) + else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) + +-- --------------------------------------------------------------------- + +isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool +isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c) + where (l,c) = undelta (0,0) dp colOffset + +printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m () +printQueuedComment loc Comment{commentContents} dp = do + p <- getPosP + colOffset <- getLayoutOffsetP + let (dr,dc) = undelta (0,0) dp colOffset + -- do not lose comments against the left margin + when (isGoodDelta (deltaPos dr (max 0 dc))) $ do + printCommentAt (undelta p dp colOffset) commentContents + setPriorEndASTD False loc + p' <- getPosP + debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) + +{- +-- Print version +printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +printQueuedComment Comment{commentContents} dp = do + p <- getPos + colOffset <- getLayoutOffset + let (dr,dc) = undelta (0,0) dp colOffset + -- do not lose comments against the left margin + when (isGoodDelta (DP (dr,max 0 dc))) $ + printCommentAt (undelta p dp colOffset) commentContents + +-} + +-- --------------------------------------------------------------------- + +-- withContext :: (Monad m, Monoid w) +-- => [(KeywordId, DeltaPos)] +-- -> Annotation +-- -> EP w m a -> EP w m a +-- withContext kds an x = withKds kds (withOffset an x) + +-- --------------------------------------------------------------------- +-- +-- | Given an annotation associated with a specific SrcSpan, +-- determines a new offset relative to the previous offset +-- +withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) +withOffset a = + local (\s -> s { epAnn = a }) + +------------------------------------------------------------------------ + +setLayoutBoth :: (Monad m, Monoid w) => EP w m () -> EP w m () +setLayoutBoth k = do + oldLHS <- gets dLHS + oldAnchorOffset <- getLayoutOffsetP + debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = True + , pMarkLayout = True } ) + let reset = do + debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = False + , dLHS = oldLHS + , pMarkLayout = False + , pLHS = oldAnchorOffset} ) + k <* reset + +-- Use 'local', designed for this +setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m () -> EP w m () +setLayoutTopLevelP k = do + debugM $ "setLayoutTopLevelP entered" + oldAnchorOffset <- getLayoutOffsetP + modify (\a -> a { pMarkLayout = False + , pLHS = 0} ) + k + debugM $ "setLayoutTopLevelP:resetting" + setLayoutOffsetP oldAnchorOffset + +------------------------------------------------------------------------ + +getPosP :: (Monad m, Monoid w) => EP w m Pos +getPosP = gets epPos + +setPosP :: (Monad m, Monoid w) => Pos -> EP w m () +setPosP l = do + -- debugM $ "setPosP:" ++ show l + modify (\s -> s {epPos = l}) + +getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor) +getExtraDP = gets uExtraDP + +setExtraDP :: (Monad m, Monoid w) => Maybe Anchor -> EP w m () +setExtraDP md = do + debugM $ "setExtraDP:" ++ show md + modify (\s -> s {uExtraDP = md}) + +getPriorEndD :: (Monad m, Monoid w) => EP w m Pos +getPriorEndD = gets dPriorEndPosition + +getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan +getAnchorU = gets uAnchorSpan + +setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndD pe = do + -- setLayoutStartIfNeededD (snd pe) + setPriorEndNoLayoutD pe + +setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndNoLayoutD pe = do + debugM $ "setPriorEndNoLayout:pe=" ++ show pe + modify (\s -> s { dPriorEndPosition = pe }) + +setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m () +setPriorEndASTD layout pe = setPriorEndASTPD layout (rs2range pe) + +setPriorEndASTPD :: (Monad m, Monoid w) => Bool -> (Pos,Pos) -> EP w m () +setPriorEndASTPD layout pe@(fm,to) = do + debugM $ "setPriorEndASTD:pe=" ++ show pe + when layout $ setLayoutStartD (snd fm) + modify (\s -> s { dPriorEndPosition = to } ) + +setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m () +setLayoutStartD p = do + EPState{dMarkLayout} <- get + when dMarkLayout $ do + debugM $ "setLayoutStartD: setting dLHS=" ++ show p + modify (\s -> s { dMarkLayout = False + , dLHS = LayoutStartCol p}) + +setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +setAnchorU rss = do + debugM $ "setAnchorU:" ++ show (rs2range rss) + modify (\s -> s { uAnchorSpan = rss }) + +getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] +getUnallocatedComments = gets epComments + +putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m () +putUnallocatedComments cs = modify (\s -> s { epComments = cs } ) + +getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol +getLayoutOffsetP = gets pLHS + +setLayoutOffsetP :: (Monad m, Monoid w) => LayoutStartCol -> EP w m () +setLayoutOffsetP c = do + debugM $ "setLayoutOffsetP:" ++ show c + modify (\s -> s { pLHS = c }) + + +-- --------------------------------------------------------------------- +------------------------------------------------------------------------- +-- |First move to the given location, then call exactP +-- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a +-- exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) +-- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a +-- exactPC ast action = +-- do +-- return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast)) +-- ma <- getAndRemoveAnnotation ast +-- let an@Ann{ annEntryDelta=edp +-- , annPriorComments=comments +-- , annFollowingComments=fcomments +-- , annsDP=kds +-- } = fromMaybe annNone ma +-- PrintOptions{epAstPrint} <- ask +-- r <- withContext kds an +-- (mapM_ (uncurry printQueuedComment) comments +-- >> advance edp +-- >> censorM (epAstPrint ast) action +-- <* mapM_ (uncurry printQueuedComment) fcomments) +-- return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast)) + +-- censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a +-- censorM f m = passM (liftM (\x -> (x,f)) m) + +-- passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a +-- passM m = RWST $ \r s -> do +-- ~((a, f),s', EPWriter w) <- runRWST m r s +-- w' <- f w +-- return (a, s', EPWriter w') + +advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () +advance dp = do + p <- getPosP + colOffset <- getLayoutOffsetP + debugM $ "advance:(p,dp,colOffset,ws)=" ++ show (p,dp,colOffset,undelta p dp colOffset) + printWhitespace (undelta p dp colOffset) + +{- +Version from Print.advance +advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () +advance cl = do + p <- getPos + colOffset <- getLayoutOffset + printWhitespace (undelta p cl colOffset) +-} + +-- --------------------------------------------------------------------- + +adjustDeltaForOffsetM :: DeltaPos -> EPP DeltaPos +adjustDeltaForOffsetM dp = do + colOffset <- gets dLHS + return (adjustDeltaForOffset 0 colOffset dp) + +-- --------------------------------------------------------------------- +-- Printing functions + +printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () +printString layout str = do + EPState{epPos = (_,c), pMarkLayout} <- get + PrintOptions{epTokenPrint, epWhitespacePrint} <- ask + when (pMarkLayout && layout) $ do + debugM $ "printString: setting pLHS to " ++ show c + modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } ) + + -- Advance position, taking care of any newlines in the string + let strDP = dpFromString str + cr = getDeltaLine strDP + p <- getPosP + colOffset <- getLayoutOffsetP + -- debugM $ "printString:(p,colOffset,strDP,cr)=" ++ show (p,colOffset,strDP,cr) + if cr == 0 + then setPosP (undelta p strDP colOffset) + else setPosP (undelta p strDP 1) + + -- Debug stuff + -- pp <- getPosP + -- debugM $ "printString: (p,pp,str)" ++ show (p,pp,str) + -- Debug end + + -- + if not layout && c == 0 + then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} + else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} + + +{- + +-- Print.printString +printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () +printString layout str = do + EPState{epPos = (_,c), epMarkLayout} <- get + PrintOptions{epTokenPrint, epWhitespacePrint} <- ask + when (epMarkLayout && layout) $ + modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ) + + -- Advance position, taking care of any newlines in the string + let strDP@(DP (cr,_cc)) = dpFromString str + p <- getPos + colOffset <- getLayoutOffset + if cr == 0 + then setPos (undelta p strDP colOffset) + else setPos (undelta p strDP 1) + + -- + if not layout && c == 0 + then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} + else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} + +-} + +-------------------------------------------------------- + +printStringAdvance :: String -> EPP () +printStringAdvance str = do + ss <- getAnchorU + printStringAtKw' ss str + +-------------------------------------------------------- + +newLine :: (Monad m, Monoid w) => EP w m () +newLine = do + (l,_) <- getPosP + printString False "\n" + setPosP (l+1,1) + +padUntil :: (Monad m, Monoid w) => Pos -> EP w m () +padUntil (l,c) = do + (l1,c1) <- getPosP + if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' ' + | l1 < l -> newLine >> padUntil (l,c) + | otherwise -> return () + +printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m () +printWhitespace = padUntil + +printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () +printCommentAt p str = do + debugM $ "printCommentAt: (pos,str)" ++ show (p,str) + printWhitespace p >> printString False str + +printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () +printStringAt p str = printWhitespace p >> printString True str diff --git a/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs b/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# 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 -import Lexer -import SrcLoc - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 800 -#else --- From Lexer.x -commentToAnnotation :: Located Token -> Located AnnotationComment -commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) -commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) -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 @@ -1,17 +1,12 @@ -{-# LANGUAGE CPP #-} module Language.Haskell.GHC.ExactPrint.Lookup ( keywordToString -#if __GLASGOW_HASKELL__ <= 710 - , unicodeString -#endif + , KeywordId(..) + , Comment(..) ) where +import GHC (AnnKeywordId(..)) import Language.Haskell.GHC.ExactPrint.Types -import qualified GHC (AnnKeywordId(..)) -#if __GLASGOW_HASKELL__ <= 710 -import Data.Maybe -#endif -- | Maps `AnnKeywordId` to the corresponding String representation. -- There is no specific mapping for the following constructors. @@ -26,194 +21,109 @@ -- warnings if new constructors are added. AnnComment _ -> mkErr kw AnnString _ -> mkErr kw -#if __GLASGOW_HASKELL__ >= 900 - (AnnEofPos ) -> mkErr kw -#endif -#if __GLASGOW_HASKELL__ <= 710 - AnnUnicode kw' -> keywordToString (G kw') -#endif 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 - (G GHC.AnnPackageName) -> mkErr kw - (G GHC.AnnHeader ) -> mkErr kw - (G GHC.AnnFunId ) -> mkErr kw - (G GHC.AnnInfix ) -> mkErr kw - (G GHC.AnnValStr ) -> mkErr kw - (G GHC.AnnName ) -> mkErr kw - (G GHC.AnnAs ) -> "as" - (G GHC.AnnAt ) -> "@" - (G GHC.AnnBang ) -> "!" - (G GHC.AnnBackquote ) -> "`" - (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 ) -> "," - (G GHC.AnnCommaTuple ) -> "," - (G GHC.AnnDarrow ) -> "=>" - (G GHC.AnnData ) -> "data" - (G GHC.AnnDcolon ) -> "::" - (G GHC.AnnDefault ) -> "default" - (G GHC.AnnDeriving ) -> "deriving" - (G GHC.AnnDo ) -> "do" - (G GHC.AnnDot ) -> "." - (G GHC.AnnDotdot ) -> ".." - (G GHC.AnnElse ) -> "else" - (G GHC.AnnEqual ) -> "=" - (G GHC.AnnExport ) -> "export" - (G GHC.AnnFamily ) -> "family" - (G GHC.AnnForall ) -> "forall" - (G GHC.AnnForeign ) -> "foreign" - (G GHC.AnnGroup ) -> "group" - (G GHC.AnnHiding ) -> "hiding" - (G GHC.AnnIf ) -> "if" - (G GHC.AnnImport ) -> "import" - (G GHC.AnnIn ) -> "in" - (G GHC.AnnInstance ) -> "instance" - (G GHC.AnnLam ) -> "\\" - (G GHC.AnnLarrow ) -> "<-" - (G GHC.AnnLet ) -> "let" -#if __GLASGOW_HASKELL__ >= 900 - -- (G GHC.AnnLolly ) -> "#->" - (G GHC.AnnLollyU ) -> "⊸" -#endif - (G GHC.AnnMdo ) -> "mdo" - (G GHC.AnnMinus ) -> "-" - (G GHC.AnnModule ) -> "module" -#if __GLASGOW_HASKELL__ >= 900 - (G GHC.AnnPercent ) -> "%" - (G GHC.AnnPercentOne) -> "%1" -#endif - (G GHC.AnnNewtype ) -> "newtype" - (G GHC.AnnOf ) -> "of" -#if __GLASGOW_HASKELL__ >= 801 - (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 ) -> "(" -#if __GLASGOW_HASKELL__ < 900 - (G GHC.AnnOpenPE ) -> "$(" - (G GHC.AnnOpenPTE ) -> "$$(" -#endif - (G GHC.AnnOpenS ) -> "[" - (G GHC.AnnPattern ) -> "pattern" - (G GHC.AnnProc ) -> "proc" - (G GHC.AnnQualified ) -> "qualified" - (G GHC.AnnRarrow ) -> "->" - (G GHC.AnnRec ) -> "rec" - (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 ) -> "~" -#if __GLASGOW_HASKELL__ <= 804 - (G GHC.AnnTildehsh ) -> "~#" -#endif - (G GHC.AnnType ) -> "type" - (G GHC.AnnUnit ) -> "()" - (G GHC.AnnUsing ) -> "using" - (G GHC.AnnVbar ) -> "|" - (G GHC.AnnWhere ) -> "where" - (G GHC.Annlarrowtail ) -> "-<" - (G GHC.Annrarrowtail ) -> ">-" - (G GHC.AnnLarrowtail ) -> "-<<" - (G GHC.AnnRarrowtail ) -> ">>-" - (G GHC.AnnSimpleQuote ) -> "'" - (G GHC.AnnThTyQuote ) -> "''" -#if __GLASGOW_HASKELL__ >= 900 - (G GHC.AnnDollar ) -> "$" - (G GHC.AnnDollarDollar ) -> "$$" -#else - (G GHC.AnnThIdSplice ) -> "$" - (G GHC.AnnThIdTySplice ) -> "$$" -#endif -#if __GLASGOW_HASKELL__ < 900 - (G GHC.AnnEofPos ) -> "" -#endif -#if __GLASGOW_HASKELL__ > 710 - (G GHC.AnnDarrowU) -> "⇒" - (G GHC.AnnDcolonU) -> "∷" - (G GHC.AnnForallU) -> "∀" - (G GHC.AnnLarrowU) -> "←" - (G GHC.AnnLarrowtailU) -> "⤛" - (G GHC.AnnRarrowU) -> "→" - (G GHC.AnnRarrowtailU) -> "⤜" - (G GHC.AnnlarrowtailU) -> "⤙" - (G GHC.AnnrarrowtailU) -> "⤚" -#endif -#if __GLASGOW_HASKELL__ >= 800 + (G AnnAnyclass) -> "anyclass" + (G AnnOpen ) -> mkErr kw + (G AnnClose ) -> mkErr kw + (G AnnVal ) -> mkErr kw + (G AnnPackageName) -> mkErr kw + (G AnnHeader ) -> mkErr kw + (G AnnFunId ) -> mkErr kw + (G AnnInfix ) -> mkErr kw + (G AnnValStr ) -> mkErr kw + (G AnnName ) -> mkErr kw + (G AnnAs ) -> "as" + (G AnnAt ) -> "@" + (G AnnBang ) -> "!" + (G AnnBackquote ) -> "`" + (G AnnBy ) -> "by" + (G AnnCase ) -> "case" + (G AnnClass ) -> "class" + (G AnnCloseB ) -> "|)" + (G AnnCloseBU ) -> "⦈" + (G AnnCloseC ) -> "}" + (G AnnCloseP ) -> ")" + (G AnnClosePH ) -> "#)" + (G AnnCloseQ ) -> "|]" + (G AnnCloseQU ) -> "⟧" + (G AnnCloseS ) -> "]" + (G AnnColon ) -> ":" + (G AnnComma ) -> "," + (G AnnCommaTuple ) -> "," + (G AnnDarrow ) -> "=>" + (G AnnData ) -> "data" + (G AnnDcolon ) -> "::" + (G AnnDefault ) -> "default" + (G AnnDeriving ) -> "deriving" + (G AnnDo ) -> "do" + (G AnnDot ) -> "." + (G AnnDotdot ) -> ".." + (G AnnElse ) -> "else" + (G AnnEqual ) -> "=" + (G AnnExport ) -> "export" + (G AnnFamily ) -> "family" + (G AnnForall ) -> "forall" + (G AnnForeign ) -> "foreign" + (G AnnGroup ) -> "group" + (G AnnHiding ) -> "hiding" + (G AnnIf ) -> "if" + (G AnnImport ) -> "import" + (G AnnIn ) -> "in" + (G AnnInstance ) -> "instance" + (G AnnLam ) -> "\\" + (G AnnLarrow ) -> "<-" + (G AnnLet ) -> "let" + (G AnnLollyU ) -> "⊸" + (G AnnMdo ) -> "mdo" + (G AnnMinus ) -> "-" + (G AnnModule ) -> "module" + (G AnnNewtype ) -> "newtype" + (G AnnOf ) -> "of" + (G AnnOpenB ) -> "(|" + (G AnnOpenBU ) -> "⦇" + (G AnnOpenC ) -> "{" + (G AnnOpenE ) -> "[e|" + (G AnnOpenEQ ) -> "[|" + (G AnnOpenEQU ) -> "⟦" + (G AnnOpenP ) -> "(" + (G AnnOpenPH ) -> "(#" + (G AnnOpenS ) -> "[" + (G AnnPattern ) -> "pattern" + (G AnnPercent ) -> "%" + (G AnnPercentOne) -> "%1" + (G AnnProc ) -> "proc" + (G AnnQualified ) -> "qualified" + (G AnnRarrow ) -> "->" + (G AnnRec ) -> "rec" + (G AnnRole ) -> "role" + (G AnnSafe ) -> "safe" + (G AnnSemi ) -> ";" + (G AnnSignature) -> "signature" + (G AnnStock ) -> "stock" + (G AnnStatic ) -> "static" + (G AnnThen ) -> "then" + (G AnnTilde ) -> "~" + (G AnnType ) -> "type" + (G AnnUnit ) -> "()" + (G AnnUsing ) -> "using" + (G AnnVbar ) -> "|" + (G AnnWhere ) -> "where" + (G Annlarrowtail ) -> "-<" + (G Annrarrowtail ) -> ">-" + (G AnnLarrowtail ) -> "-<<" + (G AnnRarrowtail ) -> ">>-" + (G AnnSimpleQuote ) -> "'" + (G AnnThTyQuote ) -> "''" + (G AnnDollar ) -> "$" + (G AnnDollarDollar ) -> "$$" + (G AnnDarrowU) -> "⇒" + (G AnnDcolonU) -> "∷" + (G AnnForallU) -> "∀" + (G AnnLarrowU) -> "←" + (G AnnLarrowtailU) -> "⤛" + (G AnnRarrowU) -> "→" + (G AnnRarrowtailU) -> "⤜" + (G AnnlarrowtailU) -> "⤙" + (G AnnrarrowtailU) -> "⤚" AnnTypeApp -> "@" -#endif -#if __GLASGOW_HASKELL__ > 804 - (G GHC.AnnVia) -> "via" -#endif - -#if __GLASGOW_HASKELL__ <= 710 --- | Tries to find a unicode equivalent to a 'KeywordId'. --- If none exists then fall back to find the ASCII version. -unicodeString :: KeywordId -> String -unicodeString kw = - fromMaybe (keywordToString kw) (lookup kw unicodeChars) - -unicodeChars :: [(KeywordId, String)] -unicodeChars = - -- AZ:TODO:make this a Data.Map, doing linear scan each time - [ (G GHC.AnnDarrow, "⇒") - , (G GHC.AnnDcolon, "∷") - , (G GHC.AnnForall, "∀") - , (G GHC.AnnLarrow, "←") - , (G GHC.AnnLarrowtail, "⤛") - , (G GHC.AnnRarrow, "→") - , (G GHC.AnnRarrowtail, "⤜") - , (G GHC.Annlarrowtail, "⤙") - , (G GHC.Annrarrowtail, "⤚") - ] - -{- -From Lexer.x - - ,("∷", ITdcolon, unicodeSyntaxEnabled) - ,("⇒", ITdarrow, unicodeSyntaxEnabled) - ,("∀", ITforall, unicodeSyntaxEnabled) - ,("→", ITrarrow, unicodeSyntaxEnabled) - ,("←", ITlarrow, unicodeSyntaxEnabled) - - ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) - - ,("★", ITstar, unicodeSyntaxEnabled) - --} - -#endif + (G AnnVia) -> "via" diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs --- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- @@ -16,6 +15,7 @@ , withDynFlags , CppOptions(..) , defaultCppOptions + , LibDir -- * Module Parsers , parseModule @@ -40,72 +40,31 @@ , initDynFlags , initDynFlagsPure , parseModuleFromStringInternal - , parseModuleApiAnnsWithCpp - , parseModuleApiAnnsWithCppInternal + , parseModuleEpAnnsWithCpp + , parseModuleEpAnnsWithCppInternal , postParseTransform ) where -import Language.Haskell.GHC.ExactPrint.Annotate -import Language.Haskell.GHC.ExactPrint.Delta import Language.Haskell.GHC.ExactPrint.Preprocess -import Language.Haskell.GHC.ExactPrint.Types -import Control.Exception (IOException, catch) import Control.Monad.RWS -#if __GLASGOW_HASKELL__ >= 900 -#elif __GLASGOW_HASKELL__ > 806 -import Data.Data (Data) -#endif -import Data.Maybe (fromMaybe) - -import GHC.Paths (libdir) - -import System.Environment (lookupEnv) - import qualified GHC hiding (parseModule) -#if __GLASGOW_HASKELL__ >= 900 import qualified Control.Monad.IO.Class as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Driver.Config as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.Parser as GHC import qualified GHC.Parser.Header as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Parser.PostProcess as GHC +import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Error as GHC -#else --- import qualified ApiAnnotation as GHC -import qualified DynFlags as GHC -#if __GLASGOW_HASKELL__ > 808 -import qualified ErrUtils as GHC -#endif -import qualified FastString as GHC --- import qualified GHC as GHC hiding (parseModule) -import qualified HeaderInfo as GHC -import qualified Lexer as GHC -import qualified MonadUtils as GHC -#if __GLASGOW_HASKELL__ <= 808 -import qualified Outputable as GHC -#endif -import qualified Parser as GHC -#if __GLASGOW_HASKELL__ > 808 -import qualified RdrHsSyn as GHC -#endif -import qualified SrcLoc as GHC -import qualified StringBuffer as GHC -#endif -#if __GLASGOW_HASKELL__ <= 710 -import qualified OrdList as OL -#else import qualified GHC.LanguageExtensions as LangExt -#endif -import qualified Data.Map as Map - - {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} @@ -113,48 +72,27 @@ -- | Wrapper function which returns Annotations along with the parsed -- element. -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -parseWith :: (Data (GHC.SrcSpanLess w), Annotate w, GHC.HasSrcSpan w) - => GHC.DynFlags +parseWith :: GHC.DynFlags -> FilePath -> GHC.P w -> String -> ParseResult w -#else -parseWith :: Annotate w - => GHC.DynFlags - -> FilePath - -> GHC.P (GHC.Located w) - -> String - -> ParseResult (GHC.Located w) -#endif parseWith dflags fileName parser s = case runParser parser dflags fileName s of -#if __GLASGOW_HASKELL__ > 808 - GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) -#elif __GLASGOW_HASKELL__ >= 804 - GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m) -#else - GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) -#endif - GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod) - where as = relativiseApiAnns pmod apianns + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk _ pmod -> Right pmod -#if __GLASGOW_HASKELL__ > 808 -parseWithECP :: (GHC.DisambECP w, Annotate (GHC.Body w GHC.GhcPs)) +parseWithECP :: (GHC.DisambECP w) => GHC.DynFlags -> FilePath -> GHC.P GHC.ECP -> String - -> ParseResult (GHC.Located w) + -> ParseResult (GHC.LocatedA w) parseWithECP dflags fileName parser s = - -- case runParser ff dflags fileName s of - case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of - GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) - GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod) - where as = relativiseApiAnns pmod apianns -#endif + case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk _ pmod -> Right pmod -- --------------------------------------------------------------------- @@ -163,7 +101,7 @@ where location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 buffer = GHC.stringToStringBuffer str - parseState = GHC.mkPState flags buffer location + parseState = GHC.initParserState (GHC.initParserOpts flags) buffer location -- --------------------------------------------------------------------- @@ -173,57 +111,43 @@ -- @ -- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr) -- @ -withDynFlags :: (GHC.DynFlags -> a) -> IO a -withDynFlags action = ghcWrapper $ do +withDynFlags :: FilePath -> (GHC.DynFlags -> a) -> IO a +withDynFlags libdir action = ghcWrapper libdir $ do dflags <- GHC.getSessionDynFlags void $ GHC.setSessionDynFlags dflags return (action dflags) -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 900 parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule) -#else -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs)) -#endif parseFile = runParser GHC.parseModule -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 808 -type ParseResult a = Either GHC.ErrorMessages (Anns, a) -#else -type ParseResult a = Either (GHC.SrcSpan, String) (Anns, a) -#endif +type LibDir = FilePath +type ParseResult a = Either GHC.ErrorMessages a + type Parser a = GHC.DynFlags -> FilePath -> String -> ParseResult a -parseExpr :: Parser (GHC.LHsExpr GhcPs) -#if __GLASGOW_HASKELL__ > 808 +parseExpr :: Parser (GHC.LHsExpr GHC.GhcPs) parseExpr df fp = parseWithECP df fp GHC.parseExpression -#else -parseExpr df fp = parseWith df fp GHC.parseExpression -#endif -parseImport :: Parser (GHC.LImportDecl GhcPs) +parseImport :: Parser (GHC.LImportDecl GHC.GhcPs) parseImport df fp = parseWith df fp GHC.parseImport -parseType :: Parser (GHC.LHsType GhcPs) +parseType :: Parser (GHC.LHsType GHC.GhcPs) parseType df fp = parseWith df fp GHC.parseType -- safe, see D1007 -parseDecl :: Parser (GHC.LHsDecl GhcPs) -#if __GLASGOW_HASKELL__ <= 710 -parseDecl df fp = parseWith df fp (head . OL.fromOL <$> GHC.parseDeclaration) -#else +parseDecl :: Parser (GHC.LHsDecl GHC.GhcPs) parseDecl df fp = parseWith df fp GHC.parseDeclaration -#endif -parseStmt :: Parser (GHC.ExprLStmt GhcPs) +parseStmt :: Parser (GHC.ExprLStmt GHC.GhcPs) parseStmt df fp = parseWith df fp GHC.parseStatement -parsePattern :: Parser (GHC.LPat GhcPs) +parsePattern :: Parser (GHC.LPat GHC.GhcPs) parsePattern df fp = parseWith df fp GHC.parsePattern -- --------------------------------------------------------------------- @@ -237,8 +161,8 @@ -- @ -- -- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs') -parseModule :: FilePath -> IO (ParseResult GHC.ParsedSource) -parseModule = parseModuleWithCpp defaultCppOptions normalLayout +parseModule :: LibDir -> FilePath -> IO (ParseResult GHC.ParsedSource) +parseModule libdir file = parseModuleWithCpp libdir defaultCppOptions file -- | This entry point will work out which language extensions are @@ -247,10 +171,11 @@ -- string; the `FilePath` parameter solely exists to provide a name -- in source location annotations. parseModuleFromString - :: FilePath + :: FilePath -- GHC libdir + -> FilePath -> String -> IO (ParseResult GHC.ParsedSource) -parseModuleFromString fp s = ghcWrapper $ do +parseModuleFromString libdir fp s = ghcWrapper libdir $ do dflags <- initDynFlagsPure fp s return $ parseModuleFromStringInternal dflags fp s @@ -259,85 +184,65 @@ parseModuleFromStringInternal dflags fileName str = let (str1, lp) = stripLinePragmas str res = case runParser GHC.parseModule dflags fileName str1 of -#if __GLASGOW_HASKELL__ > 808 - GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) -#elif __GLASGOW_HASKELL__ >= 804 - GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m) -#else - GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) -#endif - GHC.POk x pmod -> Right (mkApiAnns x, lp, dflags, pmod) - in postParseTransform res normalLayout + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk _ pmod -> Right (lp, dflags, pmod) + in postParseTransform res -parseModuleWithOptions :: DeltaOptions +parseModuleWithOptions :: FilePath -- ^ GHC libdir -> FilePath -> IO (ParseResult GHC.ParsedSource) -parseModuleWithOptions opts fp = - parseModuleWithCpp defaultCppOptions opts fp +parseModuleWithOptions libdir fp = + parseModuleWithCpp libdir defaultCppOptions fp -- | Parse a module with specific instructions for the C pre-processor. parseModuleWithCpp - :: CppOptions - -> DeltaOptions - -> FilePath + :: FilePath -- ^ GHC libdir + -> CppOptions + -> FilePath -- ^ File to be parsed -> IO (ParseResult GHC.ParsedSource) -parseModuleWithCpp cpp opts fp = do - res <- parseModuleApiAnnsWithCpp cpp fp - return $ postParseTransform res opts +parseModuleWithCpp libdir cpp fp = do + res <- parseModuleEpAnnsWithCpp libdir cpp fp + return $ postParseTransform res -- --------------------------------------------------------------------- -- | Low level function which is used in the internal tests. -- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of -- this function. -parseModuleApiAnnsWithCpp - :: CppOptions - -> FilePath +parseModuleEpAnnsWithCpp + :: FilePath -- ^ GHC libdir + -> CppOptions + -> FilePath -- ^ File to be parsed -> IO ( Either -#if __GLASGOW_HASKELL__ > 808 GHC.ErrorMessages -#else - (GHC.SrcSpan, String) -#endif - (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource) ) -parseModuleApiAnnsWithCpp cppOptions file = ghcWrapper $ do +parseModuleEpAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do dflags <- initDynFlags file - parseModuleApiAnnsWithCppInternal cppOptions dflags file + parseModuleEpAnnsWithCppInternal cppOptions dflags file -- | Internal function. Default runner of GHC.Ghc action in IO. -ghcWrapper :: GHC.Ghc a -> IO a -ghcWrapper ghc = do - let handler = return . const Nothing :: IOException -> IO (Maybe String) - rtLibdir <- liftIO $ lookupEnv "GHC_EXACTPRINT_GHC_LIBDIR" `catch` handler - let libdir' = fromMaybe libdir rtLibdir +ghcWrapper :: FilePath -> GHC.Ghc a -> IO a +ghcWrapper libdir a = GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut - . GHC.runGhc (Just libdir') $ ghc + $ GHC.runGhc (Just libdir) a -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. -parseModuleApiAnnsWithCppInternal +parseModuleEpAnnsWithCppInternal :: GHC.GhcMonad m => CppOptions -> GHC.DynFlags -> FilePath -> m ( Either -#if __GLASGOW_HASKELL__ > 808 GHC.ErrorMessages -#else - (GHC.SrcSpan, String) -#endif - (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource) ) -parseModuleApiAnnsWithCppInternal cppOptions dflags file = do -#if __GLASGOW_HASKELL__ <= 710 - let useCpp = GHC.xopt GHC.Opt_Cpp dflags -#else +parseModuleEpAnnsWithCppInternal cppOptions dflags file = do let useCpp = GHC.xopt LangExt.Cpp dflags -#endif (fileContents, injectedComments, dflags') <- if useCpp then do @@ -350,27 +255,43 @@ return (contents1,lp,dflags) return $ case parseFile dflags' file fileContents of -#if __GLASGOW_HASKELL__ > 808 - GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) -#elif __GLASGOW_HASKELL__ >= 804 - GHC.PFailed _ ss m -> Left $ (ss, (GHC.showSDoc dflags m)) -#else - GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m)) -#endif - GHC.POk (mkApiAnns -> apianns) pmod -> - Right $ (apianns, injectedComments, dflags', pmod) + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk _ pmod -> + Right $ (injectedComments, dflags', fixModuleTrailingComments pmod) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. postParseTransform - :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) - -> DeltaOptions - -> Either a (Anns, GHC.ParsedSource) -postParseTransform parseRes opts = fmap mkAnns parseRes + :: Either a ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource) + -> Either a (GHC.ParsedSource) +postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (apianns, cs, _, m) = - (relativiseApiAnnsWithOptions opts cs m apianns, m) + -- TODO:AZ perhaps inject the comments into the parsedsource here already + mkAnns (_cs, _, m) = fixModuleTrailingComments m +fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource +fixModuleTrailingComments (GHC.L l p) = GHC.L l p' + where + an' = case GHC.hsmodAnn p of + (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance (GHC.am_decls an) ocs) + unused -> unused + p' = p { GHC.hsmodAnn = an' } + -- p' = error $ "fixModuleTrailingComments: an'=" ++ showAst an' + + rebalance :: GHC.AnnList -> GHC.EpAnnComments -> GHC.EpAnnComments + rebalance al cs = cs' + where + cs' = case GHC.al_close al of + Just (GHC.AddEpAnn _ (GHC.EpaSpan ss)) -> + let + pc = GHC.priorComments cs + fc = GHC.getFollowingComments cs + bf (GHC.L anc _) = GHC.anchor anc > ss + (prior,f) = break bf fc + cs'' = GHC.EpaCommentsBalanced (pc <> prior) f + in cs'' + _ -> cs + -- | Internal function. Initializes DynFlags value for parsing. -- -- Passes "-hide-all-packages" to the GHC API to prevent parsing of @@ -418,19 +339,3 @@ return dflags3 -- --------------------------------------------------------------------- - -mkApiAnns :: GHC.PState -> GHC.ApiAnns - -#if __GLASGOW_HASKELL__ >= 900 -mkApiAnns pstate - = GHC.ApiAnns { - GHC.apiAnnItems = Map.fromListWith (++) $ GHC.annotations pstate, - GHC.apiAnnEofPos = GHC.eof_pos pstate, - GHC.apiAnnComments = Map.fromList (GHC.annotations_comments pstate), - GHC.apiAnnRogueComments = GHC.comment_q pstate - } -#else -mkApiAnns pstate - = ( Map.fromListWith (++) . GHC.annotations $ pstate - , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate)) -#endif diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs --- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides support for CPP, interpreter directives and line @@ -16,54 +15,28 @@ import qualified GHC as GHC hiding (parseModule) -#if __GLASGOW_HASKELL__ >= 900 import qualified Control.Monad.IO.Class as GHC import qualified GHC.Data.Bag as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Env as GHC import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC --- import qualified GHC.Driver.Session as GHC -import qualified GHC.Driver.Types as GHC import qualified GHC.Fingerprint.Type as GHC -import qualified GHC.Utils.Fingerprint as GHC +import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Settings as GHC +import qualified GHC.Types.SourceError as GHC +import qualified GHC.Types.SourceFile as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Error as GHC +import qualified GHC.Utils.Fingerprint as GHC import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) import GHC.Data.FastString (mkFastString) -#else -import qualified Bag as GHC -import qualified DriverPhases as GHC -import qualified DriverPipeline as GHC -import qualified DynFlags as GHC -import qualified ErrUtils as GHC -import qualified FastString as GHC -import qualified HscTypes as GHC -import qualified Lexer as GHC -import qualified MonadUtils as GHC -import qualified SrcLoc as GHC -import qualified StringBuffer as GHC -import SrcLoc (mkSrcSpan, mkSrcLoc) -import FastString (mkFastString) -#endif -#if (__GLASGOW_HASKELL__ > 808) && (__GLASGOW_HASKELL__ < 900) -import qualified Fingerprint as GHC -import qualified ToolSettings as GHC -#endif - - -#if __GLASGOW_HASKELL__ > 808 -#else -import Control.Exception -#endif -import Data.List hiding (find) +import Data.List (isPrefixOf, intercalate) 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 @@ -88,29 +61,29 @@ -- --------------------------------------------------------------------- -- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments. -stripLinePragmas :: String -> (String, [Comment]) +stripLinePragmas :: String -> (String, [GHC.LEpaComment]) stripLinePragmas = unlines' . unzip . findLines . lines where unlines' (a, b) = (unlines a, catMaybes b) -findLines :: [String] -> [(String, Maybe Comment)] +findLines :: [String] -> [(String, Maybe GHC.LEpaComment)] findLines = zipWith checkLine [1..] -checkLine :: Int -> String -> (String, Maybe Comment) +checkLine :: Int -> String -> (String, Maybe GHC.LEpaComment) checkLine line s | "{-# LINE" `isPrefixOf` s = let (pragma, res) = getPragma s size = length pragma mSrcLoc = mkSrcLoc (mkFastString "LINE") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1)) - in (res, Just $ mkComment pragma (rs ss)) + in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss)) -- Deal with shebang/cpp directives too -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s) | "#!" `isPrefixOf` s = let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s)) in - ("",Just $ mkComment s (rs ss)) + ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss)) | otherwise = (s, Nothing) getPragma :: String -> (String, String) @@ -129,46 +102,37 @@ getCppTokensAsComments :: GHC.GhcMonad m => CppOptions -- ^ Preprocessor Options -> FilePath -- ^ Path to source file - -> m [Comment] + -> m [GHC.LEpaComment] getCppTokensAsComments cppOptions sourceFile = do source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1 - (_txt,strSrcBuf,flags2) <- getPreprocessedSrcDirectPrim cppOptions sourceFile - -- #ifdef tokens + (_txt,strSrcBuf,flags2') <- getPreprocessedSrcDirectPrim cppOptions sourceFile + let flags2 = GHC.initParserOpts flags2' + -- hash-ifdef tokens directiveToks <- GHC.liftIO $ getPreprocessorAsComments sourceFile - -- Tokens without #ifdef + -- Tokens without hash-ifdef nonDirectiveToks <- tokeniseOriginalSrc startLoc flags2 source - case GHC.lexTokenStream strSrcBuf startLoc flags2 of + case GHC.lexTokenStream flags2 strSrcBuf startLoc of GHC.POk _ ts -> do let toks = GHC.addSourceToTokens startLoc source ts cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks return $ filter goodComment -#if __GLASGOW_HASKELL__ >= 900 - $ map (tokComment . GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks -#elif __GLASGOW_HASKELL__ > 800 - $ map (tokComment . GHC.commentToAnnotation . fst) cppCommentToks -#else - $ map (tokComment . commentToAnnotation . fst) cppCommentToks -#endif -#if __GLASGOW_HASKELL__ > 808 - GHC.PFailed pst -> parseError flags2 pst -#elif __GLASGOW_HASKELL__ >= 804 - GHC.PFailed _ sspan err -> parseError flags2 sspan err -#else - GHC.PFailed sspan err -> parseError flags2 sspan err -#endif + $ map (GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks + GHC.PFailed pst -> parseError pst -goodComment :: Comment -> Bool -goodComment (Comment "" _ _) = False -goodComment _ = True +goodComment :: GHC.LEpaComment -> Bool +goodComment c = isGoodComment (tokComment c) + where + isGoodComment :: Comment -> Bool + isGoodComment (Comment "" _ _) = False + isGoodComment _ = True -#if __GLASGOW_HASKELL__ >= 900 + toRealLocated :: GHC.Located a -> GHC.RealLocated a toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s x toRealLocated (GHC.L _ x) = GHC.L badRealSrcSpan x -#endif -- --------------------------------------------------------------------- @@ -205,7 +169,7 @@ missingAsComments = map mkCommentTok missingToks where mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String) - mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s),s) + mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s placeholderBufSpan),s) toks = mergeBy locFn directiveToks missingAsComments @@ -213,19 +177,13 @@ tokeniseOriginalSrc :: GHC.GhcMonad m - => GHC.RealSrcLoc -> GHC.DynFlags -> GHC.StringBuffer + => GHC.RealSrcLoc -> GHC.ParserOpts -> GHC.StringBuffer -> m [(GHC.Located GHC.Token, String)] tokeniseOriginalSrc startLoc flags buf = do let src = stripPreprocessorDirectives buf - case GHC.lexTokenStream src startLoc flags of + case GHC.lexTokenStream flags src startLoc of GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts -#if __GLASGOW_HASKELL__ > 808 - GHC.PFailed pst -> parseError flags pst -#elif __GLASGOW_HASKELL__ >= 804 - GHC.PFailed _ sspan err -> parseError flags sspan err -#else - GHC.PFailed sspan err -> parseError flags sspan err -#endif + GHC.PFailed pst -> parseError pst -- --------------------------------------------------------------------- @@ -259,8 +217,6 @@ hsc_env <- GHC.getSession let dfs = GHC.hsc_dflags hsc_env new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } -#if __GLASGOW_HASKELL__ >= 808 - -- (dflags', hspp_fn) <- r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) case r of Left err -> error $ showErrorMessages err @@ -268,18 +224,9 @@ buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') -#else - (dflags', hspp_fn) <- - GHC.liftIO $ GHC.preprocess new_env (src_fn, Just (GHC.Cpp GHC.HsSrcFile)) - buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn - txt <- GHC.liftIO $ readFileGhc hspp_fn - return (txt, buf, dflags') -#endif -#if __GLASGOW_HASKELL__ >= 808 showErrorMessages :: GHC.ErrorMessages -> String showErrorMessages msgs = intercalate "\n" $ map show $ GHC.bagToList msgs -#endif injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags injectCppOptions CppOptions{..} dflags = @@ -290,7 +237,6 @@ mkInclude = ("-include" ++) -#if __GLASGOW_HASKELL__ > 808 addOptP :: String -> GHC.DynFlags -> GHC.DynFlags addOptP f = alterToolSettings $ \s -> s { GHC.toolSettings_opt_P = f : GHC.toolSettings_opt_P s @@ -302,13 +248,6 @@ fingerprintStrings :: [String] -> GHC.Fingerprint fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss -#else -addOptP :: String -> GHC.DynFlags -> GHC.DynFlags -addOptP f = alterSettings (\s -> s { GHC.sOpt_P = f : GHC.sOpt_P s}) - -alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags -alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) } -#endif -- --------------------------------------------------------------------- -- | Get the preprocessor directives as comment tokens from the @@ -319,7 +258,7 @@ let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#') $ zip [1..] (lines fcontents) - let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line),line) + let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line placeholderBufSpan),line) where start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1 end = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line) @@ -328,20 +267,21 @@ let toks = map mkTok directives return toks +placeholderBufSpan :: GHC.PsSpan +placeholderBufSpan = pspan + where + bl = GHC.BufPos 0 + pspan = GHC.PsSpan GHC.placeholderRealSpan (GHC.BufSpan bl bl) + -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 808 -parseError :: (GHC.MonadIO m) => GHC.DynFlags -> GHC.PState -> m b -parseError dflags pst = do +parseError :: (GHC.MonadIO m) => GHC.PState -> m b +parseError pst = do let -- (warns,errs) = GHC.getMessages pst dflags -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) - GHC.throwErrors (GHC.getErrorMessages pst dflags) -#else -parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b -parseError dflags sspan err = do - throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) -#endif + -- GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst)) + GHC.throwErrors (fmap GHC.pprError (GHC.getErrorMessages pst)) -- --------------------------------------------------------------------- @@ -373,4 +313,3 @@ -- Someone please put this code out of its misery. | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally | otherwise = y : mergeBy cmp allx ys - diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs +++ /dev/null @@ -1,652 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.GHC.ExactPrint.Pretty --- --- This module adds default annotations to an AST fragment that does not have --- them, to be able to exactprint it in a way that preserves the orginal AST --- when re-parsed. --- ------------------------------------------------------------------------------ - -module Language.Haskell.GHC.ExactPrint.Pretty - ( - addAnnotationsForPretty - ) where - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Annotate - -import Control.Monad.RWS -import Control.Monad.Trans.Free -import Data.Generics -import Data.List -import Data.Ord (comparing) - - -#if __GLASGOW_HASKELL__ <= 710 -import qualified BooleanFormula as GHC -import qualified Outputable as GHC -#endif -import qualified GHC - -import qualified Data.Map as Map -import qualified Data.Set as Set - -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} - --- --------------------------------------------------------------------- - --- |Add any missing annotations so that the full AST element will exactprint --- properly when done. -addAnnotationsForPretty :: (Annotate a) => [Comment] -> GHC.Located a -> Anns -> Anns -addAnnotationsForPretty cs ast ans - = runPrettyWithComments opts cs (annotate ast) ans (0,0) - where - opts = prettyOptions NormalLayout - --- --------------------------------------------------------------------- --- --- | Type used in the Pretty Monad. -type Pretty a = RWS PrettyOptions PrettyWriter PrettyState a - -runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns -runPrettyWithComments opts cs action ans priorEnd = - mkAnns . snd - . (\next -> execRWS next opts (defaultPrettyState cs priorEnd ans)) - . prettyInterpret $ action - where - mkAnns :: PrettyWriter -> Anns - mkAnns = f . dwAnns - f :: Monoid a => Endo a -> a - f = ($ mempty) . appEndo - --- --------------------------------------------------------------------- - --- TODO: rename this, it is the R part of the RWS -data PrettyOptions = PrettyOptions - { - -- | Current `SrcSpan, part of current AnnKey` - curSrcSpan :: !GHC.SrcSpan - - -- | Constuctor of current AST element, part of current AnnKey - , annConName :: !AnnConName - - -- | Whether to use rigid or normal layout rules - , drRigidity :: !Rigidity - - -- | Current higher level context. e.g. whether a Match is part of a - -- LambdaExpr or a FunBind - , prContext :: !AstContextSet - } deriving Show - -data PrettyWriter = PrettyWriter - { -- | Final list of annotations, and sort keys - dwAnns :: Endo (Map.Map AnnKey Annotation) - - -- | Used locally to pass Keywords, delta pairs relevant to a specific - -- subtree to the parent. - , annKds :: ![(KeywordId, DeltaPos)] - , sortKeys :: !(Maybe [AnnSpan]) - , dwCapturedSpan :: !(First AnnKey) - , prLayoutContext :: !(ACS' AstContext) - } - -data PrettyState = PrettyState - { -- | Position reached when processing the last element - priorEndPosition :: !Pos - - -- | Ordered list of comments still to be allocated - , apComments :: ![Comment] - - , apMarkLayout :: Bool - , apLayoutStart :: LayoutStartCol - - , apNoPrecedingSpace :: Bool - - } - -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup PrettyWriter where - (<>) = mappend -#endif - -instance Monoid PrettyWriter where - mempty = PrettyWriter mempty mempty mempty mempty mempty - (PrettyWriter a b e g i) `mappend` (PrettyWriter c d f h j) - = PrettyWriter (a <> c) (b <> d) (e <> f) (g <> h) (i <> j) - --- --------------------------------------------------------------------- - -prettyOptions :: Rigidity -> PrettyOptions -prettyOptions ridigity = - PrettyOptions - { curSrcSpan = GHC.noSrcSpan - , annConName = annGetConstr () - , drRigidity = ridigity - , prContext = defaultACS - } - -defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState -defaultPrettyState injectedComments priorEnd _ans = - PrettyState - { priorEndPosition = priorEnd - , apComments = cs ++ injectedComments - , apLayoutStart = 1 - , apMarkLayout = False - , apNoPrecedingSpace = False - } - where - cs :: [Comment] - cs = [] - --- --------------------------------------------------------------------- --- Free Monad Interpretation code - -prettyInterpret :: Annotated a -> Pretty a -prettyInterpret = iterTM go - where - go :: AnnotationF (Pretty a) -> Pretty a - go (MarkPrim kwid _ next) = addPrettyAnnotation (G kwid) >> next - go (MarkPPOptional _kwid _ next) = next - go (MarkEOF next) = addEofAnnotation >> next - go (MarkExternal _ss akwid _ next) = addPrettyAnnotation (G akwid) >> next -#if __GLASGOW_HASKELL__ >= 800 - go (MarkInstead akwid kwid next) = addPrettyAnnotationsInstead akwid kwid >> next -#endif - go (MarkOutside akwid kwid next) = addPrettyAnnotationsOutside akwid kwid >> next - -- go (MarkOutside akwid kwid next) = addPrettyAnnotation kwid >> next - go (MarkInside akwid next) = addPrettyAnnotationsInside akwid >> next - 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 (WithAST lss prog next) = withAST lss (prettyInterpret prog) >> next - go (CountAnns kwid next) = countAnnsPretty kwid >>= next - go (WithSortKey kws next) = withSortKey kws >> next - go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next - go (SetLayoutFlag r action next) = do - rigidity <- asks drRigidity - (if r <= rigidity then setLayoutFlag else id) (prettyInterpret action) - next - go (StoreOriginalSrcSpan l key next) = storeOriginalSrcSpanPretty l key >>= next - go (MarkAnnBeforeAnn _ann1 _ann2 next) = next - go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next -#if __GLASGOW_HASKELL__ <= 710 - go (StoreString s ss next) = storeString s ss >> next -#endif - go (AnnotationsToComments kws next) = annotationsToCommentsPretty kws >> next -#if __GLASGOW_HASKELL__ <= 710 - go (AnnotationsToCommentsBF bf kws next) = annotationsToCommentsBFPretty bf kws >> next - go (FinalizeBF l next) = finalizeBFPretty l >> next -#endif - - go (SetContextLevel ctxt lvl action next) = setContextPretty ctxt lvl (prettyInterpret action) >> next - go (UnsetContext ctxt action next) = unsetContextPretty ctxt (prettyInterpret action) >> next - go (IfInContext ctxt ia ea next) = ifInContextPretty ctxt ia ea >> next - go (TellContext c next) = tellContext c >> next - --- --------------------------------------------------------------------- - -addEofAnnotation :: Pretty () -addEofAnnotation = do -#if __GLASGOW_HASKELL__ >= 900 - tellKd (AnnEofPos, DP (1,0)) -#else - tellKd (G GHC.AnnEofPos, DP (1,0)) -#endif - --- --------------------------------------------------------------------- - -addPrettyAnnotation :: KeywordId -> Pretty () -addPrettyAnnotation ann = do - noPrec <- gets apNoPrecedingSpace - 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,0)) -#if __GLASGOW_HASKELL__ >= 806 - (G GHC.AnnAnyclass) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnBackquote) -> tellKd (ann,DP (0,1)) - (G GHC.AnnBang) -> tellKd (ann,DP (0,1)) - (G GHC.AnnBy) -> tellKd (ann,DP (0,1)) - (G GHC.AnnCase ) -> tellKd (ann,DP (0,1)) - (G GHC.AnnClass) -> tellKd (ann,DP (0,1)) - (G GHC.AnnClose) -> tellKd (ann,DP (0,1)) - (G GHC.AnnCloseC) -> tellKd (ann,DP (0,0)) -#if __GLASGOW_HASKELL__ >= 802 - (G GHC.AnnCloseQ) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnDcolon) -> tellKd (ann,DP (0,1)) - (G GHC.AnnDeriving) -> tellKd (ann,DP (0,1)) - (G GHC.AnnDo) -> tellKd (ann,DP (0,1)) -#if __GLASGOW_HASKELL__ >= 900 - (G GHC.AnnDollar) -> tellKd (ann,DP (0,1)) - (G GHC.AnnDollarDollar) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnDotdot) -> tellKd (ann,DP (0,1)) - (G GHC.AnnElse) -> tellKd (ann,DP (1,2)) - (G GHC.AnnEqual) -> tellKd (ann,DP (0,1)) - (G GHC.AnnExport) -> tellKd (ann,DP (0,1)) - (G GHC.AnnFamily) -> tellKd (ann,DP (0,1)) - (G GHC.AnnForall) -> tellKd (ann,DP (0,1)) - (G GHC.AnnGroup) -> tellKd (ann,DP (0,1)) - (G GHC.AnnHiding) -> tellKd (ann,DP (0,1)) - (G GHC.AnnIf) -> tellKd (ann,DP (0,1)) - (G GHC.AnnImport) -> 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)) - (G GHC.AnnLet) -> tellKd (ann,DP (0,1)) -#if __GLASGOW_HASKELL__ >= 900 - -- (G GHC.AnnLolly) -> tellKd (ann,DP (0,1)) - (G GHC.AnnLollyU) -> tellKd (ann,DP (0,1)) - (G GHC.AnnPercentOne) -> tellKd (ann,DP (0,1)) - (G GHC.AnnPercent) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnMinus) -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator - (G GHC.AnnModule) -> tellKd (ann,DP (0,1)) - (G GHC.AnnNewtype) -> tellKd (ann,DP (0,1)) - (G GHC.AnnOf) -> tellKd (ann,DP (0,1)) - (G GHC.AnnOpenC) -> tellKd (ann,DP (0,0)) - (G GHC.AnnOpenP) -> tellKd (ann,DP (0,1)) - (G GHC.AnnOpenS) -> tellKd (ann,DP (0,1)) -#if __GLASGOW_HASKELL__ < 900 - (G GHC.AnnOpenPE) -> tellKd (ann,DP (0,1)) - (G GHC.AnnOpenPTE) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnQualified) -> tellKd (ann,DP (0,1)) - (G GHC.AnnRarrow) -> tellKd (ann,DP (0,1)) -#if __GLASGOW_HASKELL__ > 710 - (G GHC.AnnRarrowU) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnRole) -> tellKd (ann,DP (0,1)) - (G GHC.AnnSafe) -> tellKd (ann,DP (0,1)) -#if __GLASGOW_HASKELL__ >= 806 - (G GHC.AnnStock) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1)) -#if __GLASGOW_HASKELL__ < 900 - (G GHC.AnnThIdSplice) -> tellKd (ann,DP (0,1)) - (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnThTyQuote) -> tellKd (ann,DP (0,1)) - (G GHC.AnnThen) -> tellKd (ann,DP (1,2)) - (G GHC.AnnTilde) -> tellKd (ann,DP (0,1)) - (G GHC.AnnType) -> tellKd (ann,DP (0,1)) - (G GHC.AnnUsing) -> tellKd (ann,DP (0,1)) - (G GHC.AnnVal) -> tellKd (ann,DP (0,1)) - (G GHC.AnnValStr) -> tellKd (ann,DP (0,1)) - (G GHC.AnnVbar) -> tellKd (ann,DP (0,1)) -#if __GLASGOW_HASKELL__ >= 806 - (G GHC.AnnVia) -> tellKd (ann,DP (0,1)) -#endif - (G GHC.AnnWhere) -> tellKd (ann,DP (1,2)) -#if __GLASGOW_HASKELL__ >= 800 - AnnTypeApp -> tellKd (ann,DP (0,1)) -#endif - _ -> tellKd (ann,DP (0,0)) - fromNoPrecedingSpace (tellKd (ann,DP (0,0))) dp - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 800 -addPrettyAnnotationsInstead :: GHC.AnnKeywordId -> KeywordId -> Pretty () -addPrettyAnnotationsInstead _akwid AnnSemiSep = return () -addPrettyAnnotationsInstead _akwid kwid = addPrettyAnnotation kwid -#endif - --- --------------------------------------------------------------------- - -addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty () -addPrettyAnnotationsOutside _akwid AnnSemiSep = return () -addPrettyAnnotationsOutside _akwid kwid = addPrettyAnnotation kwid - --- --------------------------------------------------------------------- - -addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty () -addPrettyAnnotationsInside _ann = return () - --- --------------------------------------------------------------------- - -addPrettyAnnotationLs :: GHC.AnnKeywordId -> Int -> Pretty () -addPrettyAnnotationLs ann _off = addPrettyAnnotation (G ann) - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -getUnallocatedComments :: Pretty [Comment] -getUnallocatedComments = gets apComments - -putUnallocatedComments :: [Comment] -> Pretty () -putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) -#endif - --- --------------------------------------------------------------------- - -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b -withSrcSpanPretty (GHC.dL->GHC.L l a) action = do -#else -withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b -withSrcSpanPretty (GHC.L l a) action = do -#endif - -- peek into the current state of the output, to extract the layout context - -- flags passed up from subelements of the AST. - (_,w) <- listen (return () :: Pretty ()) - - _ <- debugP ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ()) - - local (\s -> s { curSrcSpan = l - , annConName = annGetConstr a - -- , prContext = pushAcs (prContext s) - , prContext = (pushAcs (prContext s)) <> (prLayoutContext w) - }) - action - --- --------------------------------------------------------------------- - --- | Enter a new AST element. Maintain SrcSpan stack -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) - => a - -> Pretty b -> Pretty b -withAST lss@(GHC.dL->GHC.L ss t) action = do -#else -withAST :: Data a - => GHC.Located a - -> Pretty b -> Pretty b -withAST lss@(GHC.L ss t) action = do -#endif - return () `debug` ("Pretty.withAST:enter 1:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) - -- Calculate offset required to get to the start of the SrcSPan - -- off <- gets apLayoutStart - withSrcSpanPretty lss $ do - return () `debug` ("Pretty.withAST:enter:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) - - let maskWriter s = s { annKds = [] - , sortKeys = Nothing - , dwCapturedSpan = mempty - -- , prLayoutContext = pushAcs (prLayoutContext s) - } - -#if __GLASGOW_HASKELL__ <= 710 - let spanStart = ss2pos ss - cs <- do - if GHC.isGoodSrcSpan ss - then - commentAllocation (priorComment spanStart) return - else - return [] -#else - let cs = [] -#endif - - -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext - ctx <- asks prContext - - noPrec <- gets apNoPrecedingSpace - 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 = debugP ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx - -- (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1 - (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel,InTypeApp]) ctx1 - then - -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ - censor maskWriter (listen (setNoPrecedingSpace action)) - else - -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ - censor maskWriter (listen action) - - let kds = annKds w - an = Ann - { annEntryDelta = edp - , annPriorComments = cs - , annFollowingComments = [] -- only used in Transform and Print - , annsDP = kds - , annSortKey = sortKeys w - , annCapturedSpan = getFirst $ dwCapturedSpan w - } - - addAnnotationsPretty an - `debug` ("Pretty.withAST:(annkey,an)=" ++ show (mkAnnKey lss,an)) - return res - --- --------------------------------------------------------------------- - -entryDpFor :: Typeable a => AstContextSet -> a -> Pretty DeltaPos -entryDpFor ctx a = (def `extQ` grhs) a - where - lineDefault = if inAcs (Set.singleton AdvanceLine) ctx - then 1 else 0 - noAdvanceLine = inAcs (Set.singleton NoAdvanceLine) ctx && - inAcs (Set.singleton ListStart) ctx - - def :: a -> Pretty DeltaPos - def _ = - debugP ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $ - if noAdvanceLine - then (if inTypeApp then return (DP (0,0)) else return (DP (0,1))) - -- then (if inTypeApp then error "inTypeAp" else return (DP (0,1))) - else - if listStart - then return (DP (1,2)) - else if inList - then if topLevel then return (DP (2,0)) else return (DP (1,0)) - else if topLevel then return (DP (2,0)) else return (DP (lineDefault,0)) - - topLevel = inAcs (Set.singleton TopLevel) ctx - listStart = inAcs (Set.singleton ListStart) ctx - && not (inAcs (Set.singleton TopLevel) ctx) - inList = inAcs (Set.singleton ListItem) ctx - inLambda = inAcs (Set.singleton LambdaExpr) ctx - inTypeApp = inAcs (Set.singleton InTypeApp) ctx - - grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos - grhs _ = do - if inLambda - then return (DP (0,1)) - else return (DP (1,2)) - --- --------------------------------------------------------------------- - -fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a -fromNoPrecedingSpace def lay = do - PrettyState{apNoPrecedingSpace} <- get - -- ctx <- asks prContext - if apNoPrecedingSpace - then do - modify (\s -> s { apNoPrecedingSpace = False - }) - debugP ("fromNoPrecedingSpace:def") def - -- def - else - -- lay - debugP ("fromNoPrecedingSpace:lay") lay - - --- --------------------------------------------------------------------- - --- |Add some annotation to the currently active SrcSpan -addAnnotationsPretty :: Annotation -> Pretty () -addAnnotationsPretty ann = do - l <- ask - return () `debug` ("addAnnotationsPretty:=" ++ showGhc (curSrcSpan l,prContext l)) - tellFinalAnn (getAnnKey l,ann) - -getAnnKey :: PrettyOptions -> AnnKey -getAnnKey PrettyOptions {curSrcSpan, annConName} - = AnnKey (rs curSrcSpan) annConName - --- --------------------------------------------------------------------- - -countAnnsPretty :: GHC.AnnKeywordId -> Pretty Int -countAnnsPretty _ann = return 0 - --- --------------------------------------------------------------------- - -withSortKey :: [(AnnSpan, Annotated b)] -> Pretty () -withSortKey kws = - let order = sortBy (comparing fst) kws - in do - tellSortKey (map fst order) - mapM_ (prettyInterpret . snd) order - -withSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Pretty () -withSortKeyContexts ctxts kws = - let order = sortBy (comparing fst) kws - in do - tellSortKey (map fst order) - withSortKeyContextsHelper prettyInterpret ctxts order - --- --------------------------------------------------------------------- - -storeOriginalSrcSpanPretty :: GHC.SrcSpan -> AnnKey -> Pretty AnnKey -storeOriginalSrcSpanPretty _s key = do - tellCapturedSpan key - return key - --- --------------------------------------------------------------------- - -getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Pretty GHC.SrcSpan -getSrcSpanForKw ss _kw = return ss - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -storeString :: String -> GHC.SrcSpan -> Pretty () -storeString s _ss = addPrettyAnnotation (AnnString s) -#endif - --- --------------------------------------------------------------------- - -setLayoutFlag :: Pretty () -> Pretty () -setLayoutFlag action = do - oldLay <- gets apLayoutStart - modify (\s -> s { apMarkLayout = True } ) - let reset = modify (\s -> s { apMarkLayout = False - , apLayoutStart = oldLay }) - action <* reset - --- --------------------------------------------------------------------- - -setNoPrecedingSpace :: Pretty a -> Pretty a -setNoPrecedingSpace action = do - oldVal <- gets apNoPrecedingSpace - modify (\s -> s { apNoPrecedingSpace = True } ) - let reset = modify (\s -> s { apNoPrecedingSpace = oldVal }) - action <* reset - --- --------------------------------------------------------------------- - -setContextPretty :: Set.Set AstContext -> Int -> Pretty () -> Pretty () -setContextPretty ctxt lvl = - local (\s -> s { prContext = setAcsWithLevel ctxt lvl (prContext s) } ) - -unsetContextPretty :: AstContext -> Pretty () -> Pretty () -unsetContextPretty ctxt = - local (\s -> s { prContext = unsetAcs ctxt (prContext s) } ) - - -ifInContextPretty :: Set.Set AstContext -> Annotated () -> Annotated () -> Pretty () -ifInContextPretty ctxt ifAction elseAction = do - cur <- asks prContext - let inContext = inAcs ctxt cur - if inContext - then prettyInterpret ifAction - else prettyInterpret elseAction - --- --------------------------------------------------------------------- - -annotationsToCommentsPretty :: [GHC.AnnKeywordId] -> Pretty () -annotationsToCommentsPretty _kws = return () - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty () -annotationsToCommentsBFPretty bf _kws = do - -- cs <- gets apComments - 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 - newComments = map (uncurry mkKWComment ) kws - putUnallocatedComments (cs ++ newComments) - - -finalizeBFPretty :: GHC.SrcSpan -> Pretty () -finalizeBFPretty _ss = do - commentAllocation (const True) (mapM_ (uncurry addPrettyComment)) - return () -#endif - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ <= 710 --- |Split the ordered list of comments into ones that occur prior to --- the give SrcSpan and the rest -priorComment :: Pos -> Comment -> Bool -priorComment start c = (ss2pos . commentIdentifier $ c) < start - --- TODO:AZ: We scan the entire comment list here. It may be better to impose an --- invariant that the comments are sorted, and consume them as the pos --- advances. It then becomes a process of using `takeWhile p` rather than a full --- partition. -allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment]) -allocateComments = partition -#endif - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -commentAllocation :: (Comment -> Bool) - -> ([(Comment, DeltaPos)] -> Pretty a) - -> Pretty a -commentAllocation p k = do - cs <- getUnallocatedComments - let (allocated,cs') = allocateComments p cs - putUnallocatedComments cs' - k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated) - -makeDeltaComment :: Comment -> Pretty (Comment, DeltaPos) -makeDeltaComment c = do - return (c, DP (0,1)) - -addPrettyComment :: Comment -> DeltaPos -> Pretty () -addPrettyComment d p = do - tellKd (AnnComment d, p) -#endif - --- --------------------------------------------------------------------- - --- Writer helpers - -tellFinalAnn :: (AnnKey, Annotation) -> Pretty () -tellFinalAnn (k, v) = - tell (mempty { dwAnns = Endo (Map.insert k v) }) - -tellCapturedSpan :: AnnKey -> Pretty () -tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key }) - -tellKd :: (KeywordId, DeltaPos) -> Pretty () -tellKd kd = tell (mempty { annKds = [kd] }) - -tellSortKey :: [AnnSpan] -> Pretty () -tellSortKey xs = tell (mempty { sortKeys = Just xs } ) - -tellContext :: Set.Set AstContext -> Pretty () -tellContext lc = tell (mempty { prLayoutContext = setAcsWithLevel lc 2 mempty} ) diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Print.hs +++ /dev/null @@ -1,572 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.GHC.ExactPrint.Print --- --- This module inverts the process performed by "Delta". Given 'Anns' and --- a corresponding AST we produce a source file based on this information. --- ------------------------------------------------------------------------------ -module Language.Haskell.GHC.ExactPrint.Print - ( - exactPrint - , exactPrintWithOptions - - -- * Configuration - , PrintOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint) - , stringOptions - , printOptions - - ) where - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Annotate -import Language.Haskell.GHC.ExactPrint.Lookup - -import Control.Monad.Identity -import Control.Monad.RWS -import Control.Monad.Trans.Free -import Data.Data (Data) -import Data.List (sortBy, elemIndex) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) - -import qualified Data.Set as Set - -import qualified GHC - -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} --- --------------------------------------------------------------------- --- Printing of source elements - --- | Print an AST with a map of potential modified `Anns`. The usual way to --- generate such a map is by using one of the parsers in --- "Language.Haskell.GHC.ExactPrint.Parsers". -exactPrint :: Annotate ast - => GHC.Located ast - -> Anns - -> String -exactPrint ast as = runIdentity (exactPrintWithOptions stringOptions ast as) - --- | The additional option to specify the rigidity and printing --- configuration. -exactPrintWithOptions :: (Annotate ast, Monoid b, Monad m) - => PrintOptions m b - -> GHC.Located ast - -> Anns - -> m b -exactPrintWithOptions r ast as = - runEP r (annotate ast) as - ------------------------------------------------------- --- The EP monad and basic combinators - -data PrintOptions m a = PrintOptions - { - epAnn :: !Annotation -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) - , epAstPrint :: forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a -#else - , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a -#endif - , epTokenPrint :: String -> m a - , epWhitespacePrint :: String -> m a - , epRigidity :: Rigidity - , epContext :: !AstContextSet - } - --- | Helper to create a 'PrintOptions' -printOptions :: -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) - (forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a) -#else - (forall ast . Data ast => GHC.Located ast -> a -> m a) -#endif - -> (String -> m a) - -> (String -> m a) - -> Rigidity - -> PrintOptions m a -printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions - { - epAnn = annNone - , epAstPrint = astPrint - , epWhitespacePrint = wsPrint - , epTokenPrint = tokenPrint - , epRigidity = rigidity - , epContext = defaultACS - } - --- | Options which can be used to print as a normal String. -stringOptions :: PrintOptions Identity String -stringOptions = printOptions (\_ b -> return b) return return NormalLayout - -data EPWriter a = EPWriter - { output :: !a } - -#if __GLASGOW_HASKELL__ >= 804 -instance Monoid w => Semigroup (EPWriter w) where - (<>) = mappend -#endif - -instance Monoid w => Monoid (EPWriter w) where - mempty = EPWriter mempty - (EPWriter a) `mappend` (EPWriter b) = EPWriter (a <> b) - -data EPState = EPState - { epPos :: !Pos -- ^ Current output position - , epAnns :: !Anns - , epAnnKds :: ![[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local statE w mith suitable refactoring? - , epMarkLayout :: Bool - , epLHS :: LayoutStartCol - } - ---------------------------------------------------------- - -type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a - - - -runEP :: (Monad m, Monoid a) - => PrintOptions m a - -> Annotated () -> Anns -> m a -runEP epReader action ans = - fmap (output . snd) . - (\next -> execRWST next epReader - (defaultEPState ans)) - . printInterpret $ action - --- --------------------------------------------------------------------- - -defaultEPState :: Anns -> EPState -defaultEPState as = EPState - { epPos = (1,1) - , epAnns = as - , epAnnKds = [] - , epLHS = 1 - , epMarkLayout = False - } - - --- --------------------------------------------------------------------- - -printInterpret :: forall w m a . (Monad m, Monoid w) - => Annotated a -> EP w m a -printInterpret m = iterTM go (hoistFreeT (return . runIdentity) m) - where - go :: AnnotationF (EP w m a) -> EP w m a - go (MarkEOF next) = -#if __GLASGOW_HASKELL__ >= 900 - printStringAtMaybeAnn AnnEofPos (Just "") >> next -#else - printStringAtMaybeAnn (G GHC.AnnEofPos) (Just "") >> next -#endif - go (MarkPrim kwid mstr next) = - markPrim (G kwid) mstr >> next - go (MarkPPOptional kwid mstr next) = - markPrim (G kwid) mstr >> next -#if __GLASGOW_HASKELL__ >= 800 - go (MarkInstead _ kwid next) = - printStringAtMaybeAnnAll kwid Nothing >> next -#endif - go (MarkOutside _ kwid next) = - printStringAtMaybeAnnAll kwid Nothing >> next - go (MarkInside akwid next) = - allAnns akwid >> next - go (MarkMany akwid next) = - allAnns akwid >> next - go (MarkManyOptional akwid next) = - allAnns akwid >> next - go (MarkOffsetPrim 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) = - countAnnsEP (G kwid) >>= next - go (SetLayoutFlag r action next) = do - rigidity <- asks epRigidity - (if r <= rigidity then setLayout else id) (printInterpret action) - next - - go (MarkAnnBeforeAnn ann1 ann2 next) = printMarkAnnBeforeAnn (G ann1) (G ann2) >> next - go (MarkExternal _ akwid s next) = - printStringAtMaybeAnn (G akwid) (Just s) >> next - go (StoreOriginalSrcSpan _ _ next) = storeOriginalSrcSpanPrint >>= next - go (GetSrcSpanForKw _ _ next) = return GHC.noSrcSpan >>= next -#if __GLASGOW_HASKELL__ <= 710 - go (StoreString _ _ next) = - printStoredString >> next -#endif - go (AnnotationsToComments _ next) = next -#if __GLASGOW_HASKELL__ <= 710 - go (AnnotationsToCommentsBF _ _ next) = next - go (FinalizeBF _ next) = next -#endif - go (WithSortKey ks next) = withSortKey ks >> next - go (WithSortKeyContexts ctx ks next) = withSortKeyContexts ctx ks >> next - - go (SetContextLevel ctxt lvl action next) = setContextPrint ctxt lvl (printInterpret action) >> next - go (UnsetContext _ctxt action next) = printInterpret action >> next - go (IfInContext ctxt ifAction elseAction next) = ifInContextPrint ctxt ifAction elseAction >> next - go (TellContext _ next) = next - -------------------------------------------------------------------------- - -storeOriginalSrcSpanPrint :: (Monad m, Monoid w) => EP w m AnnKey -storeOriginalSrcSpanPrint = do - Ann{..} <- asks epAnn - case annCapturedSpan of - Nothing -> error "Missing captured SrcSpan" - Just v -> return v - -#if __GLASGOW_HASKELL__ <= 710 -printStoredString :: (Monad m, Monoid w) => EP w m () -printStoredString = do - kd <- gets epAnnKds - - let - isAnnString (AnnString _,_) = True - isAnnString _ = False - - case filter isAnnString (ghead "printStoredString" kd) of - ((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) (Just ss) - _ -> return () -#endif - -withSortKey :: (Monad m, Monoid w) => [(AnnSpan, Annotated ())] -> EP w m () -withSortKey xs = do - Ann{..} <- asks epAnn - let ordered = case annSortKey of - Nothing -> xs - Just keys -> orderByKey xs keys - `debug` ("withSortKey:" ++ - showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), - map fst xs, - keys) - ) - mapM_ (printInterpret . snd) ordered - -withSortKeyContexts :: (Monad m, Monoid w) => ListContexts -> [(AnnSpan, Annotated ())] -> EP w m () -withSortKeyContexts ctxts xs = do - Ann{..} <- asks epAnn - let ordered = case annSortKey of - Nothing -> xs - Just keys -> orderByKey xs keys - `debug` ("withSortKey:" ++ - showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), - map fst xs, - keys) - ) - -- mapM_ printInterpret ordered - withSortKeyContextsHelper printInterpret ctxts ordered - --- --------------------------------------------------------------------- - -setContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Int -> EP w m () -> EP w m () -setContextPrint ctxt lvl = - local (\s -> s { epContext = setAcsWithLevel ctxt lvl (epContext s) } ) - -ifInContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Annotated () -> Annotated () -> EP w m () -ifInContextPrint ctxt ifAction elseAction = do - cur <- asks epContext - let inContext = inAcs ctxt cur - if inContext - then printInterpret ifAction - else printInterpret elseAction - --- --------------------------------------------------------------------- - -allAnns :: (Monad m, Monoid w) => GHC.AnnKeywordId -> EP w m () -allAnns kwid = printStringAtMaybeAnnAll (G kwid) Nothing - -------------------------------------------------------------------------- --- |First move to the given location, then call exactP --- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a --- exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) - => ast -> EP w m a -> EP w m a -#else -exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a -#endif -exactPC ast action = - do - return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast)) - ma <- getAndRemoveAnnotation ast - let an@Ann{ annEntryDelta=edp - , annPriorComments=comments - , annFollowingComments=fcomments - , annsDP=kds - } = fromMaybe annNone ma - PrintOptions{epAstPrint} <- ask - r <- withContext kds an - (mapM_ (uncurry printQueuedComment) comments - >> advance edp - >> censorM (epAstPrint ast) action - <* mapM_ (uncurry printQueuedComment) fcomments) - return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast)) - -censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a -censorM f m = passM (liftM (\x -> (x,f)) m) - -passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a -passM m = RWST $ \r s -> do - ~((a, f),s', EPWriter w) <- runRWST m r s - w' <- f w - return (a, s', EPWriter w') - -advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () -advance cl = do - p <- getPos - colOffset <- getLayoutOffset - printWhitespace (undelta p cl colOffset) - -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -getAndRemoveAnnotation :: (Monad m, Monoid w, Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) - => a -> EP w m (Maybe Annotation) -#else -getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation) -#endif -getAndRemoveAnnotation a = gets (getAnnotationEP a . epAnns) - -markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () -markPrim kwid mstr = - printStringAtMaybeAnn kwid mstr - -withContext :: (Monad m, Monoid w) - => [(KeywordId, DeltaPos)] - -> Annotation - -> EP w m a -> EP w m a -withContext kds an x = withKds kds (withOffset an x) - --- --------------------------------------------------------------------- --- --- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous --- offset --- -withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) -withOffset a = - local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) }) - - --- --------------------------------------------------------------------- --- --- Necessary as there are destructive gets of Kds across scopes -withKds :: (Monad m, Monoid w) => [(KeywordId, DeltaPos)] -> EP w m a -> EP w m a -withKds kd action = do - modify (\s -> s { epAnnKds = kd : epAnnKds s }) - r <- action - modify (\s -> s { epAnnKds = tail (epAnnKds s) }) - return r - ------------------------------------------------------------------------- - -setLayout :: (Monad m, Monoid w) => EP w m () -> EP w m () -setLayout k = do - oldLHS <- gets epLHS - modify (\a -> a { epMarkLayout = True } ) - let reset = modify (\a -> a { epMarkLayout = False - , epLHS = oldLHS } ) - k <* reset - -getPos :: (Monad m, Monoid w) => EP w m Pos -getPos = gets epPos - -setPos :: (Monad m, Monoid w) => Pos -> EP w m () -setPos l = modify (\s -> s {epPos = l}) - --- |Get the current column offset -getLayoutOffset :: (Monad m, Monoid w) => EP w m LayoutStartCol -getLayoutOffset = gets epLHS - --- --------------------------------------------------------------------- - --- |If the first annotation has a smaller SrcSpan than the second, then mark it. --- In the printer this means the first appearing before the second in the list --- of annotations remaining -printMarkAnnBeforeAnn :: (Monad m, Monoid w) => KeywordId -> KeywordId -> EP w m () -printMarkAnnBeforeAnn annBefore annAfter = do - kd <- gets epAnnKds - case kd of - [] -> return () -- Should never be triggered - (k:_kds) -> do - -- find the first ann, then the second. If found in that order, annotate. - let find a = (\(kw,_) -> kw == a) - case break (find annBefore) k of - (_,[]) -> return () -- annBefore not present - (_,rest) -> if null (snd $ break (find annAfter) rest) - then return () - else markPrim annBefore (Nothing) - --- --------------------------------------------------------------------- - -printStringAtMaybeAnn :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () -printStringAtMaybeAnn an mstr = printStringAtMaybeAnnThen an mstr (return ()) - -printStringAtMaybeAnnAll :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () -printStringAtMaybeAnnAll an mstr = go - where - go = printStringAtMaybeAnnThen an mstr go - -printStringAtMaybeAnnThen :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () -> EP w m () -printStringAtMaybeAnnThen an mstr next = do - let str = fromMaybe (keywordToString an) mstr - annFinal <- getAnnFinal an - case (annFinal, an) of -#if __GLASGOW_HASKELL__ <= 710 - -- Could be unicode syntax - -- TODO: This is a bit fishy, refactor - (Nothing, G kw) -> do - res <- getAnnFinal (AnnUnicode kw) - return () `debug` ("printStringAtMaybeAnn:missed:Unicode:(an,res)" ++ show (an,res)) - unless (null res) $ do - forM_ - res - (\(comments, ma) -> printStringAtLsDelta comments ma (unicodeString (G kw))) - next -#else - -- Could be unicode syntax - -- TODO: This is a bit fishy, refactor - (Nothing, G kw') -> do - let kw = GHC.unicodeAnn kw' - let str' = fromMaybe (keywordToString (G kw)) mstr - res <- getAnnFinal (G kw) - return () `debug` ("printStringAtMaybeAnn:missed:Unicode:(an,res)" ++ show (an,res)) - unless (null res) $ do - forM_ - res - (\(comments, ma) -> printStringAtLsDelta comments ma str') - next -#endif - (Just (comments, ma),_) -> printStringAtLsDelta comments ma str >> next - (Nothing, _) -> return () `debug` ("printStringAtMaybeAnn:missed:(an)" ++ show an) - -- Note: do not call next, nothing to chain - -- ++AZ++: Enabling the following line causes a very weird error associated with AnnPackageName. I suspect it is because it is forcing the evaluation of a non-existent an or str - -- `debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str)) - --- --------------------------------------------------------------------- - --- |destructive get, hence use an annotation once only -getAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe ([(Comment, DeltaPos)], DeltaPos)) -getAnnFinal kw = do - kd <- gets epAnnKds - case kd of - [] -> return Nothing -- Should never be triggered - (k:kds) -> do - let (res, kd') = destructiveGetFirst kw ([],k) - modify (\s -> s { epAnnKds = kd' : kds }) - return res - --- | Get and remove the first item in the (k,v) list for which the k matches. --- Return the value, together with any comments skipped over to get there. -destructiveGetFirst :: KeywordId - -> ([(KeywordId, v)],[(KeywordId,v)]) - -> (Maybe ([(Comment, v)], v),[(KeywordId,v)]) -destructiveGetFirst _key (acc,[]) = (Nothing, acc) -destructiveGetFirst key (acc, (k,v):kvs ) - | k == key = (Just (skippedComments, v), others ++ kvs) - | otherwise = destructiveGetFirst key (acc ++ [(k,v)], kvs) - where - (skippedComments, others) = foldr comments ([], []) acc - comments (AnnComment comment , dp ) (cs, kws) = ((comment, dp) : cs, kws) - comments kw (cs, kws) = (cs, kw : kws) - - --- --------------------------------------------------------------------- - --- |This should be the final point where things are mode concrete, --- before output. Hence the point where comments can be inserted -printStringAtLsDelta :: (Monad m, Monoid w) => [(Comment, DeltaPos)] -> DeltaPos -> String -> EP w m () -printStringAtLsDelta cs cl s = do - p <- getPos - colOffset <- getLayoutOffset - if isGoodDeltaWithOffset cl colOffset - then do - mapM_ (uncurry printQueuedComment) cs - printStringAt (undelta p cl colOffset) s - `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) - else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) - - -isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool -isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset)) - -printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () -printQueuedComment Comment{commentContents} dp = do - p <- getPos - colOffset <- getLayoutOffset - let (dr,dc) = undelta (0,0) dp colOffset - -- do not lose comments against the left margin - when (isGoodDelta (DP (dr,max 0 dc))) $ - printCommentAt (undelta p dp colOffset) commentContents - --- --------------------------------------------------------------------- - --- |non-destructive get -peekAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe DeltaPos) -peekAnnFinal kw = do - (r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (ghead "peekAnnFinal" . epAnnKds) - return (snd <$> r) - -countAnnsEP :: (Monad m, Monoid w) => KeywordId -> EP w m Int -countAnnsEP an = length <$> peekAnnFinal an - --- --------------------------------------------------------------------- - - --- --------------------------------------------------------------------- --- Printing functions - -printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () -printString layout str = do - EPState{epPos = (_,c), epMarkLayout} <- get - PrintOptions{epTokenPrint, epWhitespacePrint} <- ask - when (epMarkLayout && layout) $ - modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ) - - -- Advance position, taking care of any newlines in the string - let strDP@(DP (cr,_cc)) = dpFromString str - p <- getPos - colOffset <- getLayoutOffset - if cr == 0 - then setPos (undelta p strDP colOffset) - else setPos (undelta p strDP 1) - - -- - if not layout && c == 0 - then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} - else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} - - -newLine :: (Monad m, Monoid w) => EP w m () -newLine = do - (l,_) <- getPos - printString False "\n" - setPos (l+1,1) - -padUntil :: (Monad m, Monoid w) => Pos -> EP w m () -padUntil (l,c) = do - (l1,c1) <- getPos - if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' ' - | l1 < l -> newLine >> padUntil (l,c) - | otherwise -> return () - -printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m () -printWhitespace = padUntil - -printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () -printCommentAt p str = printWhitespace p >> printString False str - -printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () -printStringAt p str = printWhitespace p >> printString True str diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -1,1398 +1,1491 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.GHC.ExactPrint.Transform --- --- This module is currently under heavy development, and no promises are made --- about API stability. Use with care. --- --- We welcome any feedback / contributions on this, as it is the main point of --- the library. --- ------------------------------------------------------------------------------ -module Language.Haskell.GHC.ExactPrint.Transform - ( - -- * The Transform Monad - Transform - , TransformT(..) - , hoistTransform - , runTransform - , runTransformT - , runTransformFrom - , runTransformFromT - - -- * Transform monad operations - , logTr - , logDataWithAnnsTr - , getAnnsT, putAnnsT, modifyAnnsT - , uniqueSrcSpanT - - , cloneT - , graftT - - , getEntryDPT - , setEntryDPT - , transferEntryDPT - , setPrecedingLinesDeclT - , setPrecedingLinesT - , addSimpleAnnT - , addTrailingCommaT - , removeTrailingCommaT - - -- ** Managing declarations, in Transform monad - , HasTransform (..) - , HasDecls (..) - , hasDeclsSybTransform - , hsDeclsGeneric - , hsDeclsPatBind, hsDeclsPatBindD - , replaceDeclsPatBind, replaceDeclsPatBindD - , modifyDeclsT - , modifyValD - -- *** Utility, does not manage layout - , hsDeclsValBinds, replaceDeclsValbinds - - -- ** Managing lists, Transform monad - , insertAtStart - , insertAtEnd - , insertAfter - , insertBefore - - -- *** Low level operations used in 'HasDecls' - , balanceComments - , balanceTrailingComments - , moveTrailingComments - - -- ** Managing lists, pure functions - , captureOrder - , captureOrderAnnKey - - -- * Operations - , isUniqueSrcSpan - - -- * Pure functions - , mergeAnns - , mergeAnnList - , setPrecedingLinesDecl - , setPrecedingLines - , getEntryDP - , setEntryDP - , transferEntryDP - , addTrailingComma - , wrapSig, wrapDecl - , decl2Sig, decl2Bind - - ) where - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import Control.Monad.RWS -import qualified Control.Monad.Fail as Fail - -import qualified GHC as GHC hiding (parseModule) -#if __GLASGOW_HASKELL__ >= 900 -import qualified GHC.Data.Bag as GHC -import qualified GHC.Data.FastString as GHC -#else -import qualified Bag as GHC -import qualified FastString as GHC -#endif - -import qualified Data.Generics as SYB - -import Data.Data -import Data.List -import Data.Maybe - -import qualified Data.Map as Map - -import Data.Functor.Identity -import Control.Monad.State -import Control.Monad.Writer - --- import Debug.Trace - ------------------------------------------------------------------------------- --- Transformation of source elements - --- | Monad type for updating the AST and managing the annotations at the same --- time. The W state is used to generate logging information if required. -type Transform = TransformT Identity - --- |Monad transformer version of 'Transform' monad -newtype TransformT m a = TransformT { unTransformT :: RWST () [String] (Anns,Int) m a } - deriving (Monad,Applicative,Functor - ,MonadReader () - ,MonadWriter [String] - ,MonadState (Anns,Int) - ,MonadTrans - ) - -instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where - fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg - --- | Run a transformation in the 'Transform' monad, returning the updated --- annotations and any logging generated via 'logTr' -runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String]) -runTransform ans f = runTransformFrom 0 ans f - -runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String]) -runTransformT ans f = runTransformFromT 0 ans f - --- | Run a transformation in the 'Transform' monad, returning the updated --- annotations and any logging generated via 'logTr', allocating any new --- SrcSpans from the provided initial value. -runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String]) -runTransformFrom seed ans f = runRWS (unTransformT f) () (ans,seed) - --- |Run a monad transformer stack for the 'TransformT' monad transformer -runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String]) -runTransformFromT seed ans f = runRWST (unTransformT f) () (ans,seed) - --- | Change inner monad of 'TransformT'. -hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a -hoistTransform nt (TransformT m) = TransformT (mapRWST nt m) - --- |Log a string to the output of the Monad -logTr :: (Monad m) => String -> TransformT m () -logTr str = tell [str] - --- |Log a representation of the given AST with annotations to the output of the --- Monad -logDataWithAnnsTr :: (Monad m) => (SYB.Data a) => String -> a -> TransformT m () -logDataWithAnnsTr str ast = do - anns <- getAnnsT - logTr $ str ++ showAnnData anns 0 ast - --- |Access the 'Anns' being modified in this transformation -getAnnsT :: (Monad m) => TransformT m Anns -getAnnsT = gets fst - --- |Replace the 'Anns' after any changes -putAnnsT :: (Monad m) => Anns -> TransformT m () -putAnnsT ans = do - (_,col) <- get - put (ans,col) - --- |Change the stored 'Anns' -modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m () -modifyAnnsT f = do - ans <- getAnnsT - putAnnsT (f ans) - --- --------------------------------------------------------------------- - --- |Once we have 'Anns', a 'GHC.SrcSpan' is used purely as part of an 'AnnKey' --- to index into the 'Anns'. If we need to add new elements to the AST, they --- need their own 'GHC.SrcSpan' for this. -uniqueSrcSpanT :: (Monad m) => TransformT m GHC.SrcSpan -uniqueSrcSpanT = do - (an,col) <- get - put (an,col + 1 ) - let pos = GHC.mkSrcLoc (GHC.mkFastString "ghc-exactprint") (-1) col - return $ GHC.mkSrcSpan pos pos - --- |Test whether a given 'GHC.SrcSpan' was generated by 'uniqueSrcSpanT' -isUniqueSrcSpan :: GHC.SrcSpan -> Bool -isUniqueSrcSpan ss = srcSpanStartLine ss == -1 - --- --------------------------------------------------------------------- --- |Make a copy of an AST element, replacing the existing SrcSpans with new --- ones, and duplicating the matching annotations. -cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(GHC.SrcSpan, GHC.SrcSpan)]) -cloneT ast = do - runWriterT $ SYB.everywhereM (return `SYB.ext2M` replaceLocated) ast - where - replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m) - => (GHC.GenLocated loc a) -> WriterT [(GHC.SrcSpan, GHC.SrcSpan)] (TransformT m) (GHC.GenLocated loc a) - replaceLocated (GHC.L l t) = do - case cast l :: Maybe GHC.SrcSpan of - Just ss -> do - newSpan <- lift uniqueSrcSpanT - lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) anns of - Nothing -> anns - Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns) - tell [(ss, newSpan)] - return $ fromJust . cast $ GHC.L newSpan t - Nothing -> return (GHC.L l t) - --- --------------------------------------------------------------------- --- |Slightly more general form of cloneT -graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a -graftT origAnns = SYB.everywhereM (return `SYB.ext2M` replaceLocated) - where - replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m) - => GHC.GenLocated loc a -> TransformT m (GHC.GenLocated loc a) - replaceLocated (GHC.L l t) = do - case cast l :: Maybe GHC.SrcSpan of - Just ss -> do - newSpan <- uniqueSrcSpanT - modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) origAnns of - Nothing -> anns - Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns) - return $ fromJust $ cast $ GHC.L newSpan t - Nothing -> return (GHC.L l t) - --- --------------------------------------------------------------------- - --- |If a list has been re-ordered or had items added, capture the new order in --- the appropriate 'annSortKey' attached to the 'Annotation' for the first --- parameter. -captureOrder :: (Data a) => GHC.Located a -> [GHC.Located b] -> Anns -> Anns -captureOrder parent ls ans = captureOrderAnnKey (mkAnnKey parent) ls ans - --- |If a list has been re-ordered or had items added, capture the new order in --- the appropriate 'annSortKey' item of the supplied 'AnnKey' -captureOrderAnnKey :: AnnKey -> [GHC.Located b] -> Anns -> Anns -captureOrderAnnKey parentKey ls ans = ans' - where - newList = map (rs . GHC.getLoc) ls - reList = Map.adjust (\an -> an {annSortKey = Just newList }) parentKey - ans' = reList ans - --- --------------------------------------------------------------------- - --- |Pure function to convert a 'GHC.LHsDecl' to a 'GHC.LHsBind'. This does --- nothing to any annotations that may be attached to either of the elements. --- It is used as a utility function in 'replaceDecls' -decl2Bind :: GHC.LHsDecl name -> [GHC.LHsBind name] -#if __GLASGOW_HASKELL__ > 804 -decl2Bind (GHC.L l (GHC.ValD _ s)) = [GHC.L l s] -#else -decl2Bind (GHC.L l (GHC.ValD s)) = [GHC.L l s] -#endif -decl2Bind _ = [] - --- |Pure function to convert a 'GHC.LSig' to a 'GHC.LHsBind'. This does --- nothing to any annotations that may be attached to either of the elements. --- It is used as a utility function in 'replaceDecls' -decl2Sig :: GHC.LHsDecl name -> [GHC.LSig name] -#if __GLASGOW_HASKELL__ > 804 -decl2Sig (GHC.L l (GHC.SigD _ s)) = [GHC.L l s] -#else -decl2Sig (GHC.L l (GHC.SigD s)) = [GHC.L l s] -#endif -decl2Sig _ = [] - --- --------------------------------------------------------------------- - --- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl' -wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs -#if __GLASGOW_HASKELL__ > 808 -wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.NoExtField s) -#elif __GLASGOW_HASKELL__ > 804 -wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.noExt s) -#else -wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s) -#endif - --- --------------------------------------------------------------------- - --- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl' -wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs -#if __GLASGOW_HASKELL__ > 808 -wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.NoExtField s) -#elif __GLASGOW_HASKELL__ > 804 -wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.noExt s) -#else -wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s) -#endif - --- --------------------------------------------------------------------- - --- |Create a simple 'Annotation' without comments, and attach it to the first --- parameter. -addSimpleAnnT :: (Constraints a,Monad m) -#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) - => a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () -#else - => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () -#endif -addSimpleAnnT ast dp kds = do - let ann = annNone { annEntryDelta = dp - , annsDP = kds - } - modifyAnnsT (Map.insert (mkAnnKey ast) ann) - --- --------------------------------------------------------------------- - --- |Add a trailing comma annotation, unless there is already one -addTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m () -addTrailingCommaT ast = do - modifyAnnsT (addTrailingComma ast (DP (0,0))) - --- --------------------------------------------------------------------- - --- |Remove a trailing comma annotation, if there is one one -removeTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m () -removeTrailingCommaT ast = do - modifyAnnsT (removeTrailingComma ast) - --- --------------------------------------------------------------------- - --- |'Transform' monad version of 'getEntryDP' -#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) -getEntryDPT :: (Constraints a,Monad m) => a -> TransformT m DeltaPos -#else -getEntryDPT :: (Data a,Monad m) => GHC.Located a -> TransformT m DeltaPos -#endif -getEntryDPT ast = do - anns <- getAnnsT - return (getEntryDP anns ast) - --- --------------------------------------------------------------------- - --- |'Transform' monad version of 'getEntryDP' -#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) -setEntryDPT :: (Constraints a,Monad m) => a -> DeltaPos -> TransformT m () -#else -setEntryDPT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> TransformT m () -#endif -setEntryDPT ast dp = do - modifyAnnsT (setEntryDP ast dp) - --- --------------------------------------------------------------------- - --- |'Transform' monad version of 'transferEntryDP' -transferEntryDPT :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m () -transferEntryDPT a b = - modifyAnnsT (transferEntryDP a b) - --- --------------------------------------------------------------------- - --- |'Transform' monad version of 'setPrecedingLinesDecl' -setPrecedingLinesDeclT :: (Monad m) => GHC.LHsDecl GhcPs -> Int -> Int -> TransformT m () -setPrecedingLinesDeclT ld n c = - modifyAnnsT (setPrecedingLinesDecl ld n c) - --- --------------------------------------------------------------------- - --- |'Transform' monad version of 'setPrecedingLines' -setPrecedingLinesT :: (SYB.Data a,Monad m) => GHC.Located a -> Int -> Int -> TransformT m () -setPrecedingLinesT ld n c = - modifyAnnsT (setPrecedingLines ld n c) - --- --------------------------------------------------------------------- - --- | Left bias pair union -mergeAnns :: Anns -> Anns -> Anns -mergeAnns - = Map.union - --- |Combine a list of annotations -mergeAnnList :: [Anns] -> Anns -mergeAnnList [] = error "mergeAnnList must have at lease one entry" -mergeAnnList (x:xs) = foldr mergeAnns x xs - --- --------------------------------------------------------------------- - --- |Unwrap a HsDecl and call setPrecedingLines on it --- ++AZ++ TODO: get rid of this, it is a synonym only -setPrecedingLinesDecl :: GHC.LHsDecl GhcPs -> Int -> Int -> Anns -> Anns -setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans - --- --------------------------------------------------------------------- - --- | Adjust the entry annotations to provide an `n` line preceding gap -setPrecedingLines :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Anns -> Anns -setPrecedingLines ast n c anne = setEntryDP ast (DP (n,c)) anne - --- --------------------------------------------------------------------- - --- |Return the true entry 'DeltaPos' from the annotation for a given AST --- element. This is the 'DeltaPos' ignoring any comments. -#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) -getEntryDP :: (Constraints a) => Anns -> a -> DeltaPos -#else -getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos -#endif -getEntryDP anns ast = - case Map.lookup (mkAnnKey ast) anns of - Nothing -> DP (0,0) - Just ann -> annTrueEntryDelta ann - --- --------------------------------------------------------------------- - --- |Set the true entry 'DeltaPos' from the annotation for a given AST --- element. This is the 'DeltaPos' ignoring any comments. -#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) -setEntryDP :: (Constraints a) => a -> DeltaPos -> Anns -> Anns -#else -setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns -#endif -setEntryDP ast dp anns = - case Map.lookup (mkAnnKey ast) anns of - Nothing -> Map.insert (mkAnnKey ast) (annNone { annEntryDelta = dp}) anns - Just ann -> Map.insert (mkAnnKey ast) (ann' { annEntryDelta = annCommentEntryDelta ann' dp}) anns - where - ann' = setCommentEntryDP ann dp - --- --------------------------------------------------------------------- - --- |When setting an entryDP, the leading comment needs to be adjusted too -setCommentEntryDP :: Annotation -> DeltaPos -> Annotation --- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann' -setCommentEntryDP ann dp = ann' - where - ann' = case (annPriorComments ann) of - [] -> ann - [(pc,_)] -> ann { annPriorComments = [(pc,dp)] } - ((pc,_):pcs) -> ann { annPriorComments = ((pc,dp):pcs) } - --- --------------------------------------------------------------------- - --- |Take the annEntryDelta associated with the first item and associate it with the second. --- Also transfer any comments occuring before it. -transferEntryDP :: (SYB.Data a, SYB.Data b) => GHC.Located a -> GHC.Located b -> Anns -> Anns -transferEntryDP a b anns = (const anns2) anns - where - maybeAnns = do -- Maybe monad - anA <- Map.lookup (mkAnnKey a) anns - anB <- Map.lookup (mkAnnKey b) anns - let anB' = Ann - { annEntryDelta = DP (0,0) -- Need to adjust for comments after - , annPriorComments = annPriorComments anB - , annFollowingComments = annFollowingComments anB - , annsDP = annsDP anB - , annSortKey = annSortKey anB - , annCapturedSpan = annCapturedSpan anB - } - return ((Map.insert (mkAnnKey b) anB' anns),annLeadingCommentEntryDelta anA) - (anns',dp) = fromMaybe - (error $ "transferEntryDP: lookup failed (a,b)=" ++ show (mkAnnKey a,mkAnnKey b)) - maybeAnns - anns2 = setEntryDP b dp anns' - --- --------------------------------------------------------------------- - -addTrailingComma :: (SYB.Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns -addTrailingComma a dp anns = - case Map.lookup (mkAnnKey a) anns of - Nothing -> anns - Just an -> - case find isAnnComma (annsDP an) of - Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G GHC.AnnComma,dp)]}) anns - Just _ -> anns - where - isAnnComma (G GHC.AnnComma,_) = True - isAnnComma _ = False - --- --------------------------------------------------------------------- - -removeTrailingComma :: (SYB.Data a) => GHC.Located a -> Anns -> Anns -removeTrailingComma a anns = - case Map.lookup (mkAnnKey a) anns of - Nothing -> anns - Just an -> - case find isAnnComma (annsDP an) of - Nothing -> anns - Just _ -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns - where - isAnnComma (G GHC.AnnComma,_) = True - isAnnComma _ = False - --- --------------------------------------------------------------------- - --- |The relatavise phase puts all comments appearing between the end of one AST --- item and the beginning of the next as 'annPriorComments' for the second one. --- This function takes two adjacent AST items and moves any 'annPriorComments' --- from the second one to the 'annFollowingComments' of the first if they belong --- to it instead. This is typically required before deleting or duplicating --- either of the AST elements. -balanceComments :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m () -balanceComments first second = do - -- ++AZ++ : replace the nested casts with appropriate SYB.gmapM - -- logTr $ "balanceComments entered" - -- logDataWithAnnsTr "first" first - case cast first :: Maybe (GHC.LHsDecl GhcPs) of -#if __GLASGOW_HASKELL__ > 804 - Just (GHC.L l (GHC.ValD _ fb@(GHC.FunBind{}))) -> do -#else - Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do -#endif - balanceCommentsFB (GHC.L l fb) second - _ -> case cast first :: Maybe (GHC.LHsBind GhcPs) of - Just fb'@(GHC.L _ (GHC.FunBind{})) -> do - balanceCommentsFB fb' second - _ -> balanceComments' first second - --- |Prior to moving an AST element, make sure any trailing comments belonging to --- it are attached to it, and not the following element. Of necessity this is a --- heuristic process, to be tuned later. Possibly a variant should be provided --- with a passed-in decision function. -balanceComments' :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m () -balanceComments' first second = do - let - k1 = mkAnnKey first - k2 = mkAnnKey second - moveComments p ans = ans' - where - an1 = gfromJust "balanceComments' k1" $ Map.lookup k1 ans - an2 = gfromJust "balanceComments' k2" $ Map.lookup k2 ans - cs1f = annFollowingComments an1 - cs2b = annPriorComments an2 - (move,stay) = break p cs2b - an1' = an1 { annFollowingComments = cs1f ++ move} - an2' = an2 { annPriorComments = stay} - ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - - simpleBreak (_,DP (r,_c)) = r > 0 - - modifyAnnsT (moveComments simpleBreak) - --- |Once 'balanceComments' has been called to move trailing comments to a --- 'GHC.FunBind', these need to be pushed down from the top level to the last --- 'GHC.Match' if that 'GHC.Match' needs to be manipulated. -balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m () -#if __GLASGOW_HASKELL__ >= 900 -balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _)) second = do -#elif __GLASGOW_HASKELL__ > 808 -balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do -#elif __GLASGOW_HASKELL__ > 804 -balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do -#elif __GLASGOW_HASKELL__ > 710 -balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do -#else -balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do -#endif - -- logTr $ "balanceCommentsFB entered" - balanceComments' (last matches) second -balanceCommentsFB f s = balanceComments' f s - --- --------------------------------------------------------------------- - - --- |After moving an AST element, make sure any comments that may belong --- with the following element in fact do. Of necessity this is a heuristic --- process, to be tuned later. Possibly a variant should be provided with a --- passed-in decision function. -balanceTrailingComments :: (Monad m) => (Data a,Data b) => GHC.Located a -> GHC.Located b - -> TransformT m [(Comment, DeltaPos)] -balanceTrailingComments first second = do - let - k1 = mkAnnKey first - k2 = mkAnnKey second - moveComments p ans = (ans',move) - where - an1 = gfromJust "balanceTrailingComments k1" $ Map.lookup k1 ans - an2 = gfromJust "balanceTrailingComments k2" $ Map.lookup k2 ans - cs1f = annFollowingComments an1 - (move,stay) = break p cs1f - an1' = an1 { annFollowingComments = stay } - ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans - - simpleBreak (_,DP (r,_c)) = r > 0 - - ans <- getAnnsT - let (ans',mov) = moveComments simpleBreak ans - putAnnsT ans' - return mov - --- --------------------------------------------------------------------- - --- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for --- |Move any 'annFollowingComments' values from the 'Annotation' associated to --- the first parameter to that of the second. -moveTrailingComments :: (Data a,Data b) - => GHC.Located a -> GHC.Located b -> Transform () -moveTrailingComments first second = do - let - k1 = mkAnnKey first - k2 = mkAnnKey second - moveComments ans = ans' - where - an1 = gfromJust "moveTrailingComments k1" $ Map.lookup k1 ans - an2 = gfromJust "moveTrailingComments k2" $ Map.lookup k2 ans - cs1f = annFollowingComments an1 - cs2f = annFollowingComments an2 - an1' = an1 { annFollowingComments = [] } - an2' = an2 { annFollowingComments = cs1f ++ cs2f } - ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans - - modifyAnnsT moveComments - --- --------------------------------------------------------------------- - --- |Insert a declaration into an AST element having sub-declarations --- (@HasDecls@) according to the given location function. -insertAt :: (HasDecls (GHC.Located ast)) - => (GHC.LHsDecl GhcPs - -> [GHC.LHsDecl GhcPs] - -> [GHC.LHsDecl GhcPs]) - -> GHC.Located ast - -> GHC.LHsDecl GhcPs - -> Transform (GHC.Located ast) -insertAt f t decl = do - oldDecls <- hsDecls t - replaceDecls t (f decl oldDecls) - --- |Insert a declaration at the beginning or end of the subdecls of the given --- AST item -insertAtStart, insertAtEnd :: (HasDecls (GHC.Located ast)) - => GHC.Located ast - -> GHC.LHsDecl GhcPs - -> Transform (GHC.Located ast) - -insertAtStart = insertAt (:) -insertAtEnd = insertAt (\x xs -> xs ++ [x]) - --- |Insert a declaration at a specific location in the subdecls of the given --- AST item -insertAfter, insertBefore :: (HasDecls (GHC.Located ast)) - => GHC.Located old - -> GHC.Located ast - -> GHC.LHsDecl GhcPs - -> Transform (GHC.Located ast) -insertAfter (GHC.getLoc -> k) = insertAt findAfter - where - findAfter x xs = - let (fs, b:bs) = span (\(GHC.L l _) -> l /= k) xs - in fs ++ (b : x : bs) -insertBefore (GHC.getLoc -> k) = insertAt findBefore - where - findBefore x xs = - let (fs, bs) = span (\(GHC.L l _) -> l /= k) xs - in fs ++ (x : bs) - --- ===================================================================== --- start of HasDecls instances --- ===================================================================== - --- |Provide a means to get and process the immediate child declartions of a --- given AST element. -class (Data t) => HasDecls t where --- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent - - -- | Return the 'GHC.HsDecl's that are directly enclosed in the - -- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl' - -- form, even if orginating in local decls. This is safe, as annotations - -- never attach to the wrapper, only to the wrapped item. - hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs] - - -- | Replace the directly enclosed decl list by the given - -- decl list. Runs in the 'Transform' monad to be able to update list order - -- annotations, and rebalance comments and other layout changes as needed. - -- - -- For example, a call on replaceDecls for a wrapped 'GHC.FunBind' having no - -- where clause will convert - -- - -- @ - -- -- |This is a function - -- foo = x -- comment1 - -- @ - -- in to - -- - -- @ - -- -- |This is a function - -- foo = x -- comment1 - -- where - -- nn = 2 - -- @ - replaceDecls :: (Monad m) => t -> [GHC.LHsDecl GhcPs] -> TransformT m t - --- --------------------------------------------------------------------- - -instance HasDecls GHC.ParsedSource where -#if __GLASGOW_HASKELL__ >= 900 - hsDecls (GHC.L _ (GHC.HsModule _lo _mn _exps _imps decls _ _)) = return decls - replaceDecls m@(GHC.L l (GHC.HsModule lo mn exps imps _decls deps haddocks)) decls - = do - logTr "replaceDecls LHsModule" - modifyAnnsT (captureOrder m decls) - return (GHC.L l (GHC.HsModule lo mn exps imps decls deps haddocks)) -#else - hsDecls (GHC.L _ (GHC.HsModule _mn _exps _imps decls _ _)) = return decls - replaceDecls m@(GHC.L l (GHC.HsModule mn exps imps _decls deps haddocks)) decls - = do - logTr "replaceDecls LHsModule" - modifyAnnsT (captureOrder m decls) - return (GHC.L l (GHC.HsModule mn exps imps decls deps haddocks)) -#endif - --- --------------------------------------------------------------------- - -instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where -#if __GLASGOW_HASKELL__ > 804 - hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _ (GHC.L _ lb)))) = do -#elif __GLASGOW_HASKELL__ >= 804 - hsDecls d@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do -#elif __GLASGOW_HASKELL__ >= 800 - hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do -#elif __GLASGOW_HASKELL__ >= 710 - hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do -#else - hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do -#endif - decls <- hsDeclsValBinds lb - orderedDecls d decls -#if __GLASGOW_HASKELL__ > 804 - hsDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) = return [] - hsDecls (GHC.L _ (GHC.XMatch _)) = return [] -#endif - - -#if __GLASGOW_HASKELL__ > 804 - replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) [] -#elif __GLASGOW_HASKELL__ >= 804 - replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) [] -#else - replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) [] -#endif - = do - logTr "replaceDecls LMatch" - let - noWhere (G GHC.AnnWhere,_) = False - noWhere _ = True - - removeWhere mkds = - case Map.lookup (mkAnnKey m) mkds of - Nothing -> error "wtf" - Just ann -> Map.insert (mkAnnKey m) ann1 mkds - where - ann1 = ann { annsDP = filter noWhere (annsDP ann) - } - modifyAnnsT removeWhere - -#if __GLASGOW_HASKELL__ <= 710 - binds' <- replaceDeclsValbinds binds [] -#else - binds'' <- replaceDeclsValbinds (GHC.unLoc binds) [] - let binds' = GHC.L (GHC.getLoc binds) binds'' -#endif -#if __GLASGOW_HASKELL__ > 804 - return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds'))) -#elif __GLASGOW_HASKELL__ >= 804 - return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) -#else - return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) -#endif - -#if __GLASGOW_HASKELL__ > 804 - replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) newBinds -#elif __GLASGOW_HASKELL__ >= 804 - replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) newBinds -#else - replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds -#endif - = do - logTr "replaceDecls LMatch" - -- Need to throw in a fresh where clause if the binds were empty, - -- in the annotations. -#if __GLASGOW_HASKELL__ <= 710 - case binds of -#else - case GHC.unLoc binds of -#endif -#if __GLASGOW_HASKELL__ > 804 - GHC.EmptyLocalBinds{} -> do -#else - GHC.EmptyLocalBinds -> do -#endif - let - addWhere mkds = - case Map.lookup (mkAnnKey m) mkds of - Nothing -> error "wtf" - Just ann -> Map.insert (mkAnnKey m) ann1 mkds - where - ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))] - } - modifyAnnsT addWhere - modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4) - - -- only move the comment if the original where clause was empty. - toMove <- balanceTrailingComments m m - insertCommentBefore (mkAnnKey m) toMove (matchApiAnn GHC.AnnWhere) - _ -> return () - - modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds) -#if __GLASGOW_HASKELL__ <= 710 - binds' <- replaceDeclsValbinds binds newBinds -#else - binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newBinds - let binds' = GHC.L (GHC.getLoc binds) binds'' -#endif - -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds' -#if __GLASGOW_HASKELL__ > 804 - return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds'))) -#elif __GLASGOW_HASKELL__ >= 804 - return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) -#else - return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) -#endif -#if __GLASGOW_HASKELL__ > 804 - replaceDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) _ = error "replaceDecls" - replaceDecls (GHC.L _ (GHC.XMatch _)) _ = error "replaceDecls" -#endif - --- --------------------------------------------------------------------- - -instance HasDecls (GHC.LHsExpr GhcPs) where -#if __GLASGOW_HASKELL__ > 804 - hsDecls ls@(GHC.L _ (GHC.HsLet _ (GHC.L _ decls) _ex)) = do -#elif __GLASGOW_HASKELL__ > 710 - hsDecls ls@(GHC.L _ (GHC.HsLet (GHC.L _ decls) _ex)) = do -#else - hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do -#endif - ds <- hsDeclsValBinds decls - orderedDecls ls ds - hsDecls _ = return [] - -#if __GLASGOW_HASKELL__ > 804 - replaceDecls e@(GHC.L l (GHC.HsLet x decls ex)) newDecls -#else - replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls -#endif - = do - logTr "replaceDecls HsLet" - modifyAnnsT (captureOrder e newDecls) -#if __GLASGOW_HASKELL__ <= 710 - decls' <- replaceDeclsValbinds decls newDecls -#else - decls'' <- replaceDeclsValbinds (GHC.unLoc decls) newDecls - let decls' = GHC.L (GHC.getLoc decls) decls'' -#endif -#if __GLASGOW_HASKELL__ > 804 - return (GHC.L l (GHC.HsLet x decls' ex)) -#else - return (GHC.L l (GHC.HsLet decls' ex)) -#endif - -#if __GLASGOW_HASKELL__ > 804 - replaceDecls (GHC.L l (GHC.HsPar x e)) newDecls -#else - replaceDecls (GHC.L l (GHC.HsPar e)) newDecls -#endif - = do - logTr "replaceDecls HsPar" - e' <- replaceDecls e newDecls -#if __GLASGOW_HASKELL__ > 804 - return (GHC.L l (GHC.HsPar x e')) -#else - return (GHC.L l (GHC.HsPar e')) -#endif - replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GhcPs) undefined for:" ++ showGhc old - --- --------------------------------------------------------------------- - --- | Extract the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This --- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is --- idempotent. -hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -#if __GLASGOW_HASKELL__ > 804 -hsDeclsPatBindD (GHC.L l (GHC.ValD _ d)) = hsDeclsPatBind (GHC.L l d) -#else -hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d) -#endif -hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x - --- | Extract the immediate declarations for a 'GHC.PatBind'. This --- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is --- idempotent. -hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -#if __GLASGOW_HASKELL__ > 804 -hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ _ (GHC.GRHSs _ _grhs (GHC.L _ lb)) _)) = do -#elif __GLASGOW_HASKELL__ > 710 -hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs (GHC.L _ lb)) _ _ _)) = do -#else -hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do -#endif - decls <- hsDeclsValBinds lb - orderedDecls d decls -hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x - --- ------------------------------------- - --- | Replace the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This --- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is --- idempotent. -replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs] - -> TransformT m (GHC.LHsDecl GhcPs) -#if __GLASGOW_HASKELL__ > 804 -replaceDeclsPatBindD (GHC.L l (GHC.ValD x d)) newDecls = do - (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls - return (GHC.L l (GHC.ValD x d')) -#else -replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do - (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls - return (GHC.L l (GHC.ValD d')) -#endif -replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x - --- | Replace the immediate declarations for a 'GHC.PatBind'. This --- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is --- idempotent. -replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> [GHC.LHsDecl GhcPs] - -> TransformT m (GHC.LHsBind GhcPs) -#if __GLASGOW_HASKELL__ > 804 -replaceDeclsPatBind p@(GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds) b)) newDecls -#else -replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls -#endif - = do - logTr "replaceDecls PatBind" - -- Need to throw in a fresh where clause if the binds were empty, - -- in the annotations. -#if __GLASGOW_HASKELL__ <= 710 - case binds of -#else - case GHC.unLoc binds of -#endif -#if __GLASGOW_HASKELL__ > 804 - GHC.EmptyLocalBinds{} -> do -#else - GHC.EmptyLocalBinds -> do -#endif - let - addWhere mkds = - case Map.lookup (mkAnnKey p) mkds of - Nothing -> error "wtf" - Just ann -> Map.insert (mkAnnKey p) ann1 mkds - where - ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))] - } - modifyAnnsT addWhere - modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4) - - _ -> return () - - modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls) -#if __GLASGOW_HASKELL__ <= 710 - binds' <- replaceDeclsValbinds binds newDecls -#else - binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newDecls - let binds' = GHC.L (GHC.getLoc binds) binds'' -#endif -#if __GLASGOW_HASKELL__ > 804 - return (GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds') b)) -#else - return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d)) -#endif -replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where -#if __GLASGOW_HASKELL__ > 804 - hsDecls ls@(GHC.L _ (GHC.LetStmt _ (GHC.L _ lb))) = do -#elif __GLASGOW_HASKELL__ > 710 - hsDecls ls@(GHC.L _ (GHC.LetStmt (GHC.L _ lb))) = do -#else - hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do -#endif - decls <- hsDeclsValBinds lb - orderedDecls ls decls -#if __GLASGOW_HASKELL__ > 804 - hsDecls (GHC.L _ (GHC.LastStmt _ e _ _)) = hsDecls e -#elif __GLASGOW_HASKELL__ >= 804 - hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e -#elif __GLASGOW_HASKELL__ > 800 - hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e -#elif __GLASGOW_HASKELL__ > 710 - hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e -#else - hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e -#endif -#if __GLASGOW_HASKELL__ >= 900 - hsDecls (GHC.L _ (GHC.BindStmt _ _pat e)) = hsDecls e -#elif __GLASGOW_HASKELL__ > 804 - hsDecls (GHC.L _ (GHC.BindStmt _ _pat e _ _)) = hsDecls e -#elif __GLASGOW_HASKELL__ > 710 - hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _ _)) = hsDecls e -#else - hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e -#endif -#if __GLASGOW_HASKELL__ > 804 - hsDecls (GHC.L _ (GHC.BodyStmt _ e _ _)) = hsDecls e -#else - hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsDecls e -#endif - hsDecls _ = return [] - -#if __GLASGOW_HASKELL__ > 804 - replaceDecls s@(GHC.L l (GHC.LetStmt x lb)) newDecls -#else - replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls -#endif - = do - modifyAnnsT (captureOrder s newDecls) -#if __GLASGOW_HASKELL__ <= 710 - lb' <- replaceDeclsValbinds lb newDecls -#else - lb'' <- replaceDeclsValbinds (GHC.unLoc lb) newDecls - let lb' = GHC.L (GHC.getLoc lb) lb'' -#endif -#if __GLASGOW_HASKELL__ > 804 - return (GHC.L l (GHC.LetStmt x lb')) -#else - return (GHC.L l (GHC.LetStmt lb')) -#endif -#if __GLASGOW_HASKELL__ > 804 - replaceDecls (GHC.L l (GHC.LastStmt x e d se)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.LastStmt x e' d se)) -#elif __GLASGOW_HASKELL__ > 710 - replaceDecls (GHC.L l (GHC.LastStmt e d se)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.LastStmt e' d se)) -#else - replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.LastStmt e' se)) -#endif -#if __GLASGOW_HASKELL__ >= 900 - replaceDecls (GHC.L l (GHC.BindStmt x pat e)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.BindStmt x pat e')) -#elif __GLASGOW_HASKELL__ > 804 - replaceDecls (GHC.L l (GHC.BindStmt x pat e a b)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.BindStmt x pat e' a b)) -#elif __GLASGOW_HASKELL__ > 710 - replaceDecls (GHC.L l (GHC.BindStmt pat e a b c)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.BindStmt pat e' a b c)) -#else - replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.BindStmt pat e' a b)) -#endif - -#if __GLASGOW_HASKELL__ > 804 - replaceDecls (GHC.L l (GHC.BodyStmt x e a b)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.BodyStmt x e' a b)) -#else - replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls - = do - e' <- replaceDecls e newDecls - return (GHC.L l (GHC.BodyStmt e' a b c)) -#endif - replaceDecls x _newDecls = return x - --- ===================================================================== --- end of HasDecls instances --- ===================================================================== - --- --------------------------------------------------------------------- - --- |Do a transformation on an AST fragment by providing a function to process --- the general case and one specific for a 'GHC.LHsBind'. This is required --- because a 'GHC.FunBind' may have multiple 'GHC.Match' items, so we cannot --- gurantee that 'replaceDecls' after 'hsDecls' is idempotent. -hasDeclsSybTransform :: (SYB.Data t2,Monad m) - => (forall t. HasDecls t => t -> m t) - -- ^Worker function for the general case - -> (GHC.LHsBind GhcPs -> m (GHC.LHsBind GhcPs)) - -- ^Worker function for FunBind/PatBind - -> t2 -- ^Item to be updated - -> m t2 -hasDeclsSybTransform workerHasDecls workerBind t = trf t - where - trf = SYB.mkM parsedSource - `SYB.extM` lmatch - `SYB.extM` lexpr - `SYB.extM` lstmt - `SYB.extM` lhsbind - `SYB.extM` lvald - - parsedSource (p::GHC.ParsedSource) = workerHasDecls p - - lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) - = workerHasDecls lm - - lexpr (le::GHC.LHsExpr GhcPs) - = workerHasDecls le - - lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) - = workerHasDecls d - - lhsbind (b@(GHC.L _ GHC.FunBind{}):: GHC.LHsBind GhcPs) - = workerBind b - lhsbind b@(GHC.L _ GHC.PatBind{}) - = workerBind b - lhsbind x = return x - -#if __GLASGOW_HASKELL__ > 804 - lvald (GHC.L l (GHC.ValD x d)) = do - (GHC.L _ d') <- lhsbind (GHC.L l d) - return (GHC.L l (GHC.ValD x d')) -#else - lvald (GHC.L l (GHC.ValD d)) = do - (GHC.L _ d') <- lhsbind (GHC.L l d) - return (GHC.L l (GHC.ValD d')) -#endif - lvald x = return x - --- --------------------------------------------------------------------- - --- |A 'GHC.FunBind' wraps up one or more 'GHC.Match' items. 'hsDecls' cannot --- return anything for these as there is not meaningful 'replaceDecls' for it. --- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind' --- decls too, where they are needed for analysis only. -hsDeclsGeneric :: (SYB.Data t,Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs] -hsDeclsGeneric t = q t - where - q = return [] - `SYB.mkQ` parsedSource - `SYB.extQ` lmatch - `SYB.extQ` lexpr - `SYB.extQ` lstmt - `SYB.extQ` lhsbind - `SYB.extQ` lhsbindd - `SYB.extQ` llocalbinds - `SYB.extQ` localbinds - - parsedSource (p::GHC.ParsedSource) = hsDecls p - - lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) = hsDecls lm - - lexpr (le::GHC.LHsExpr GhcPs) = hsDecls le - - lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) = hsDecls d - - -- --------------------------------- - - lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -#if __GLASGOW_HASKELL__ >= 900 - lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _)) = do -#elif __GLASGOW_HASKELL__ > 808 - lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do -#elif __GLASGOW_HASKELL__ > 804 - lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do -#elif __GLASGOW_HASKELL__ > 710 - lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do -#else - lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do -#endif - dss <- mapM hsDecls matches - return (concat dss) - lhsbind p@(GHC.L _ (GHC.PatBind{})) = do - hsDeclsPatBind p - lhsbind _ = return [] - - -- --------------------------------- - -#if __GLASGOW_HASKELL__ > 804 - lhsbindd (GHC.L l (GHC.ValD _ d)) = lhsbind (GHC.L l d) -#else - lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d) -#endif - lhsbindd _ = return [] - - -- --------------------------------- - - llocalbinds :: (Monad m) => GHC.Located (GHC.HsLocalBinds GhcPs) -> TransformT m [GHC.LHsDecl GhcPs] - llocalbinds (GHC.L _ ds) = localbinds ds - - -- --------------------------------- - - localbinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs] - localbinds d = hsDeclsValBinds d - --- --------------------------------------------------------------------- - --- |Look up the annotated order and sort the decls accordingly -orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GhcPs] -> TransformT m [GHC.LHsDecl GhcPs] -orderedDecls parent decls = do - ans <- getAnnsT - case getAnnotationEP parent ans of - Nothing -> error $ "orderedDecls:no annotation for:" ++ showAnnData emptyAnns 0 parent - Just ann -> case annSortKey ann of - Nothing -> do - return decls - Just keys -> do - let ds = map (\s -> (rs $ GHC.getLoc s,s)) decls - ordered = map snd $ orderByKey ds keys - return ordered - --- --------------------------------------------------------------------- - --- | Utility function for extracting decls from 'GHC.HsLocalBinds'. Use with --- care, as this does not necessarily return the declarations in order, the --- ordering should be done by the calling function from the 'GHC.HsLocalBinds' --- context in the AST. -hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -hsDeclsValBinds lb = case lb of -#if __GLASGOW_HASKELL__ > 804 - GHC.HsValBinds _ (GHC.ValBinds _ bs sigs) -> do - let - bds = map wrapDecl (GHC.bagToList bs) - sds = map wrapSig sigs - return (bds ++ sds) - GHC.HsValBinds _ (GHC.XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" - GHC.HsIPBinds {} -> return [] - GHC.EmptyLocalBinds {} -> return [] - GHC.XHsLocalBindsLR {} -> return [] -#else - GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do - let - bds = map wrapDecl (GHC.bagToList bs) - sds = map wrapSig sigs - return (bds ++ sds) - GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid" - GHC.HsIPBinds _ -> return [] - GHC.EmptyLocalBinds -> return [] -#endif - --- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with --- care, as this does not manage the declaration order, the --- ordering should be done by the calling function from the 'GHC.HsLocalBinds' --- context in the AST. -replaceDeclsValbinds :: (Monad m) - => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs] - -> TransformT m (GHC.HsLocalBinds GhcPs) -replaceDeclsValbinds _ [] = do -#if __GLASGOW_HASKELL__ > 808 - return (GHC.EmptyLocalBinds GHC.NoExtField) -#elif __GLASGOW_HASKELL__ > 804 - return (GHC.EmptyLocalBinds GHC.noExt) -#else - return (GHC.EmptyLocalBinds) -#endif -#if __GLASGOW_HASKELL__ > 804 -replaceDeclsValbinds (GHC.HsValBinds _ _b) new -#else -replaceDeclsValbinds (GHC.HsValBinds _b) new -#endif - = do - logTr "replaceDecls HsLocalBinds" - let decs = GHC.listToBag $ concatMap decl2Bind new - let sigs = concatMap decl2Sig new -#if __GLASGOW_HASKELL__ > 808 - return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs)) -#elif __GLASGOW_HASKELL__ > 804 - return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) -#else - return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) -#endif -replaceDeclsValbinds (GHC.HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" -#if __GLASGOW_HASKELL__ > 804 -replaceDeclsValbinds (GHC.EmptyLocalBinds _) new -#else -replaceDeclsValbinds (GHC.EmptyLocalBinds) new -#endif - = do - logTr "replaceDecls HsLocalBinds" - let newBinds = map decl2Bind new - newSigs = map decl2Sig new - let decs = GHC.listToBag $ concat newBinds - let sigs = concat newSigs -#if __GLASGOW_HASKELL__ > 808 - return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs)) -#elif __GLASGOW_HASKELL__ > 804 - return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) -#else - return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) -#endif -#if __GLASGOW_HASKELL__ > 804 -replaceDeclsValbinds (GHC.XHsLocalBindsLR _) _ = error "replaceDeclsValbinds. XHsLocalBindsLR" -#endif - --- --------------------------------------------------------------------- - -type Decl = GHC.LHsDecl GhcPs -type Match = GHC.LMatch GhcPs (GHC.LHsExpr GhcPs) - --- |Modify a 'GHC.LHsBind' wrapped in a 'GHC.ValD'. For a 'GHC.PatBind' the --- declarations are extracted and returned after modification. For a --- 'GHC.FunBind' the supplied 'GHC.SrcSpan' is used to identify the specific --- 'GHC.Match' to be transformed, for when there are multiple of them. -modifyValD :: forall m t. (HasTransform m) - => GHC.SrcSpan - -> Decl - -> (Match -> [Decl] -> m ([Decl], Maybe t)) - -> m (Decl,Maybe t) -#if __GLASGOW_HASKELL__ > 804 -modifyValD p pb@(GHC.L ss (GHC.ValD _ (GHC.PatBind {} ))) f = -#else -modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f = -#endif - if ss == p - then do - ds <- liftT $ hsDeclsPatBindD pb - (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds - pb' <- liftT $ replaceDeclsPatBindD pb ds' - return (pb',r) - else return (pb,Nothing) -modifyValD p ast f = do - (ast',r) <- runStateT (SYB.everywhereM (SYB.mkM doModLocal) ast) Nothing - return (ast',r) - where - doModLocal :: Match -> StateT (Maybe t) m Match - doModLocal (match@(GHC.L ss _) :: Match) = do - let - if ss == p - then do - ds <- lift $ liftT $ hsDecls match - (ds',r) <- lift $ f match ds - put r - match' <- lift $ liftT $ replaceDecls match ds' - return match' - else return match - --- --------------------------------------------------------------------- - --- |Used to integrate a @Transform@ into other Monad stacks -class (Monad m) => (HasTransform m) where - liftT :: Transform a -> m a - -instance Monad m => HasTransform (TransformT m) where - liftT = hoistTransform (return . runIdentity) - --- --------------------------------------------------------------------- - --- | Apply a transformation to the decls contained in @t@ -modifyDeclsT :: (HasDecls t,HasTransform m) - => ([GHC.LHsDecl GhcPs] -> m [GHC.LHsDecl GhcPs]) - -> t -> m t -modifyDeclsT action t = do - decls <- liftT $ hsDecls t - decls' <- action decls - liftT $ replaceDecls t decls' - --- --------------------------------------------------------------------- - -matchApiAnn :: GHC.AnnKeywordId -> (KeywordId,DeltaPos) -> Bool -matchApiAnn mkw (kw,_) - = case kw of - (G akw) -> mkw == akw - _ -> False - - --- We comments extracted from annPriorComments or annFollowingComments, which --- need to move to just before the item identified by the predicate, if it --- fires, else at the end of the annotations. -insertCommentBefore :: (Monad m) => AnnKey -> [(Comment, DeltaPos)] - -> ((KeywordId, DeltaPos) -> Bool) -> TransformT m () -insertCommentBefore key toMove p = do - let - doInsert ans = - case Map.lookup key ans of - Nothing -> error $ "insertCommentBefore:no AnnKey for:" ++ showGhc key - Just ann -> Map.insert key ann' ans - where - (before,after) = break p (annsDP ann) - ann' = ann { annsDP = before ++ (map comment2dp toMove) ++ after} - - modifyAnnsT doInsert +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.GHC.ExactPrint.Transform +-- +-- This module is currently under heavy development, and no promises are made +-- about API stability. Use with care. +-- +-- We welcome any feedback / contributions on this, as it is the main point of +-- the library. +-- +----------------------------------------------------------------------------- +module Language.Haskell.GHC.ExactPrint.Transform + ( + -- * The Transform Monad + Transform + , TransformT(..) + , hoistTransform + , runTransform + , runTransformT + , runTransformFrom + , runTransformFromT + + -- * Transform monad operations + , logTr + , logDataWithAnnsTr + , getAnnsT, putAnnsT, modifyAnnsT + , uniqueSrcSpanT + + , cloneT + , graftT + + , getEntryDPT + , setEntryDPT + , transferEntryDPT + , setPrecedingLinesDeclT + , setPrecedingLinesT + , addSimpleAnnT + , addTrailingCommaT + , removeTrailingCommaT + + -- ** Managing declarations, in Transform monad + , HasTransform (..) + , HasDecls (..) + , hasDeclsSybTransform + , hsDeclsGeneric + , hsDeclsPatBind, hsDeclsPatBindD + , replaceDeclsPatBind, replaceDeclsPatBindD + , modifyDeclsT + , modifyValD + -- *** Utility, does not manage layout + , hsDeclsValBinds, replaceDeclsValbinds + , WithWhere(..) + + -- ** New gen functions + , noAnnSrcSpanDP + , noAnnSrcSpanDP0 + , noAnnSrcSpanDP1 + , noAnnSrcSpanDPn + , d0, d1, dn + , m0, m1, mn + , addComma + + -- ** Managing lists, Transform monad + , insertAt + , insertAtStart + , insertAtEnd + , insertAfter + , insertBefore + + -- *** Low level operations used in 'HasDecls' + , balanceComments + , balanceCommentsList + , balanceCommentsList' + , balanceTrailingComments + , moveTrailingComments + , anchorEof + + -- ** Managing lists, pure functions + , captureOrder + , captureLineSpacing + , captureMatchLineSpacing + , captureTypeSigSpacing + + -- * Operations + , isUniqueSrcSpan + + -- * Pure functions + , mergeAnns + , mergeAnnList + , setPrecedingLinesDecl + , setPrecedingLines + , getEntryDP + , setEntryDP + , setEntryDP' + , transferEntryDP + , transferEntryDP' + , addTrailingComma + , wrapSig, wrapDecl + , decl2Sig, decl2Bind + , deltaAnchor + ) where + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import Control.Monad.RWS +import qualified Control.Monad.Fail as Fail + +import GHC hiding (parseModule, parsedSource) +import GHC.Data.Bag +import GHC.Data.FastString + +import Data.Generics +-- import Data.Data +import Data.List (sort, sortBy, find) +import Data.Maybe + +import qualified Data.Map as Map + +import Data.Functor.Identity +import Control.Monad.State +import Control.Monad.Writer + + +------------------------------------------------------------------------------ +-- Transformation of source elements + +-- | Monad type for updating the AST and managing the annotations at the same +-- time. The W state is used to generate logging information if required. +type Transform = TransformT Identity + +-- |Monad transformer version of 'Transform' monad +newtype TransformT m a = TransformT { unTransformT :: RWST () [String] (Anns,Int) m a } + deriving (Monad,Applicative,Functor + ,MonadReader () + ,MonadWriter [String] + ,MonadState (Anns,Int) + ,MonadTrans + ) + +instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where + fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg + +-- | Run a transformation in the 'Transform' monad, returning the updated +-- annotations and any logging generated via 'logTr' +runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String]) +runTransform ans f = runTransformFrom 0 ans f + +runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String]) +runTransformT ans f = runTransformFromT 0 ans f + +-- | Run a transformation in the 'Transform' monad, returning the updated +-- annotations and any logging generated via 'logTr', allocating any new +-- SrcSpans from the provided initial value. +runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String]) +runTransformFrom seed ans f = runRWS (unTransformT f) () (ans,seed) + +-- |Run a monad transformer stack for the 'TransformT' monad transformer +runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String]) +runTransformFromT seed ans f = runRWST (unTransformT f) () (ans,seed) + +-- | Change inner monad of 'TransformT'. +hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a +hoistTransform nt (TransformT m) = TransformT (mapRWST nt m) + +-- |Log a string to the output of the Monad +logTr :: (Monad m) => String -> TransformT m () +logTr str = tell [str] + +-- |Log a representation of the given AST with annotations to the output of the +-- Monad +logDataWithAnnsTr :: (Monad m) => (Data a) => String -> a -> TransformT m () +logDataWithAnnsTr str ast = do + logTr $ str ++ showAst ast + +-- |Access the 'Anns' being modified in this transformation +getAnnsT :: (Monad m) => TransformT m Anns +getAnnsT = gets fst + +-- |Replace the 'Anns' after any changes +putAnnsT :: (Monad m) => Anns -> TransformT m () +putAnnsT ans = do + (_,col) <- get + put (ans,col) + +-- |Change the stored 'Anns' +modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m () +modifyAnnsT f = do + ans <- getAnnsT + putAnnsT (f ans) + +-- --------------------------------------------------------------------- + +-- |Once we have 'Anns', a 'SrcSpan' is used purely as part of an 'AnnKey' +-- to index into the 'Anns'. If we need to add new elements to the AST, they +-- need their own 'SrcSpan' for this. +uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan +uniqueSrcSpanT = do + (an,col) <- get + put (an,col + 1 ) + let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col + return $ mkSrcSpan pos pos + +-- |Test whether a given 'SrcSpan' was generated by 'uniqueSrcSpanT' +isUniqueSrcSpan :: SrcSpan -> Bool +isUniqueSrcSpan ss = srcSpanStartLine' ss == -1 + +srcSpanStartLine' :: SrcSpan -> Int +srcSpanStartLine' (RealSrcSpan s _) = srcSpanStartLine s +srcSpanStartLine' _ = 0 + +-- --------------------------------------------------------------------- +-- |Make a copy of an AST element, replacing the existing SrcSpans with new +-- ones, and duplicating the matching annotations. +cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(SrcSpan, SrcSpan)]) +cloneT ast = do + runWriterT $ everywhereM (return `ext2M` replaceLocated) ast + where + replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m) + => (GenLocated loc a) -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a) + replaceLocated (L l t) = do + case cast l :: Maybe SrcSpan of + Just ss -> do + newSpan <- lift uniqueSrcSpanT + lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) anns of + Nothing -> anns + Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns) + tell [(ss, newSpan)] + return $ fromJust . cast $ L newSpan t + Nothing -> return (L l t) + +-- --------------------------------------------------------------------- +-- |Slightly more general form of cloneT +graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a +graftT origAnns = everywhereM (return `ext2M` replaceLocated) + where + replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m) + => GenLocated loc a -> TransformT m (GenLocated loc a) + replaceLocated (L l t) = do + case cast l :: Maybe SrcSpan of + Just ss -> do + newSpan <- uniqueSrcSpanT + modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) origAnns of + Nothing -> anns + Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns) + return $ fromJust $ cast $ L newSpan t + Nothing -> return (L l t) + +-- --------------------------------------------------------------------- + +-- |If a list has been re-ordered or had items added, capture the new order in +-- the appropriate 'AnnSortKey' attached to the 'Annotation' for the list. +captureOrder :: [LocatedA b] -> AnnSortKey +captureOrder ls = AnnSortKey $ map (rs . getLocA) ls + +-- --------------------------------------------------------------------- + +captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs +captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ) e) f))) + = L l (ValD x (FunBind a b (MG c (L d ms') e) f)) + where + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = captureLineSpacing ms +captureMatchLineSpacing d = d + +captureLineSpacing :: Monoid t + => [LocatedAn t e] -> [GenLocated (SrcSpanAnn' (EpAnn t)) e] +captureLineSpacing [] = [] +captureLineSpacing [d] = [d] +captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds) + where + (l1,_) = ss2pos $ rs $ getLocA de1 + (l2,_) = ss2pos $ rs $ getLocA d2 + d2' = setEntryDP' d2 (deltaPos (l2-l1) 0) + +-- --------------------------------------------------------------------- + +captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs +captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (HsWC xw ty)))) + = (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc' rs') cs) ns (HsWC xw ty')))) + where + -- we want DPs for the distance from the end of the ns to the + -- AnnDColon, and to the start of the ty + AddEpAnn kw dca = dc + rd = case last ns of + L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll + L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? + -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r + dc' = case dca of + EpaSpan r -> AddEpAnn kw (EpaDelta $ ss2delta (ss2posEnd rd) r) + EpaDelta _ -> AddEpAnn kw dca + + -- --------------------------------- + + ty' :: LHsSigType GhcPs + ty' = case ty of + (L (SrcSpanAnn EpAnnNotUsed ll) b) + -> let + op = case dca of + EpaSpan r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) + EpaDelta _ -> MovedAnchor (SameLine 1) + in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b) + (L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b) + -> let + op' = case op of + MovedAnchor _ -> op + _ -> case dca of + EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r) + EpaDelta _ -> MovedAnchor (SameLine 1) + in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b) + +captureTypeSigSpacing s = s + +-- --------------------------------------------------------------------- + +-- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does +-- nothing to any annotations that may be attached to either of the elements. +-- It is used as a utility function in 'replaceDecls' +decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs] +decl2Bind (L l (ValD _ s)) = [L l s] +decl2Bind _ = [] + +-- |Pure function to convert a 'LSig' to a 'LHsBind'. This does +-- nothing to any annotations that may be attached to either of the elements. +-- It is used as a utility function in 'replaceDecls' +decl2Sig :: LHsDecl GhcPs -> [LSig GhcPs] +decl2Sig (L l (SigD _ s)) = [L l s] +decl2Sig _ = [] + +-- --------------------------------------------------------------------- + +-- |Convert a 'LSig' into a 'LHsDecl' +wrapSig :: LSig GhcPs -> LHsDecl GhcPs +wrapSig (L l s) = L l (SigD NoExtField s) + +-- --------------------------------------------------------------------- + +-- |Convert a 'LHsBind' into a 'LHsDecl' +wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs +wrapDecl (L l s) = L l (ValD NoExtField s) + +-- --------------------------------------------------------------------- + +-- |Create a simple 'Annotation' without comments, and attach it to the first +-- parameter. +addSimpleAnnT :: (Data a,Monad m) + => Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () +addSimpleAnnT ast dp kds = do + let ann = annNone { annEntryDelta = dp + , annsDP = kds + } + modifyAnnsT (Map.insert (mkAnnKey ast) ann) + +-- --------------------------------------------------------------------- + +-- |Add a trailing comma annotation, unless there is already one +addTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m () +addTrailingCommaT ast = do + modifyAnnsT (addTrailingComma ast (SameLine 0)) + +-- --------------------------------------------------------------------- + +-- |Remove a trailing comma annotation, if there is one one +removeTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m () +removeTrailingCommaT ast = do + modifyAnnsT (removeTrailingComma ast) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'getEntryDP' +getEntryDPT :: (Data a,Monad m) => Located a -> TransformT m DeltaPos +getEntryDPT ast = do + anns <- getAnnsT + return (getEntryDP anns ast) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'getEntryDP' +setEntryDPT :: (Monad m) => LocatedA a -> DeltaPos -> TransformT m () +setEntryDPT ast dp = do + modifyAnnsT (setEntryDP ast dp) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'transferEntryDP' +transferEntryDPT :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA b) +transferEntryDPT _a b = do + return b + -- modifyAnnsT (transferEntryDP a b) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'setPrecedingLinesDecl' +setPrecedingLinesDeclT :: (Monad m) => LHsDecl GhcPs -> Int -> Int -> TransformT m () +setPrecedingLinesDeclT ld n c = + modifyAnnsT (setPrecedingLinesDecl ld n c) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'setPrecedingLines' +setPrecedingLinesT :: (Monad m) => LocatedA a -> Int -> Int -> TransformT m () +setPrecedingLinesT ld n c = + modifyAnnsT (setPrecedingLines ld n c) + +-- --------------------------------------------------------------------- + +-- | Left bias pair union +mergeAnns :: Anns -> Anns -> Anns +mergeAnns + = Map.union + +-- |Combine a list of annotations +mergeAnnList :: [Anns] -> Anns +mergeAnnList [] = error "mergeAnnList must have at lease one entry" +mergeAnnList (x:xs) = foldr mergeAnns x xs + +-- --------------------------------------------------------------------- + +-- |Unwrap a HsDecl and call setPrecedingLines on it +-- ++AZ++ TODO: get rid of this, it is a synonym only +setPrecedingLinesDecl :: LHsDecl GhcPs -> Int -> Int -> Anns -> Anns +setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans + +-- --------------------------------------------------------------------- + +-- | Adjust the entry annotations to provide an `n` line preceding gap +setPrecedingLines :: LocatedA a -> Int -> Int -> Anns -> Anns +setPrecedingLines ast n c anne = setEntryDP ast (deltaPos n c) anne + +-- --------------------------------------------------------------------- + +-- |Return the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +getEntryDP :: (Data a) => Anns -> Located a -> DeltaPos +getEntryDP anns ast = + case Map.lookup (mkAnnKey ast) anns of + Nothing -> SameLine 0 + Just ann -> annTrueEntryDelta ann + +-- --------------------------------------------------------------------- + +setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs +setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ) e) f))) dp + = L l' (ValD x (FunBind a b (MG c (L d ms') e) f)) + where + L l' _ = setEntryDP' decl dp + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = case ms of + [] -> [] + (m0':ms0) -> setEntryDP' m0' dp : ms0 +setEntryDPDecl d dp = setEntryDP' d dp + +-- --------------------------------------------------------------------- + +-- |Set the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +-- setEntryDP' :: (Data a) => LocatedA a -> DeltaPos -> LocatedA a +setEntryDP' :: (Monoid t) => LocatedAn t a -> DeltaPos -> LocatedAn t a +setEntryDP' (L (SrcSpanAnn EpAnnNotUsed l) a) dp + = L (SrcSpanAnn + (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments) + l) a +setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp + = L (SrcSpanAnn + (EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments [])) + l) a +setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp + = case sort (priorComments cs) of + [] -> + L (SrcSpanAnn + (EpAnn (Anchor r (MovedAnchor dp)) an cs) + l) a + (L ca c:cs') -> + L (SrcSpanAnn + (EpAnn (Anchor r (MovedAnchor edp)) an cs'') + l) a + where + cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs') + lc = head $ reverse $ (L ca c:cs') + delta = ss2delta (ss2pos $ anchor $ getLoc lc) r + line = getDeltaLine delta + col = deltaColumn delta + -- TODO: this adjustment by 1 happens all over the place. Generalise it + edp' = if line == 0 then SameLine col + else DifferentLine line col + edp = edp' `debug` ("setEntryDP' :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r)) + +-- |Set the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +setEntryDP :: LocatedA a -> DeltaPos -> Anns -> Anns +setEntryDP _ast _dp anns = anns + +-- --------------------------------------------------------------------- + +addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation +addEpaLocationDelta _off _anc (EpaDelta d) = EpaDelta d +addEpaLocationDelta off anc (EpaSpan r) + = EpaDelta (adjustDeltaForOffset 0 off (ss2deltaEnd anc r)) + +-- Set the entry DP for an element coming after an existing keyword annotation +setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t +setEntryDPFromAnchor _off (EpaDelta _) (L la a) = L la a +setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP' ll dp' + where + r = case la of + (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l + (SrcSpanAnn (EpAnn (Anchor r' _) _ _) _) -> r' + dp' = adjustDeltaForOffset 0 off (ss2deltaEnd anc r) + +-- --------------------------------------------------------------------- + +-- |Take the annEntryDelta associated with the first item and associate it with the second. +-- Also transfer any comments occuring before it. +transferEntryDP :: (Monad m, Monoid t) => LocatedAn t a -> LocatedAn t b -> TransformT m (LocatedAn t b) +transferEntryDP (L (SrcSpanAnn EpAnnNotUsed l1) _) (L (SrcSpanAnn EpAnnNotUsed _) b) = do + logTr $ "transferEntryDP': EpAnnNotUsed,EpAnnNotUsed" + return (L (SrcSpanAnn EpAnnNotUsed l1) b) +transferEntryDP (L (SrcSpanAnn (EpAnn anc _an cs) _l1) _) (L (SrcSpanAnn EpAnnNotUsed l2) b) = do + logTr $ "transferEntryDP': EpAnn,EpAnnNotUsed" + return (L (SrcSpanAnn (EpAnn anc mempty cs) l2) b) +transferEntryDP (L (SrcSpanAnn (EpAnn anc1 _an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do + logTr $ "transferEntryDP': EpAnn,EpAnn" + -- Problem: if the original had preceding comments, blindly + -- transferring the location is not correct + case priorComments cs1 of + [] -> return (L (SrcSpanAnn (EpAnn anc1 an2 cs2) l2) b) + -- TODO: what happens if the receiving side already has comments? + (L anc _:_) -> do + logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc + return (L (SrcSpanAnn (EpAnn anc an2 cs2) l2) b) +transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do + logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn" + return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b) + where + anc2' = case anc2 of + Anchor _a op -> Anchor (realSrcSpan l2) op + +-- |Take the annEntryDelta associated with the first item and associate it with the second. +-- Also transfer any comments occuring before it. +-- TODO: call transferEntryDP, and use pushDeclDP +transferEntryDP' :: (Monad m) => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs) +transferEntryDP' la lb = do + (L l2 b) <- transferEntryDP la lb + return (L l2 (pushDeclDP b (SameLine 0))) + + +pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs +pushDeclDP (ValD x (FunBind a b (MG c (L d ms ) e) f)) dp + = ValD x (FunBind a b (MG c (L d' ms') e) f) + where + L d' _ = setEntryDP' (L d ms) dp + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = case ms of + [] -> [] + (m0':ms0) -> setEntryDP' m0' dp : ms0 +pushDeclDP d _dp = d + +-- --------------------------------------------------------------------- + +addTrailingComma :: (Data a) => Located a -> DeltaPos -> Anns -> Anns +addTrailingComma a dp anns = + case Map.lookup (mkAnnKey a) anns of + Nothing -> anns + Just an -> + case find isAnnComma (annsDP an) of + Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G AnnComma,dp)]}) anns + Just _ -> anns + where + isAnnComma (G AnnComma,_) = True + isAnnComma _ = False + +-- --------------------------------------------------------------------- + +removeTrailingComma :: (Data a) => Located a -> Anns -> Anns +removeTrailingComma a anns = + case Map.lookup (mkAnnKey a) anns of + Nothing -> anns + Just an -> + case find isAnnComma (annsDP an) of + Nothing -> anns + Just _ -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns + where + isAnnComma (G AnnComma,_) = True + isAnnComma _ = False + +-- --------------------------------------------------------------------- + +balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] +balanceCommentsList [] = return [] +balanceCommentsList [x] = return [x] +balanceCommentsList (a:b:ls) = do + (a',b') <- balanceComments a b + r <- balanceCommentsList (b':ls) + return (a':r) + +-- |The relatavise phase puts all comments appearing between the end of one AST +-- item and the beginning of the next as 'annPriorComments' for the second one. +-- This function takes two adjacent AST items and moves any 'annPriorComments' +-- from the second one to the 'annFollowingComments' of the first if they belong +-- to it instead. This is typically required before deleting or duplicating +-- either of the AST elements. +balanceComments :: (Monad m) + => LHsDecl GhcPs -> LHsDecl GhcPs + -> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs) +balanceComments first second = do + -- ++AZ++ : replace the nested casts with appropriate gmapM + -- logTr $ "balanceComments entered" + -- logDataWithAnnsTr "first" first + case first of + (L l (ValD x fb@(FunBind{}))) -> do + (L l' fb',second') <- balanceCommentsFB (L l fb) second + return (L l' (ValD x fb'), second') + _ -> balanceComments' first second + +-- |Once 'balanceComments' has been called to move trailing comments to a +-- 'FunBind', these need to be pushed down from the top level to the last +-- 'Match' if that 'Match' needs to be manipulated. +balanceCommentsFB :: (Monad m) + => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) +balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do + logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) + matches' <- balanceCommentsList' matches + let (m,ms) = case reverse matches' of + (m':ms') -> (m',ms') + _ -> error "balanceCommentsFB" + (m',second') <- balanceComments' m second + m'' <- balanceCommentsMatch m' + logTr $ "balanceCommentsMatch done" + return (L lf (FunBind x n (MG mx (L lm (reverse (m'':ms))) o) t), second') +balanceCommentsFB f s = balanceComments' f s + +-- | Move comments on the same line as the end of the match into the +-- GRHS, prior to the binds +balanceCommentsMatch :: (Monad m) + => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) +balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do + logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l)) + logTr $ "balanceCommentsMatch: (move',stay')=" ++ showAst (move',stay') + logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo) + logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l)) + logTr $ "balanceCommentsMatch: (anc1,cs1f)=" ++ showAst (anc1,cs1f) + logTr $ "balanceCommentsMatch: (l'', grhss')=" ++ showAst (l'', grhss') + return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) + where + simpleBreak (r,_) = r /= 0 + (SrcSpanAnn an1 _loc1) = l + anc1 = addCommentOrigDeltas $ epAnnComments an1 + cs1f = getFollowingComments anc1 + (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f) + move = map snd move' + stay = map snd stay' + (l'', grhss', binds', logInfo) + = case reverse grhss of + [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) + (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs) -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) + (L lg (GRHS ag grs rhs):gs) -> + let + anc1' = setFollowingComments anc1 stay + an1' = setCommentsSrcAnn l anc1' + + -- --------------------------------- + (moved,bindsm) = pushTrailingComments WithWhere (EpaCommentsBalanced [] move) binds + -- --------------------------------- + + (EpAnn anc an lgc) = ag + lgc' = splitComments (realSrcSpan lg) $ addCommentOrigDeltas lgc + ag' = if moved + then EpAnn anc an lgc' + else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) + -- ag' = EpAnn anc an lgc' + + in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1')) + +pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs) +pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b) +pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:HsIPBinds" +pushTrailingComments w cs lb@(HsValBinds an _) + = (True, HsValBinds an' vb) + where + (decls, _, _ws1) = runTransform mempty (hsDeclsValBinds lb) + (an', decls') = case reverse decls of + [] -> (addCommentsToEpAnn (spanHsLocaLBinds lb) an cs, decls) + (L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds) + (vb,_ws2) = case runTransform mempty (replaceDeclsValbinds w lb decls') of + ((HsValBinds _ vb'), _, ws2') -> (vb', ws2') + _ -> (ValBinds NoAnnSortKey emptyBag [], []) + + +balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a] +balanceCommentsList' [] = return [] +balanceCommentsList' [x] = return [x] +balanceCommentsList' (a:b:ls) = do + logTr $ "balanceCommentsList' entered" + (a',b') <- balanceComments' a b + r <- balanceCommentsList' (b':ls) + return (a':r) + +-- |Prior to moving an AST element, make sure any trailing comments belonging to +-- it are attached to it, and not the following element. Of necessity this is a +-- heuristic process, to be tuned later. Possibly a variant should be provided +-- with a passed-in decision function. +-- The initial situation is that all comments for a given anchor appear as prior comments +-- Many of these should in fact be following comments for the previous anchor +balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) +balanceComments' la1 la2 = do + logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) + logTr $ "balanceComments': (anchorFromLocatedA la1)=" ++ showGhc (anchorFromLocatedA la1) + logTr $ "balanceComments': (sort cs2b)=" ++ showAst (sort cs2b) + logTr $ "balanceComments': (move',stay')=" ++ showAst (move',stay') + logTr $ "balanceComments': (move'',stay'')=" ++ showAst (move'',stay'') + logTr $ "balanceComments': (move,stay)=" ++ showAst (move,stay) + return (la1', la2') + where + simpleBreak n (r,_) = r > n + L (SrcSpanAnn an1 loc1) f = la1 + L (SrcSpanAnn an2 loc2) s = la2 + anc1 = addCommentOrigDeltas $ epAnnComments an1 + anc2 = addCommentOrigDeltas $ epAnnComments an2 + cs1f = getFollowingComments anc1 + cs2b = priorComments anc2 + (stay'',move') = break (simpleBreak 1) (priorCommentsDeltas (anchorFromLocatedA la2) cs2b) + -- Need to also check for comments more closely attached to la1, + -- ie trailing on the same line + (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay'')) + move = map snd (move'' ++ move') + stay = map snd stay' + cs1 = setFollowingComments anc1 (sort $ cs1f ++ move) + cs2 = setPriorComments anc2 stay + + an1' = setCommentsSrcAnn (getLoc la1) cs1 + an2' = setCommentsSrcAnn (getLoc la2) cs2 + la1' = L an1' f + la2' = L an2' s + +-- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start +trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment] + -> [(Int, LEpaComment)] +trailingCommentsDeltas _ [] = [] +trailingCommentsDeltas anc (la@(L l _):las) + = deltaComment anc la : trailingCommentsDeltas (anchor l) las + where + deltaComment anc' (L loc c) = (abs(ll - al), L loc c) + where + (al,_) = ss2posEnd anc' + (ll,_) = ss2pos (anchor loc) + +-- AZ:TODO: this is identical to commentsDeltas +priorCommentsDeltas :: RealSrcSpan -> [LEpaComment] + -> [(Int, LEpaComment)] +priorCommentsDeltas anc cs = go anc (reverse $ sort cs) + where + go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] + go _ [] = [] + go anc' (la@(L l _):las) = deltaComment anc' la : go (anchor l) las + + deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment) + deltaComment anc' (L loc c) = (abs(ll - al), L loc c) + where + (al,_) = ss2pos anc' + (ll,_) = ss2pos (anchor loc) + + +-- | Split comments into ones occuring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitComments p (EpaComments cs) = cs' + where + cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> EpaCommentsBalanced before after +splitComments p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' + where + cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | A GHC comment includes the span of the preceding (non-comment) +-- token. Takes an original list of comments, and converts the +-- 'Anchor's to have a have a `MovedAnchor` operation based on the +-- original locations. +commentOrigDeltas :: [LEpaComment] -> [LEpaComment] +commentOrigDeltas [] = [] +commentOrigDeltas lcs = map commentOrigDelta lcs + +addCommentOrigDeltas :: EpAnnComments -> EpAnnComments +addCommentOrigDeltas (EpaComments cs) = EpaComments (commentOrigDeltas cs) +addCommentOrigDeltas (EpaCommentsBalanced pcs fcs) + = EpaCommentsBalanced (commentOrigDeltas pcs) (commentOrigDeltas fcs) + +addCommentOrigDeltasAnn :: (EpAnn a) -> (EpAnn a) +addCommentOrigDeltasAnn EpAnnNotUsed = EpAnnNotUsed +addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) + +-- TODO: this is replicating functionality in ExactPrint. Sort out the +-- import loop` +anchorFromLocatedA :: LocatedA a -> RealSrcSpan +anchorFromLocatedA (L (SrcSpanAnn an loc) _) + = case an of + EpAnnNotUsed -> realSrcSpan loc + (EpAnn anc _ _) -> anchor anc + +-- | A GHC comment includes the span of the preceding token. Take an +-- original comment, and convert the 'Anchor to have a have a +-- `MovedAnchor` operation based on the original location, only if it +-- does not already have one. +commentOrigDelta :: LEpaComment -> LEpaComment +-- commentOrigDelta c@(L (GHC.Anchor _ (GHC.MovedAnchor _)) _) = c +commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp)) + = (L (GHC.Anchor la op) (GHC.EpaComment t pp)) + where + (r,c) = ss2posEnd pp + op' = if r == 0 + then MovedAnchor (ss2delta (r,c+1) la) + else MovedAnchor (ss2delta (r,c) la) + op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0) + then MovedAnchor (DifferentLine 1 0) + else op' + +-- --------------------------------------------------------------------- + +balanceSameLineComments :: (Monad m) + => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) +balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do + logTr $ "balanceSameLineComments: (la)=" ++ showGhc (ss2range $ locA la) + logTr $ "balanceSameLineComments: [logInfo]=" ++ showAst logInfo + return (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) + where + simpleBreak n (r,_) = r > n + (la',grhss', logInfo) = case reverse grhss of + [] -> (la,grhss,[]) + (L lg g@(GRHS EpAnnNotUsed _gs _rhs):grs) -> (la,reverse $ (L lg g):grs,[]) + (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))]) + where + (SrcSpanAnn an1 _loc1) = la + anc1 = addCommentOrigDeltas $ epAnnComments an1 + (EpAnn anc an _) = ga :: EpAnn GrhsAnn + (csp,csf) = case anc1 of + EpaComments cs -> ([],cs) + EpaCommentsBalanced p f -> (p,f) + (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchor anc) csf) + move = map snd move' + stay = map snd stay' + cs1 = EpaCommentsBalanced csp stay + + gac = addCommentOrigDeltas $ epAnnComments ga + gfc = getFollowingComments gac + gac' = setFollowingComments gac (sort $ gfc ++ move) + ga' = (EpAnn anc an gac') + + an1' = setCommentsSrcAnn la cs1 + la'' = an1' + +-- --------------------------------------------------------------------- + + +-- |After moving an AST element, make sure any comments that may belong +-- with the following element in fact do. Of necessity this is a heuristic +-- process, to be tuned later. Possibly a variant should be provided with a +-- passed-in decision function. +balanceTrailingComments :: (Monad m) => (Data a,Data b) => Located a -> Located b + -> TransformT m [(Comment, DeltaPos)] +balanceTrailingComments first second = do + let + k1 = mkAnnKey first + k2 = mkAnnKey second + moveComments p ans = (ans',move) + where + an1 = gfromJust "balanceTrailingComments k1" $ Map.lookup k1 ans + an2 = gfromJust "balanceTrailingComments k2" $ Map.lookup k2 ans + cs1f = annFollowingComments an1 + (move,stay) = break p cs1f + an1' = an1 { annFollowingComments = stay } + ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans + + simpleBreak (_,SameLine _) = False + simpleBreak (_,DifferentLine _ _) = True + + ans <- getAnnsT + let (ans',mov) = moveComments simpleBreak ans + putAnnsT ans' + return mov + +-- --------------------------------------------------------------------- + +-- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for +-- |Move any 'annFollowingComments' values from the 'Annotation' associated to +-- the first parameter to that of the second. +moveTrailingComments :: (Data a,Data b) + => Located a -> Located b -> Transform () +moveTrailingComments first second = do + let + k1 = mkAnnKey first + k2 = mkAnnKey second + moveComments ans = ans' + where + an1 = gfromJust "moveTrailingComments k1" $ Map.lookup k1 ans + an2 = gfromJust "moveTrailingComments k2" $ Map.lookup k2 ans + cs1f = annFollowingComments an1 + cs2f = annFollowingComments an2 + an1' = an1 { annFollowingComments = [] } + an2' = an2 { annFollowingComments = cs1f ++ cs2f } + ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans + + modifyAnnsT moveComments + +-- --------------------------------------------------------------------- + +anchorEof :: ParsedSource -> ParsedSource +anchorEof (L l m@(HsModule an _lo _mn _exps _imps _decls _ _)) = L l (m { hsmodAnn = an' }) + where + an' = addCommentOrigDeltasAnn an + +-- --------------------------------------------------------------------- + +-- | Take an anchor and a preceding location, and generate an +-- equivalent one with a 'MovedAnchor' delta. +deltaAnchor :: Anchor -> RealSrcSpan -> Anchor +deltaAnchor (Anchor anc _) ss = Anchor anc (MovedAnchor dp) + where + dp = ss2delta (ss2pos anc) ss + +-- --------------------------------------------------------------------- + +-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the +-- given @DeltaPos@. +noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDP l dp + = SrcSpanAnn (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments) l + +noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (SameLine 0) + +noAnnSrcSpanDP1 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDP1 l = noAnnSrcSpanDP l (SameLine 1) + +noAnnSrcSpanDPn :: (Monoid ann) => SrcSpan -> Int -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (SameLine s) + +d0 :: EpaLocation +d0 = EpaDelta $ SameLine 0 + +d1 :: EpaLocation +d1 = EpaDelta $ SameLine 1 + +dn :: Int -> EpaLocation +dn n = EpaDelta $ SameLine n + +m0 :: AnchorOperation +m0 = MovedAnchor $ SameLine 0 + +m1 :: AnchorOperation +m1 = MovedAnchor $ SameLine 1 + +mn :: Int -> AnchorOperation +mn n = MovedAnchor $ SameLine n + +addComma :: SrcSpanAnnA -> SrcSpanAnnA +addComma (SrcSpanAnn EpAnnNotUsed l) + = (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) emptyComments) l) +addComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) + = (SrcSpanAnn (EpAnn anc (AnnListItem (AddCommaAnn d0:as)) cs) l) + +-- --------------------------------------------------------------------- + +-- | Insert a declaration into an AST element having sub-declarations +-- (@HasDecls@) according to the given location function. +insertAt :: (HasDecls ast) + => (LHsDecl GhcPs + -> [LHsDecl GhcPs] + -> [LHsDecl GhcPs]) + -> ast + -> LHsDecl GhcPs + -> Transform ast +insertAt f t decl = do + oldDecls <- hsDecls t + replaceDecls t (f decl oldDecls) + +-- |Insert a declaration at the beginning or end of the subdecls of the given +-- AST item +insertAtStart, insertAtEnd :: (HasDecls ast) + => ast + -> LHsDecl GhcPs + -> Transform ast + +insertAtStart = insertAt (:) +insertAtEnd = insertAt (\x xs -> xs ++ [x]) + +-- |Insert a declaration at a specific location in the subdecls of the given +-- AST item +insertAfter, insertBefore :: (HasDecls (LocatedA ast)) + => LocatedA old + -> LocatedA ast + -> LHsDecl GhcPs + -> Transform (LocatedA ast) +insertAfter (getLocA -> k) = insertAt findAfter + where + findAfter x xs = + case span (\(L l _) -> locA l /= k) xs of + ([],[]) -> [x] + (fs,[]) -> fs++[x] + (fs, b:bs) -> fs ++ (b : x : bs) + -- let (fs, b:bs) = span (\(L l _) -> locA l /= k) xs + -- in fs ++ (b : x : bs) +insertBefore (getLocA -> k) = insertAt findBefore + where + findBefore x xs = + let (fs, bs) = span (\(L l _) -> locA l /= k) xs + in fs ++ (x : bs) + +-- ===================================================================== +-- start of HasDecls instances +-- ===================================================================== + +-- |Provide a means to get and process the immediate child declartions of a +-- given AST element. +class (Data t) => HasDecls t where +-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent + + -- | Return the 'HsDecl's that are directly enclosed in the + -- given syntax phrase. They are always returned in the wrapped 'HsDecl' + -- form, even if orginating in local decls. This is safe, as annotations + -- never attach to the wrapper, only to the wrapped item. + hsDecls :: (Monad m) => t -> TransformT m [LHsDecl GhcPs] + + -- | Replace the directly enclosed decl list by the given + -- decl list. Runs in the 'Transform' monad to be able to update list order + -- annotations, and rebalance comments and other layout changes as needed. + -- + -- For example, a call on replaceDecls for a wrapped 'FunBind' having no + -- where clause will convert + -- + -- @ + -- -- |This is a function + -- foo = x -- comment1 + -- @ + -- in to + -- + -- @ + -- -- |This is a function + -- foo = x -- comment1 + -- where + -- nn = 2 + -- @ + replaceDecls :: (Monad m) => t -> [LHsDecl GhcPs] -> TransformT m t + +-- --------------------------------------------------------------------- + +instance HasDecls ParsedSource where + hsDecls (L _ (HsModule _ _lo _mn _exps _imps decls _ _)) = return decls + replaceDecls (L l (HsModule a lo mname exps imps _decls deps haddocks)) decls + = do + logTr "replaceDecls LHsModule" + -- modifyAnnsT (captureOrder m decls) + return (L l (HsModule a lo mname exps imps decls deps haddocks)) + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where + hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsValBinds lb + + replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) [] + = do + logTr "replaceDecls LMatch empty decls" + binds'' <- replaceDeclsValbinds WithoutWhere binds [] + return (L l (Match xm c p (GRHSs xr rhs binds''))) + + replaceDecls m@(L l (Match xm c p (GRHSs xr rhs binds))) newBinds + = do + logTr "replaceDecls LMatch nonempty decls" + -- Need to throw in a fresh where clause if the binds were empty, + -- in the annotations. + (l', rhs') <- case binds of + EmptyLocalBinds{} -> do + logTr $ "replaceDecls LMatch empty binds" + modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4) + + -- only move the comment if the original where clause was empty. + -- toMove <- balanceTrailingComments m m + -- insertCommentBefore (mkAnnKey m) toMove (matchEpAnn AnnWhere) + -- TODO: move trailing comments on the same line to before the binds + logDataWithAnnsTr "Match.replaceDecls:balancing comments:m" m + L l' m' <- balanceSameLineComments m + logDataWithAnnsTr "Match.replaceDecls:(m1')" (L l' m') + return (l', grhssGRHSs $ m_grhss m') + _ -> return (l, rhs) + binds'' <- replaceDeclsValbinds WithWhere binds newBinds + logDataWithAnnsTr "Match.replaceDecls:binds'" binds'' + return (L l' (Match xm c p (GRHSs xr rhs' binds''))) + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (HsExpr GhcPs)) where + hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsValBinds decls + hsDecls _ = return [] + + replaceDecls (L ll (HsLet x binds ex)) newDecls + = do + logTr "replaceDecls HsLet" + let lastAnc = realSrcSpan $ spanHsLocaLBinds binds + -- TODO: may be an intervening comment, take account for lastAnc + let (x', ex',newDecls') = case x of + EpAnnNotUsed -> (x, ex, newDecls) + (EpAnn a (AnnsLet l i) cs) -> + let + off = case l of + (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r + (EpaDelta (SameLine _)) -> LayoutStartCol 0 + (EpaDelta (DifferentLine _ c)) -> LayoutStartCol c + ex'' = setEntryDPFromAnchor off i ex + newDecls'' = case newDecls of + [] -> newDecls + (d:ds) -> setEntryDPDecl d (SameLine 0) : ds + in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs + , ex'' + , newDecls'') + binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' + return (L ll (HsLet x' binds' ex')) + + -- TODO: does this make sense? Especially as no hsDecls for HsPar + replaceDecls (L l (HsPar x e)) newDecls + = do + logTr "replaceDecls HsPar" + e' <- replaceDecls e newDecls + return (L l (HsPar x e')) + replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old + +-- --------------------------------------------------------------------- + +-- | Extract the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is +-- idempotent. +hsDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs] +hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d) +hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x + +-- | Extract the immediate declarations for a 'PatBind'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is +-- idempotent. +hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] +hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb) _)) = hsDeclsValBinds lb +hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x + +-- ------------------------------------- + +-- | Replace the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is +-- idempotent. +replaceDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> [LHsDecl GhcPs] + -> TransformT m (LHsDecl GhcPs) +replaceDeclsPatBindD (L l (ValD x d)) newDecls = do + (L _ d') <- replaceDeclsPatBind (L l d) newDecls + return (L l (ValD x d')) +replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x + +-- | Replace the immediate declarations for a 'PatBind'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is +-- idempotent. +replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs] + -> TransformT m (LHsBind GhcPs) +replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls + = do + logTr "replaceDecls PatBind" + -- Need to throw in a fresh where clause if the binds were empty, + -- in the annotations. + case binds of + EmptyLocalBinds{} -> do + let + addWhere _mkds = + error "TBD" + modifyAnnsT addWhere + modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4) + + _ -> return () + + -- modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls) + binds'' <- replaceDeclsValbinds WithWhere binds newDecls + -- let binds' = L (getLoc binds) binds'' + return (L l (PatBind x a (GRHSs xr rhss binds'') b)) +replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where + hsDecls (L _ (LetStmt _ lb)) = hsDeclsValBinds lb + hsDecls (L _ (LastStmt _ e _ _)) = hsDecls e + hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e + hsDecls (L _ (BodyStmt _ e _ _)) = hsDecls e + hsDecls _ = return [] + + replaceDecls (L l (LetStmt x lb)) newDecls + = do + -- modifyAnnsT (captureOrder s newDecls) + lb'' <- replaceDeclsValbinds WithWhere lb newDecls + -- let lb' = L (getLoc lb) lb'' + return (L l (LetStmt x lb'')) + replaceDecls (L l (LastStmt x e d se)) newDecls + = do + e' <- replaceDecls e newDecls + return (L l (LastStmt x e' d se)) + replaceDecls (L l (BindStmt x pat e)) newDecls + = do + e' <- replaceDecls e newDecls + return (L l (BindStmt x pat e')) + + replaceDecls (L l (BodyStmt x e a b)) newDecls + = do + e' <- replaceDecls e newDecls + return (L l (BodyStmt x e' a b)) + replaceDecls x _newDecls = return x + +-- ===================================================================== +-- end of HasDecls instances +-- ===================================================================== + +-- --------------------------------------------------------------------- + +-- |Do a transformation on an AST fragment by providing a function to process +-- the general case and one specific for a 'LHsBind'. This is required +-- because a 'FunBind' may have multiple 'Match' items, so we cannot +-- gurantee that 'replaceDecls' after 'hsDecls' is idempotent. +hasDeclsSybTransform :: (Data t2,Monad m) + => (forall t. HasDecls t => t -> m t) + -- ^Worker function for the general case + -> (LHsBind GhcPs -> m (LHsBind GhcPs)) + -- ^Worker function for FunBind/PatBind + -> t2 -- ^Item to be updated + -> m t2 +hasDeclsSybTransform workerHasDecls workerBind t = trf t + where + trf = mkM parsedSource + `extM` lmatch + `extM` lexpr + `extM` lstmt + `extM` lhsbind + `extM` lvald + + parsedSource (p::ParsedSource) = workerHasDecls p + + lmatch (lm::LMatch GhcPs (LHsExpr GhcPs)) + = workerHasDecls lm + + lexpr (le::LHsExpr GhcPs) + = workerHasDecls le + + lstmt (d::LStmt GhcPs (LHsExpr GhcPs)) + = workerHasDecls d + + lhsbind (b@(L _ FunBind{}):: LHsBind GhcPs) + = workerBind b + lhsbind b@(L _ PatBind{}) + = workerBind b + lhsbind x = return x + + lvald (L l (ValD x d)) = do + (L _ d') <- lhsbind (L l d) + return (L l (ValD x d')) + lvald x = return x + +-- --------------------------------------------------------------------- + +-- |A 'FunBind' wraps up one or more 'Match' items. 'hsDecls' cannot +-- return anything for these as there is not meaningful 'replaceDecls' for it. +-- This function provides a version of 'hsDecls' that returns the 'FunBind' +-- decls too, where they are needed for analysis only. +hsDeclsGeneric :: (Data t,Monad m) => t -> TransformT m [LHsDecl GhcPs] +hsDeclsGeneric t = q t + where + q = return [] + `mkQ` parsedSource + `extQ` lmatch + `extQ` lexpr + `extQ` lstmt + `extQ` lhsbind + `extQ` lhsbindd + `extQ` llocalbinds + `extQ` localbinds + + parsedSource (p::ParsedSource) = hsDecls p + + lmatch (lm::LMatch GhcPs (LHsExpr GhcPs)) = hsDecls lm + + lexpr (le::LHsExpr GhcPs) = hsDecls le + + lstmt (d::LStmt GhcPs (LHsExpr GhcPs)) = hsDecls d + + -- --------------------------------- + + lhsbind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] + lhsbind (L _ (FunBind _ _ (MG _ (L _ matches) _) _)) = do + dss <- mapM hsDecls matches + return (concat dss) + lhsbind p@(L _ (PatBind{})) = do + hsDeclsPatBind p + lhsbind _ = return [] + + -- --------------------------------- + + lhsbindd (L l (ValD _ d)) = lhsbind (L l d) + lhsbindd _ = return [] + + -- --------------------------------- + + llocalbinds :: (Monad m) => Located (HsLocalBinds GhcPs) -> TransformT m [LHsDecl GhcPs] + llocalbinds (L _ ds) = localbinds ds + + -- --------------------------------- + + localbinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs] + localbinds d = hsDeclsValBinds d + +-- --------------------------------------------------------------------- + +-- |Look up the annotated order and sort the decls accordingly +-- TODO:AZ: this should be pure +orderedDecls :: (Monad m) + => AnnSortKey -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] +orderedDecls sortKey decls = do + case sortKey of + NoAnnSortKey -> do + -- return decls + return $ sortBy (\a b -> compare (realSrcSpan $ getLocA a) (realSrcSpan $ getLocA b)) decls + AnnSortKey keys -> do + let ds = map (\s -> (rs $ getLocA s,s)) decls + ordered = map snd $ orderByKey ds keys + return ordered + +-- --------------------------------------------------------------------- + +hsDeclsValBinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs] +hsDeclsValBinds lb = case lb of + HsValBinds _ (ValBinds sortKey bs sigs) -> do + let + bds = map wrapDecl (bagToList bs) + sds = map wrapSig sigs + orderedDecls sortKey (bds ++ sds) + HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" + HsIPBinds {} -> return [] + EmptyLocalBinds {} -> return [] + +data WithWhere = WithWhere + | WithoutWhere + deriving (Eq,Show) + +-- | Utility function for returning decls to 'HsLocalBinds'. Use with +-- care, as this does not manage the declaration order, the +-- ordering should be done by the calling function from the 'HsLocalBinds' +-- context in the AST. +replaceDeclsValbinds :: (Monad m) + => WithWhere + -> HsLocalBinds GhcPs -> [LHsDecl GhcPs] + -> TransformT m (HsLocalBinds GhcPs) +replaceDeclsValbinds _ _ [] = do + return (EmptyLocalBinds NoExtField) +replaceDeclsValbinds w b@(HsValBinds a _) new + = do + logTr "replaceDeclsValbinds" + let oldSpan = spanHsLocaLBinds b + an <- oldWhereAnnotation a w (realSrcSpan oldSpan) + let decs = listToBag $ concatMap decl2Bind new + let sigs = concatMap decl2Sig new + let sortKey = captureOrder new + return (HsValBinds an (ValBinds sortKey decs sigs)) +replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" +replaceDeclsValbinds w (EmptyLocalBinds _) new + = do + logTr "replaceDecls HsLocalBinds" + an <- newWhereAnnotation w + let newBinds = concatMap decl2Bind new + newSigs = concatMap decl2Sig new + let decs = listToBag $ newBinds + let sigs = newSigs + let sortKey = captureOrder new + return (HsValBinds an (ValBinds sortKey decs sigs)) + +oldWhereAnnotation :: (Monad m) + => EpAnn AnnList -> WithWhere -> RealSrcSpan -> TransformT m (EpAnn AnnList) +oldWhereAnnotation EpAnnNotUsed ww _oldSpan = do + newSpan <- uniqueSrcSpanT + let w = case ww of + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] + WithoutWhere -> [] + let anc2' = Anchor (rs newSpan) (MovedAnchor (SameLine 1)) + (anc, anc2) <- do + newSpan' <- uniqueSrcSpanT + return ( Anchor (rs newSpan') (MovedAnchor (DifferentLine 1 2)) + , anc2') + let an = EpAnn anc + (AnnList (Just anc2) Nothing Nothing w []) + emptyComments + return an +oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do + -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, change the AnnList anchor to have the correct DP too + let (AnnList ancl o c _r t) = an + let w = case ww of + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] + WithoutWhere -> [] + (anc', ancl') <- do + case ww of + WithWhere -> return (anc, ancl) + WithoutWhere -> return (anc, ancl) + let an' = EpAnn anc' + (AnnList ancl' o c w t) + cs + return an' + +newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList) +newWhereAnnotation ww = do + newSpan <- uniqueSrcSpanT + let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3)) + let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5)) + let w = case ww of + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] + WithoutWhere -> [] + let an = EpAnn anc + (AnnList (Just anc2) Nothing Nothing w []) + emptyComments + return an + +-- --------------------------------------------------------------------- + +type Decl = LHsDecl GhcPs +type PMatch = LMatch GhcPs (LHsExpr GhcPs) + +-- |Modify a 'LHsBind' wrapped in a 'ValD'. For a 'PatBind' the +-- declarations are extracted and returned after modification. For a +-- 'FunBind' the supplied 'SrcSpan' is used to identify the specific +-- 'Match' to be transformed, for when there are multiple of them. +modifyValD :: forall m t. (HasTransform m) + => SrcSpan + -> Decl + -> (PMatch -> [Decl] -> m ([Decl], Maybe t)) + -> m (Decl,Maybe t) +modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f = + if (locA ss) == p + then do + ds <- liftT $ hsDeclsPatBindD pb + (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds + pb' <- liftT $ replaceDeclsPatBindD pb ds' + return (pb',r) + else return (pb,Nothing) +modifyValD p ast f = do + (ast',r) <- runStateT (everywhereM (mkM doModLocal) ast) Nothing + return (ast',r) + where + doModLocal :: PMatch -> StateT (Maybe t) m PMatch + doModLocal (match@(L ss _) :: PMatch) = do + if (locA ss) == p + then do + ds <- lift $ liftT $ hsDecls match + (ds',r) <- lift $ f match ds + put r + match' <- lift $ liftT $ replaceDecls match ds' + return match' + else return match + +-- --------------------------------------------------------------------- + +-- |Used to integrate a @Transform@ into other Monad stacks +class (Monad m) => (HasTransform m) where + liftT :: Transform a -> m a + +instance Monad m => HasTransform (TransformT m) where + liftT = hoistTransform (return . runIdentity) + +-- --------------------------------------------------------------------- + +-- | Apply a transformation to the decls contained in @t@ +modifyDeclsT :: (HasDecls t,HasTransform m) + => ([LHsDecl GhcPs] -> m [LHsDecl GhcPs]) + -> t -> m t +modifyDeclsT action t = do + decls <- liftT $ hsDecls t + decls' <- action decls + liftT $ replaceDecls t decls' + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs --- a/src/Language/Haskell/GHC/ExactPrint/Types.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs @@ -1,129 +1,70 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} -module Language.Haskell.GHC.ExactPrint.Types - ( -- * Core Types - Anns - , emptyAnns - , Annotation(..) - , annNone - - , KeywordId(..) - , Comment(..) - -- * Positions - , Pos - , DeltaPos(..) - , deltaRow, deltaColumn - -- * AnnKey - , AnnSpan - , AnnKey(..) - , mkAnnKey - , AnnConName(..) - , annGetConstr -#if __GLASGOW_HASKELL__ >= 900 - , badRealSrcSpan -#endif - - -- * Other - - , Rigidity(..) - , AstContext(..),AstContextSet,defaultACS - , ACS'(..) - , ListContexts(..) - - -- * For managing compatibility - , Constraints - - -- * GHC version compatibility - , GhcPs - , GhcRn - , GhcTc - -#if __GLASGOW_HASKELL__ > 804 - , noExt -#endif - - -- * Internal Types - , LayoutStartCol(..) - , declFun - - ) where +{-# LANGUAGE ViewPatterns #-} -import Data.Data (Data, Typeable, toConstr,cast) --- import Data.Generics +module Language.Haskell.GHC.ExactPrint.Types + where -import qualified GHC -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Data.FastString as GHC -import GHC.Driver.Session as GHC -import GHC.Types.SrcLoc as GHC -import GHC.Utils.Outputable as GHC -#else -import qualified DynFlags as GHC -import qualified Outputable as GHC -#endif +import GHC hiding (EpaComment) +import GHC.Utils.Outputable hiding ( (<>) ) +import Data.Data (Data, toConstr,cast) import qualified Data.Map as Map -import qualified Data.Set as Set -- --------------------------------------------------------------------- +-- | This structure holds a complete set of annotations for an AST +type Anns = Map.Map AnnKey Annotation -#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) -type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a) -#else -type Constraints a = (Data a) -#endif +emptyAnns :: Anns +emptyAnns = Map.empty --- --------------------------------------------------------------------- +-- | For every @Located a@, use the @SrcSpan@ and constructor name of +-- a as the key, to store the standard annotation. +-- These are used to maintain context in the AP and EP monads +data AnnKey = AnnKey RealSrcSpan AnnConName + deriving (Eq, Data, Ord) --- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted --- from an @AnnKeywordId@ because the annotation must be interleaved into the --- stream and does not have a well-defined position -data Comment = Comment - { - commentContents :: !String -- ^ The contents of the comment including separators +-- More compact Show instance +instance Show AnnKey where + show (AnnKey ss cn) = "AnnKey " ++ showPprUnsafe ss ++ " " ++ show cn - -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is - -- the thing we use to decide where in the output stream the comment should - -- go. - , commentIdentifier :: !AnnSpan -- ^ Needed to uniquely identify two comments with the same contents - , commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. - } - deriving (Eq,Typeable,Data,Ord) -instance Show Comment where - show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")" +mkAnnKeyPrim :: (Data a) => Located a -> AnnKey +mkAnnKeyPrim (L l a) = AnnKey (realSrcSpan l) (annGetConstr a) -instance GHC.Outputable Comment where - ppr x = GHC.text (show x) +mkAnnKeyPrimA :: (Data a) => LocatedA a -> AnnKey +mkAnnKeyPrimA (L l a) = AnnKey (realSrcSpan $ locA l) (annGetConstr a) -type Pos = (Int,Int) +-- Holds the name of a constructor +data AnnConName = CN { unConName :: String } + deriving (Eq, Ord, Data) --- | A relative positions, row then column -newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data) +-- More compact show instance +instance Show AnnConName where + show (CN s) = "CN " ++ show s -deltaRow, deltaColumn :: DeltaPos -> Int -deltaRow (DP (r, _)) = r -deltaColumn (DP (_, c)) = c +annGetConstr :: (Data a) => a -> AnnConName +annGetConstr a = CN (show $ toConstr a) +-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. +mkAnnKey :: (Data a) => Located a -> AnnKey +mkAnnKey ld = + case cast ld :: Maybe (LHsDecl GhcPs) of + Just d -> declFun mkAnnKeyPrimA d + Nothing -> mkAnnKeyPrim ld --- | Marks the start column of a layout block. -newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int } - deriving (Eq, Num) -instance Show LayoutStartCol where - show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")" +type Pos = (Int,Int) +-- --------------------------------------------------------------------- annNone :: Annotation -annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing +annNone = Ann (SameLine 0) [] [] [] Nothing Nothing data Annotation = Ann { @@ -144,11 +85,7 @@ -- The next three fields relate to interacing down into the AST , annsDP :: ![(KeywordId, DeltaPos)] -- ^ Annotations associated with this element. -#if __GLASGOW_HASKELL__ >= 900 - , annSortKey :: !(Maybe [GHC.RealSrcSpan]) -#else - , annSortKey :: !(Maybe [GHC.SrcSpan]) -#endif + , annSortKey :: !(Maybe [RealSrcSpan]) -- ^ Captures the sort order of sub elements. This is needed when the -- sub-elements have been split (as in a HsLocalBind which holds separate -- binds and sigs) or for infix patterns where the order has been @@ -163,327 +100,90 @@ -- need eo be vertically aligned for the Haskell layout rules, and this -- guarantees this property in the presence of AST edits. - } deriving (Typeable,Eq) + } deriving (Eq) -instance Show Annotation where - show (Ann dp comments fcomments ans sk csp) - = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " " - ++ show fcomments ++ " " - ++ show ans ++ " " ++ showGhc sk ++ " " - ++ showGhc csp ++ ")" +-- --------------------------------------------------------------------- +declFun :: (forall a . Data a => LocatedA a -> b) -> LHsDecl GhcPs -> b +declFun f (L l de) = + case de of + TyClD _ d -> f (L l d) + InstD _ d -> f (L l d) + DerivD _ d -> f (L l d) + ValD _ d -> f (L l d) + SigD _ d -> f (L l d) + KindSigD _ d -> f (L l d) + DefD _ d -> f (L l d) + ForD _ d -> f (L l d) + WarningD _ d -> f (L l d) + AnnD _ d -> f (L l d) + RuleD _ d -> f (L l d) + SpliceD _ d -> f (L l d) + DocD _ d -> f (L l d) + RoleAnnotD _ d -> f (L l d) --- | This structure holds a complete set of annotations for an AST -type Anns = Map.Map AnnKey Annotation +-- --------------------------------------------------------------------- -emptyAnns :: Anns -emptyAnns = Map.empty +data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) --- | For every @Located a@, use the @SrcSpan@ and constructor name of --- a as the key, to store the standard annotation. --- These are used to maintain context in the AP and EP monads -data AnnKey = AnnKey AnnSpan AnnConName - deriving (Eq, Ord, Data) --- | From GHC 9.0 the ParsedSource uses RealSrcSpan instead of SrcSpan. --- Compatibility type -#if __GLASGOW_HASKELL__ >= 900 -type AnnSpan = GHC.RealSrcSpan -#else -type AnnSpan = GHC.SrcSpan -#endif --- More compact Show instance -instance Show AnnKey where - show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn - - -#if __GLASGOW_HASKELL__ >= 900 -mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey -mkAnnKeyPrim (GHC.L (GHC.RealSrcSpan l _) a) = AnnKey l (annGetConstr a) -mkAnnKeyPrim (GHC.L _ a) = AnnKey badRealSrcSpan (annGetConstr a) -#elif __GLASGOW_HASKELL__ > 806 -mkAnnKeyPrim :: (Constraints a) - => a -> AnnKey -mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a) -#else -mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey -mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a) -#endif - - -#if __GLASGOW_HASKELL__ >= 900 -badRealSrcSpan :: GHC.RealSrcSpan -badRealSrcSpan = GHC.mkRealSrcSpan bad bad - where - bad = GHC.mkRealSrcLoc (GHC.fsLit "ghc-exactprint-nospan") 0 0 -#endif - -#if __GLASGOW_HASKELL__ <= 802 -type GhcPs = GHC.RdrName -type GhcRn = GHC.Name -type GhcTc = GHC.Id -#else -type GhcPs = GHC.GhcPs -type GhcRn = GHC.GhcRn -type GhcTc = GHC.GhcTc -#endif - - -#if __GLASGOW_HASKELL__ > 808 -noExt :: GHC.NoExtField -noExt = GHC.NoExtField -#elif __GLASGOW_HASKELL__ > 804 -noExt :: GHC.NoExt -noExt = GHC.noExt -#endif +-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted +-- from an @AnnKeywordId@ because the annotation must be interleaved into the +-- stream and does not have a well-defined position +data Comment = Comment + { + commentContents :: !String -- ^ The contents of the comment including separators --- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -mkAnnKey :: (Constraints a) => a -> AnnKey -#else -mkAnnKey :: (Data a) => GHC.Located a -> AnnKey -#endif -mkAnnKey ld = - case cast ld :: Maybe (GHC.LHsDecl GhcPs) of - Just d -> declFun mkAnnKeyPrim d - Nothing -> mkAnnKeyPrim ld + -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is + -- the thing we use to decide where in the output stream the comment should + -- go. + , commentAnchor :: !Anchor + , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. + } + deriving Eq --- Holds the name of a constructor -data AnnConName = CN { unConName :: String } - deriving (Eq, Ord, Data) +instance Show Comment where + show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show o ++ ")" --- More compact show instance -instance Show AnnConName where - show (CN s) = "CN " ++ show s +instance Ord Comment where + -- When we have CPP injected comments with a fake filename, or LINE + -- pragma, the file name changes, so we need to compare the + -- locations only, with out the filename. + compare (Comment _ ss1 _) (Comment _ ss2 _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2) + where + ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss) -annGetConstr :: (Data a) => a -> AnnConName -annGetConstr a = CN (show $ toConstr a) +instance Outputable Comment where + ppr x = text (show x) -- | The different syntactic elements which are not represented in the -- AST. -data KeywordId = G GHC.AnnKeywordId -- ^ A normal keyword +data KeywordId = G AnnKeywordId -- ^ A normal keyword | AnnSemiSep -- ^ A separating comma -#if __GLASGOW_HASKELL__ >= 900 - | AnnEofPos -#endif -#if __GLASGOW_HASKELL__ >= 800 | AnnTypeApp -- ^ Visible type application annotation -#endif | AnnComment Comment | AnnString String -- ^ Used to pass information from -- Delta to Print when we have to work -- out details from the original -- SrcSpan. -#if __GLASGOW_HASKELL__ <= 710 - | AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible. -#endif - deriving (Eq, Ord, Data) + deriving (Eq) instance Show KeywordId where show (G gc) = "(G " ++ show gc ++ ")" show AnnSemiSep = "AnnSemiSep" -#if __GLASGOW_HASKELL__ >= 900 - show AnnEofPos = "AnnEofPos" -#endif -#if __GLASGOW_HASKELL__ >= 800 show AnnTypeApp = "AnnTypeApp" -#endif show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")" show (AnnString s) = "(AnnString " ++ s ++ ")" -#if __GLASGOW_HASKELL__ <= 710 - show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")" -#endif --- --------------------------------------------------------------------- - -instance GHC.Outputable KeywordId where - ppr k = GHC.text (show k) - -instance GHC.Outputable AnnConName where - ppr tr = GHC.text (show tr) - -instance GHC.Outputable Annotation where - ppr a = GHC.text (show a) - -instance GHC.Outputable AnnKey where - ppr a = GHC.text (show a) - -instance GHC.Outputable DeltaPos where - ppr a = GHC.text (show a) - --- --------------------------------------------------------------------- --- --- Flag used to control whether we use rigid or normal layout rules. --- NOTE: check is done via comparison of enumeration order, be careful with any changes -data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) -{- - -Rigidity logic. The same type is used for two different things - -1. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies - NormalLayout - Layout should be captured unconditionally - - RigidLayout - Layout should be captured or not depending on a parameter kept - in the interpreter Read state - -2. As the controlling parameter for the optional (Rigid) layout - -The nett effect is the following, where flag is the hard-coded flag value in -Annotate, and param is the interpreter param set when the interpreter is run - - flag | param | result - -------------+--------------+-------------------- - NormalLayout | either | layout captured - RigidLayout | NormalLayout | layout NOT captured - RigidLayout | RigidLayout | layout captured - -The flag is only used on HsIf and HsCase - -So - - state | HsCase | HsIf - ----------------------------|-----------+------ - before rigidity flag (AZ) | no layout | layout - param NormalLayout | no layout | no layout - param RigidLayout | layout | layout - ----------------------------+-----------+------- - desired future HaRe | no layout | layout - desired future apply-refact | layout | layout --} - --- --------------------------------------------------------------------- - -data ACS' a = ACS - { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should - -- propagate down the AST. Removed when it hits zero - } deriving (Show) - -#if __GLASGOW_HASKELL__ >= 804 -instance Semigroup (ACS' AstContext) where - (<>) = mappend -#endif - -instance Monoid (ACS' AstContext) where - mempty = ACS mempty - -- ACS a `mappend` ACS b = ACS (a `mappend` b) - ACS a `mappend` ACS b = ACS (Map.unionWith max a b) - -- For Data.Map, mappend == union, which is a left-biased replace for key collisions - -type AstContextSet = ACS' AstContext --- data AstContextSet = ACS --- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should --- -- propagate down the AST. Removed when it --- -- hits zero --- } deriving (Show) - -defaultACS :: AstContextSet -defaultACS = ACS Map.empty - --- instance GHC.Outputable AstContextSet where -instance (Show a) => GHC.Outputable (ACS' a) where - ppr x = GHC.text $ show x - -data AstContext = LambdaExpr - | CaseAlt - | NoPrecedingSpace - | HasHiding - | AdvanceLine - | NoAdvanceLine - | Intercalate -- This item may have a list separator following - | InIE -- possible 'type' or 'pattern' - | PrefixOp - | PrefixOpDollar - | InfixOp -- RdrName may be used as an infix operator - | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently - | ListItem -- Identifies subsequent elements of a list in layout - | TopLevel -- top level declaration - | NoDarrow - | AddVbar - | Deriving - | Parens -- TODO: Not currently used? - | ExplicitNeverActive - | InGadt - | InRecCon - | InClassDecl - | InSpliceDecl - | LeftMost -- Is this the leftmost operator in a chain of OpApps? - | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt - -- TODO:AZ: do we actually need this? - -- TODO:AZ this is actually tight prefix - - -- Next four used to identify current list context - | CtxOnly - | CtxFirst - | CtxMiddle - | CtxLast - | CtxPos Int -- 0 for first, increasing for subsequent - - -- Next are used in tellContext to push context up the tree - | FollowingLine - deriving (Eq, Ord, Show) - - -data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) } - deriving (Eq,Show) - --- --------------------------------------------------------------------- - --- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD --- -- should not have blank lines after it --- deriving (Eq, Ord, Show) - --- --------------------------------------------------------------------- - -declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b - -#if __GLASGOW_HASKELL__ > 804 -declFun f (GHC.L l de) = - case de of - GHC.TyClD _ d -> f (GHC.L l d) - GHC.InstD _ d -> f (GHC.L l d) - GHC.DerivD _ d -> f (GHC.L l d) - GHC.ValD _ d -> f (GHC.L l d) - GHC.SigD _ d -> f (GHC.L l d) -#if __GLASGOW_HASKELL__ > 808 - GHC.KindSigD _ d -> f (GHC.L l d) -#endif - GHC.DefD _ d -> f (GHC.L l d) - GHC.ForD _ d -> f (GHC.L l d) - GHC.WarningD _ d -> f (GHC.L l d) - GHC.AnnD _ d -> f (GHC.L l d) - GHC.RuleD _ d -> f (GHC.L l d) - GHC.SpliceD _ d -> f (GHC.L l d) - GHC.DocD _ d -> f (GHC.L l d) - GHC.RoleAnnotD _ d -> f (GHC.L l d) - GHC.XHsDecl _ -> error "declFun:XHsDecl" -#else -declFun f (GHC.L l de) = - case de of - GHC.TyClD d -> f (GHC.L l d) - GHC.InstD d -> f (GHC.L l d) - GHC.DerivD d -> f (GHC.L l d) - GHC.ValD d -> f (GHC.L l d) - GHC.SigD d -> f (GHC.L l d) - GHC.DefD d -> f (GHC.L l d) - GHC.ForD d -> f (GHC.L l d) - GHC.WarningD d -> f (GHC.L l d) - GHC.AnnD d -> f (GHC.L l d) - GHC.RuleD d -> f (GHC.L l d) - GHC.VectD d -> f (GHC.L l d) - GHC.SpliceD d -> f (GHC.L l d) - GHC.DocD d -> f (GHC.L l d) - GHC.RoleAnnotD d -> f (GHC.L l d) -#if __GLASGOW_HASKELL__ < 711 - GHC.QuasiQuoteD d -> f (GHC.L l d) -#endif -#endif +-- | Marks the start column of a layout block. +newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int } + deriving (Eq, Num) +instance Show LayoutStartCol where + show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")" -- --------------------------------------------------------------------- -- Duplicated here so it can be used in show instances -showGhc :: (GHC.Outputable a) => a -> String -showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags - --- --------------------------------------------------------------------- - +showGhc :: (Outputable a) => a -> String +showGhc = showPprUnsafe diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -1,129 +1,49 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.GHC.ExactPrint.Utils - ( - -- * Manipulating Positons - ss2pos - , ss2posEnd - , ss2range - , undelta - , isPointSrcSpan - , pos2delta - , ss2delta - , addDP - , spanLength - , isGoodDelta - , rs, sr - -- * Manipulating Comments - , mkComment - , mkKWComment - , dpFromString - , comment2dp - , extractComments - - -- * GHC Functions - , srcSpanStartLine - , srcSpanEndLine - , srcSpanStartColumn - , srcSpanEndColumn - , rdrName2String - , isSymbolRdrName - , tokComment - , isListComp - , isGadt - , isExactName - - - -- * Manipulating Annotations - , getAnnotationEP - , annTrueEntryDelta - , annCommentEntryDelta - , annLeadingCommentEntryDelta - - -- * General Utility - , orderByKey - - - -- * AST Context management - , setAcs, setAcsWithLevel - , unsetAcs - , inAcs - , pushAcs - , bumpAcs - -#if __GLASGOW_HASKELL__ <= 710 - -- * for boolean formulas in GHC 7.10.3 - -- ,LBooleanFormula, BooleanFormula(..) - , makeBooleanFormulaAnns -#endif - - -- * For tests - , debug - , debugP - , debugM - , warn - , showGhc - , showAnnData - , occAttributes - - , showSDoc_, showSDocDebug_ - -- AZ's baggage - , ghead,glast,gtail,gfromJust - ) where - - +module Language.Haskell.GHC.ExactPrint.Utils + -- ( + -- -- * Manipulating Positons + -- ss2pos + -- , ss2posEnd + -- , undelta + -- , isPointSrcSpan + -- , pos2delta + -- , ss2delta + -- , addDP + -- , spanLength + -- , isGoodDelta + -- ) where + where import Control.Monad.State -import qualified Data.ByteString as B -import Data.Generics +import Data.Function import Data.Ord (comparing) -import Language.Haskell.GHC.ExactPrint.Types +import Data.Generics + +import GHC.Hs.Dump import Language.Haskell.GHC.ExactPrint.Lookup -#if __GLASGOW_HASKELL__ <= 710 -import qualified BooleanFormula as GHC -#endif +import GHC hiding (EpaComment) import qualified GHC -#if __GLASGOW_HASKELL__ >= 900 -import qualified GHC.Data.Bag as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.Data.FastString as GHC -import qualified GHC.Types.Name as GHC -import qualified GHC.Types.Name.Set as GHC -import qualified GHC.Utils.Outputable as GHC -import qualified GHC.Types.Name.Reader as GHC -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Types.Var as GHC -import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),occNameString,pprNameSpaceBrief) -#else -import qualified Bag as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified Name as GHC -import qualified NameSet as GHC -import qualified Outputable as GHC -import qualified RdrName as GHC -import qualified SrcLoc as GHC -import qualified Var as GHC -import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief) -#endif +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Data.FastString +import GHC.Utils.Outputable (showSDocUnsafe, showPprUnsafe) +import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),pprNameSpaceBrief) import Control.Arrow import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.List +import Data.List (sortBy, elemIndex) import Debug.Trace +import Language.Haskell.GHC.ExactPrint.Types -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- |Global switch to enable debug tracing in ghc-exactprint Delta / Print @@ -133,8 +53,8 @@ -- |Global switch to enable debug tracing in ghc-exactprint Pretty debugPEnabledFlag :: Bool --- debugPEnabledFlag = True -debugPEnabledFlag = False +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. @@ -153,9 +73,6 @@ debugM :: Monad m => String -> m () debugM s = when debugEnabledFlag $ traceM s --- | Show a GHC.Outputable structure -showGhc :: (GHC.Outputable a) => a -> String -showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags -- --------------------------------------------------------------------- @@ -165,18 +82,42 @@ -- | A good delta has no negative values. isGoodDelta :: DeltaPos -> Bool -isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0 +isGoodDelta (SameLine co) = co >= 0 +isGoodDelta (DifferentLine ro co) = ro > 0 && co >= 0 + -- Note: DifferentLine invariant is ro is nonzero and positive -- | Create a delta from the current position to the start of the given -- @SrcSpan@. -ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos +ss2delta :: Pos -> RealSrcSpan -> DeltaPos ss2delta ref ss = pos2delta ref (ss2pos ss) +-- | create a delta from the end of a current span. The +1 is because +-- the stored position ends up one past the span, this is prior to +-- that adjustment +ss2deltaEnd :: RealSrcSpan -> RealSrcSpan -> DeltaPos +ss2deltaEnd rrs ss = ss2delta ref ss + where + (r,c) = ss2posEnd rrs + ref = if r == 0 + then (r,c+1) + else (r,c) + +-- | create a delta from the start of a current span. The +1 is +-- because the stored position ends up one past the span, this is +-- prior to that adjustment +ss2deltaStart :: RealSrcSpan -> RealSrcSpan -> DeltaPos +ss2deltaStart rrs ss = ss2delta ref ss + where + (r,c) = ss2pos rrs + ref = if r == 0 + then (r,c) + else (r,c) + -- | Convert the start of the second @Pos@ to be an offset from the -- first. The assumption is the reference starts before the second @Pos@ pos2delta :: Pos -> Pos -> DeltaPos -pos2delta (refl,refc) (l,c) = DP (lo,co) +pos2delta (refl,refc) (l,c) = deltaPos lo co where lo = l - refl co = if lo == 0 then c - refc @@ -185,106 +126,79 @@ -- | Apply the delta to the current position, taking into account the -- current column offset if advancing to a new line undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos -undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc) +undelta (l,c) (SameLine dc) (LayoutStartCol _co) = (l, c + dc) +undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc) where + -- Note: invariant: dl > 0 fl = l + dl - fc = if dl == 0 then c + dc - else co + dc + fc = co + dc +undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn +undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp) + where + (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0) + len = length (keywordToString (G kw)) + sp = range2rs ((l,c),(l,c+len)) + -- | Add together two @DeltaPos@ taking into account newlines -- -- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 3) -- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5) -- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3) addDP :: DeltaPos -> DeltaPos -> DeltaPos -addDP (DP (a, b)) (DP (c, d)) = - if c >= 1 then DP (a+c, d) - else DP (a, b+d) +addDP dp (DifferentLine c d) = DifferentLine (getDeltaLine dp+c) d +addDP (DifferentLine a b) (SameLine d) = DifferentLine a (b+d) +addDP (SameLine b) (SameLine d) = SameLine (b+d) --- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the --- remaining delta for the second after the first has been applied. --- invariant : if c = a `addDP` b --- then a `stepDP` c == b --- --- Cases where first DP is <= than second --- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1) --- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0) --- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1) --- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4) --- --- Cases where first DP is > than second --- > DP (0, 3) `addDP` DP (0, 2) == DP (0,1) -- advance one at least --- > DP (3, 3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col --- > DP (3, 3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least --- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col -stepDP :: DeltaPos -> DeltaPos -> DeltaPos -stepDP (DP (a,b)) (DP (c,d)) - | (a,b) == (c,d) = DP (a,b) - | a == c = if b < d then DP (0,d - b) - else if d == 0 - then DP (1,0) - -- else DP (0,1) - else DP (c,d) - | a < c = DP (c - a,d) - | otherwise = DP (1,d) +-- --------------------------------------------------------------------- +adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos +adjustDeltaForOffset _ _colOffset dp@(SameLine _) = dp +adjustDeltaForOffset d (LayoutStartCol colOffset) (DifferentLine l c) + = DifferentLine l (c - colOffset - d) + -- --------------------------------------------------------------------- -ss2pos :: GHC.SrcSpan -> Pos -ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss) +ss2pos :: RealSrcSpan -> Pos +ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss) -ss2posEnd :: GHC.SrcSpan -> Pos -ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss) +ss2posEnd :: RealSrcSpan -> Pos +ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndCol ss) -ss2range :: GHC.SrcSpan -> (Pos,Pos) -ss2range ss = (ss2pos ss, ss2posEnd ss) +ss2range :: SrcSpan -> (Pos,Pos) +ss2range ss = (ss2pos $ rs ss, ss2posEnd $ rs ss) -srcSpanEndColumn :: GHC.SrcSpan -> Int -#if __GLASGOW_HASKELL__ >= 900 -srcSpanEndColumn (GHC.RealSrcSpan s _) = GHC.srcSpanEndCol s -#else -srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s -#endif -srcSpanEndColumn _ = 0 +rs2range :: RealSrcSpan -> (Pos,Pos) +rs2range ss = (ss2pos ss, ss2posEnd ss) -srcSpanStartColumn :: GHC.SrcSpan -> Int -#if __GLASGOW_HASKELL__ >= 900 -srcSpanStartColumn (GHC.RealSrcSpan s _) = GHC.srcSpanStartCol s -#else -srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s -#endif -srcSpanStartColumn _ = 0 +rs :: SrcSpan -> RealSrcSpan +rs (RealSrcSpan s _) = s +rs _ = badRealSrcSpan -srcSpanEndLine :: GHC.SrcSpan -> Int -#if __GLASGOW_HASKELL__ >= 900 -srcSpanEndLine (GHC.RealSrcSpan s _) = GHC.srcSpanEndLine s -#else -srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s -#endif -srcSpanEndLine _ = 0 +range2rs :: (Pos,Pos) -> RealSrcSpan +range2rs (s,e) = mkRealSrcSpan (mkLoc s) (mkLoc e) + where + mkLoc (l,c) = mkRealSrcLoc (fsLit "ghc-exactprint") l c -srcSpanStartLine :: GHC.SrcSpan -> Int -#if __GLASGOW_HASKELL__ >= 900 -srcSpanStartLine (GHC.RealSrcSpan s _) = GHC.srcSpanStartLine s -#else -srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s -#endif -srcSpanStartLine _ = 0 +badRealSrcSpan :: RealSrcSpan +badRealSrcSpan = mkRealSrcSpan bad bad + where + bad = mkRealSrcLoc (fsLit "ghc-exactprint-nospan") 0 0 -spanLength :: GHC.SrcSpan -> Int -spanLength = (-) <$> srcSpanEndColumn <*> srcSpanStartColumn +spanLength :: RealSrcSpan -> Int +spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol -- --------------------------------------------------------------------- -- | Checks whether a SrcSpan has zero length. -isPointSrcSpan :: AnnSpan -> Bool -isPointSrcSpan ss = spanLength (sr ss) == 0 - && srcSpanStartLine (sr ss) == srcSpanEndLine (sr ss) +isPointSrcSpan :: RealSrcSpan -> Bool +isPointSrcSpan ss = spanLength ss == 0 + && srcSpanStartLine ss == srcSpanEndLine ss -- --------------------------------------------------------------------- -- |Given a list of items and a list of keys, returns a list of items -- ordered by their position in the list of keys. -orderByKey :: (Eq o) => [(o,a)] -> [o] -> [(o,a)] +orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)] orderByKey keys order -- AZ:TODO: if performance becomes a problem, consider a Map of the order -- SrcSpan to an index, and do a lookup instead of elemIndex. @@ -294,156 +208,86 @@ -- --------------------------------------------------------------------- -isListComp :: GHC.HsStmtContext name -> Bool +isListComp :: HsStmtContext name -> Bool isListComp cts = case cts of - GHC.ListComp -> True - GHC.MonadComp -> True -#if __GLASGOW_HASKELL__ <= 804 - GHC.PArrComp -> True -#endif + ListComp -> True + MonadComp -> True -#if __GLASGOW_HASKELL__ >= 900 - GHC.DoExpr {} -> False - GHC.MDoExpr {} -> False -#else - GHC.DoExpr -> False - GHC.MDoExpr -> False -#endif - GHC.ArrowExpr -> False - GHC.GhciStmtCtxt -> False + DoExpr {} -> False + MDoExpr {} -> False + ArrowExpr -> False + GhciStmtCtxt -> False - GHC.PatGuard {} -> False - GHC.ParStmtCtxt {} -> False - GHC.TransStmtCtxt {} -> False + PatGuard {} -> False + ParStmtCtxt {} -> False + TransStmtCtxt {} -> False -- --------------------------------------------------------------------- -isGadt :: [GHC.LConDecl name] -> Bool -#if __GLASGOW_HASKELL__ >= 880 +isGadt :: [LConDecl (GhcPass p)] -> Bool isGadt [] = True -#else -isGadt [] = False -#endif -#if __GLASGOW_HASKELL__ >= 900 -isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True -isGadt ((GHC.L _ (GHC.XConDecl{})):_) = True -#elif __GLASGOW_HASKELL__ > 710 -isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True -#else -isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True -#endif +isGadt ((L _ (ConDeclGADT{})):_) = True isGadt _ = False --- isGadt :: [GHC.LConDecl name] -> Bool --- isGadt [] = False --- #if __GLASGOW_HASKELL__ <= 710 --- isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True --- #else --- isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True --- #endif --- isGadt _ = False - - -- --------------------------------------------------------------------- -- Is a RdrName of type Exact? SYB query, so can be extended to other types too isExactName :: (Data name) => name -> Bool -isExactName = False `mkQ` GHC.isExact +isExactName = False `mkQ` isExact -- --------------------------------------------------------------------- -rs :: GHC.SrcSpan -> AnnSpan -#if __GLASGOW_HASKELL__ >= 900 --- rs :: GHC.SrcSpan -> GHC.RealSrcSpan -rs (GHC.RealSrcSpan s _) = s -rs _ = badRealSrcSpan -#else --- rs :: GHC.SrcSpan -> GHC.SrcSpan -rs = id -#endif +insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource +insertCppComments (L l p) cs = L l p' + where + ncs = EpaComments cs + an' = case GHC.hsmodAnn p of + (EpAnn a an ocs) -> EpAnn a an (ocs <> ncs) + unused -> unused + p' = p { GHC.hsmodAnn = an' } -#if __GLASGOW_HASKELL__ >= 900 -sr :: GHC.RealSrcSpan -> GHC.SrcSpan -sr s = GHC.RealSrcSpan s Nothing -#else -sr :: GHC.SrcSpan -> GHC.SrcSpan -sr = id -#endif -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 900 -ghcCommentText :: GHC.RealLocated GHC.AnnotationComment -> String -#else -ghcCommentText :: GHC.Located GHC.AnnotationComment -> String -#endif -ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s)) = s -ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s)) = s -ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s -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 +ghcCommentText :: LEpaComment -> String +ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentPrev s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNamed s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaDocSection _ s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = "" -#if __GLASGOW_HASKELL__ >= 900 -tokComment :: GHC.RealLocated GHC.AnnotationComment -> Comment -tokComment t@(GHC.L lt _) = mkComment (ghcCommentText t) lt -#else -tokComment :: GHC.Located GHC.AnnotationComment -> Comment -tokComment t@(GHC.L lt _) = mkComment (ghcCommentText t) lt -#endif +tokComment :: LEpaComment -> Comment +tokComment t@(L lt _) = mkComment (normaliseCommentText $ ghcCommentText t) lt -#if __GLASGOW_HASKELL__ >= 900 -mkComment :: String -> GHC.RealSrcSpan -> Comment -mkComment c ss = Comment c ss Nothing -#else -mkComment :: String -> GHC.SrcSpan -> Comment -mkComment c ss = Comment c (rs ss) Nothing -#endif +mkLEpaComment :: String -> Anchor -> LEpaComment +-- Note: fudging the ac_prior_tok value, hope it does not cause a problem +mkLEpaComment s anc = (L anc (GHC.EpaComment (EpaLineComment s) (anchor anc))) +mkComment :: String -> Anchor -> Comment +mkComment c anc = Comment c anc Nothing + +-- Windows comments include \r in them from the lexer. +normaliseCommentText :: String -> String +normaliseCommentText [] = [] +normaliseCommentText ('\r':xs) = normaliseCommentText xs +normaliseCommentText (x:xs) = x:normaliseCommentText xs + -- | Makes a comment which originates from a specific keyword. -mkKWComment :: GHC.AnnKeywordId -> GHC.SrcSpan -> Comment -mkKWComment kw ss = Comment (keywordToString $ G kw) (rs ss) (Just kw) +mkKWComment :: AnnKeywordId -> EpaLocation -> Comment +mkKWComment kw (EpaSpan ss) + = Comment (keywordToString $ G kw) (Anchor ss UnchangedAnchor) (Just kw) +mkKWComment kw (EpaDelta dp) + = Comment (keywordToString $ G kw) (Anchor placeholderRealSpan (MovedAnchor dp)) (Just kw) comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos) comment2dp = first AnnComment --- --------------------------------------------------------------------- -{- - -GHC 9.0 version - -data ApiAnns = - ApiAnns - { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan], - apiAnnEofPos :: Maybe RealSrcSpan, - apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment], - apiAnnRogueComments :: [RealLocated AnnotationComment] - } - --} - - -extractComments :: GHC.ApiAnns -> [Comment] -#if __GLASGOW_HASKELL__ >= 900 -extractComments anns - -- cm has type :: Map SrcSpan [Located AnnotationComment] - = map tokComment $ GHC.sortRealLocated $ ((concat - $ Map.elems (GHC.apiAnnComments anns)) ++ GHC.apiAnnRogueComments anns) -#else -extractComments (_,cm) - -- cm has type :: Map SrcSpan [Located AnnotationComment] - = map tokComment . GHC.sortLocated . concat $ Map.elems cm -#endif +sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a] +sortAnchorLocated = sortBy (compare `on` (anchor . getLoc)) -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) -getAnnotationEP :: (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a) - => a -> Anns -> Maybe Annotation -#else -getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation -#endif +getAnnotationEP :: (Data a) => Located a -> Anns -> Maybe Annotation getAnnotationEP la as = Map.lookup (mkAnnKey la) as @@ -451,18 +295,9 @@ -- start of the current element. annTrueEntryDelta :: Annotation -> DeltaPos annTrueEntryDelta Ann{annEntryDelta, annPriorComments} = - foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) + foldr addDP (SameLine 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) `addDP` annEntryDelta --- | Take an annotation and a required "true entry" and calculate an equivalent --- one relative to the last comment in the annPriorComments. -annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos -annCommentEntryDelta Ann{annPriorComments} trueDP = dp - where - commentDP = - foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) - dp = stepDP commentDP trueDP - -- | Return the DP of the first item that generates output, either a comment or the entry DP annLeadingCommentEntryDelta :: Annotation -> DeltaPos annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp @@ -476,267 +311,171 @@ dpFromString :: String -> DeltaPos dpFromString xs = dpFromString' xs 0 0 where - dpFromString' "" line col = DP (line, col) + dpFromString' "" line col = + if line == 0 + then SameLine col + else DifferentLine line col dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0 dpFromString' (_:cs) line col = dpFromString' cs line (col + 1) -- --------------------------------------------------------------------- -isSymbolRdrName :: GHC.RdrName -> Bool -isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n +isSymbolRdrName :: RdrName -> Bool +isSymbolRdrName n = isSymOcc $ rdrNameOcc n -rdrName2String :: GHC.RdrName -> String +rdrName2String :: RdrName -> String rdrName2String r = - case GHC.isExact_maybe r of + case isExact_maybe r of Just n -> name2String n Nothing -> case r of - GHC.Unqual occ -> GHC.occNameString occ - GHC.Qual modname occ -> GHC.moduleNameString modname ++ "." - ++ GHC.occNameString occ - GHC.Orig _ occ -> GHC.occNameString occ - GHC.Exact n -> GHC.getOccString n + Unqual occ -> occNameString occ + Qual modname occ -> moduleNameString modname ++ "." + ++ occNameString occ + Orig _ occ -> occNameString occ + Exact n -> getOccString n -name2String :: GHC.Name -> String -name2String = showGhc +name2String :: Name -> String +name2String = showPprUnsafe -- --------------------------------------------------------------------- --- | Put the provided context elements into the existing set with fresh level --- counts -setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet -setAcs ctxt acs = setAcsWithLevel ctxt 3 acs - --- | Put the provided context elements into the existing set with given level --- counts --- setAcsWithLevel :: Set.Set AstContext -> Int -> AstContextSet -> AstContextSet --- setAcsWithLevel ctxt level (ACS a) = ACS a' --- where --- upd s (k,v) = Map.insert k v s --- a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) -setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a -setAcsWithLevel ctxt level (ACS a) = ACS a' +occAttributes :: OccName.OccName -> String +occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" where - upd s (k,v) = Map.insert k v s - a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) - --- --------------------------------------------------------------------- --- | Remove the provided context element from the existing set --- unsetAcs :: AstContext -> AstContextSet -> AstContextSet -unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a -unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a + -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " + ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " + vo = if isVarOcc o then "Var " else "" + tv = if isTvOcc o then "Tv " else "" + tc = if isTcOcc o then "Tc " else "" + d = if isDataOcc o then "Data " else "" + ds = if isDataSymOcc o then "DataSym " else "" + s = if isSymOcc o then "Sym " else "" + v = if isValOcc o then "Val " else "" --- --------------------------------------------------------------------- + -- --------------------------------------------------------------------- --- | Are any of the contexts currently active? --- inAcs :: Set.Set AstContext -> AstContextSet -> Bool -inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool -inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a) +locatedAnAnchor :: LocatedAn a t -> RealSrcSpan +locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l +locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a --- | propagate the ACS down a level, dropping all values which hit zero --- pushAcs :: AstContextSet -> AstContextSet -pushAcs :: ACS' a -> ACS' a -pushAcs (ACS a) = ACS $ Map.mapMaybe f a - where - f n - | n <= 1 = Nothing - | otherwise = Just (n - 1) + -- --------------------------------------------------------------------- --- |Sometimes we have to pass the context down unchanged. Bump each count up by --- one so that it is unchanged after a @pushAcs@ call. --- bumpAcs :: AstContextSet -> AstContextSet -bumpAcs :: ACS' a -> ACS' a -bumpAcs (ACS a) = ACS $ Map.mapMaybe f a - where - f n = Just (n + 1) +showAst :: (Data a) => a -> String +showAst ast + = showSDocUnsafe + $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast -- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 - - -- to be called in annotationsToCommentsBF by the pretty printer -makeBooleanFormulaAnns :: (GHC.Outputable a) - => GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)] -makeBooleanFormulaAnns bf = go 1 bf - where - go :: (GHC.Outputable a) - => Int -> GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)] - go _ (GHC.Var _) = [] - go l v@(GHC.And [a,b]) = - go 3 a ++ - go 3 b ++ - (if l > 3 then addParensIfNeeded v else []) ++ - [(GHC.AnnComma, ssAfter (getBoolSrcSpan a))] - go l v@(GHC.Or [a,b]) = - go 2 a ++ - go 2 b ++ - (if l > 2 then addParensIfNeeded v else []) ++ - [(GHC.AnnVbar, ssAfter (getBoolSrcSpan a) )] - go _ x = error $ "makeBooleanFormulaAnns: unexpected case:" ++ showGhc x - - -addParensIfNeeded :: GHC.Outputable a - => GHC.BooleanFormula (GHC.Located a) - -> [(GHC.AnnKeywordId, GHC.SrcSpan)] -addParensIfNeeded (GHC.Var _) = [] -addParensIfNeeded a = [(GHC.AnnOpenP,opp),(GHC.AnnCloseP,cpp)] - where - ss = getBoolSrcSpan a - opp = ssBefore ss - cpp = ssAfter ss - - --- ssFor a b = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) - --- | Generate a SrcSpan of single char length before the given one -ssBefore :: GHC.SrcSpan -> GHC.SrcSpan -ssBefore a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e) - where - GHC.RealSrcLoc as = GHC.srcSpanStart a - s = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 2) - e = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 1) +-- Putting these here for the time being, to avoid import loops --- | Generate a SrcSpan of single char length after the given one -ssAfter :: GHC.SrcSpan -> GHC.SrcSpan -ssAfter a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e) - where - GHC.RealSrcLoc ae = GHC.srcSpanEnd a - s = ae - e = GHC.advanceSrcLoc s ' ' +ghead :: String -> [a] -> a +ghead info [] = error $ "ghead "++info++" []" +ghead _info (h:_) = h +glast :: String -> [a] -> a +glast info [] = error $ "glast " ++ info ++ " []" +glast _info h = last h -getBoolSrcSpan :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> GHC.SrcSpan -getBoolSrcSpan (GHC.Var (GHC.L ss _)) = ss -getBoolSrcSpan (GHC.And [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) -getBoolSrcSpan (GHC.Or [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) -getBoolSrcSpan x = error $ "getBoolSrcSpan: unexpected case:" ++ showGhc x +gtail :: String -> [a] -> [a] +gtail info [] = error $ "gtail " ++ info ++ " []" +gtail _info h = tail h -#endif +gfromJust :: String -> Maybe a -> a +gfromJust _info (Just h) = h +gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing" -- --------------------------------------------------------------------- --- | Show a GHC AST with interleaved Annotation information. -showAnnData :: Data a => Anns -> Int -> a -> String -showAnnData anns n = - generic -- `ext1Q` located - `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan - `extQ` bytestring - `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon - -- `extQ` overLit - `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet - `extQ` fixity - `ext2Q` located - where generic :: Data a => a -> String - generic t = indent n ++ "(" ++ showConstr (toConstr t) - ++ space (unwords (gmapQ (showAnnData anns (n+1)) t)) ++ ")" - space "" = "" - space s = ' ':s - indent i = "\n" ++ replicate i ' ' - string = show :: String -> String - fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String - bytestring = show :: B.ByteString -> String - list l = indent n ++ "[" - ++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]" +-- -- Copied from syb for the test - name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String - -- occName = ("{OccName: "++) . (++"}") . OccName.occNameString - occName o = "{OccName: "++ OccName.occNameString o ++ " " ++ occAttributes o ++ "}" - moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String - -- srcSpan = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String - srcSpan :: GHC.SrcSpan -> String - srcSpan ss = "{ "++ showSDoc_ (GHC.hang (GHC.ppr ss) (n+2) - -- (GHC.ppr (Map.lookup ss anns) - (GHC.text "") - ) - ++"}" +-- -- | Generic queries of type \"r\", +-- -- i.e., take any \"a\" and return an \"r\" +-- -- +-- type GenericQ r = forall a. Data a => a -> r - 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 +-- -- | Make a generic query; +-- -- start from a type-specific case; +-- -- return a constant otherwise +-- -- +-- mkQ :: ( Typeable a +-- , Typeable b +-- ) +-- => r +-- -> (b -> r) +-- -> a +-- -> r +-- (r `mkQ` br) a = case cast a of +-- Just b -> br b +-- Nothing -> r - bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String - bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList - bagName :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String - bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList - bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String - bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList +-- -- | Make a generic monadic transformation; +-- -- start from a type-specific case; +-- -- resort to return otherwise +-- -- +-- mkM :: ( Monad m +-- , Typeable a +-- , Typeable b +-- ) +-- => (b -> m b) +-- -> a +-- -> m a +-- mkM = extM return -#if __GLASGOW_HASKELL__ > 800 - nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable -#else - nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems -#endif +-- -- | Flexible type extension +-- ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a +-- ext0 def ext = maybe def id (gcast ext) - fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String - located :: (Data b,Data loc) => GHC.GenLocated loc b -> String - -- located la = show (getAnnotationEP la anns) - located (GHC.L ss a) = - indent n ++ "(" - ++ case cast ss of - Just (s :: GHC.SrcSpan) -> - srcSpan s - ++ indent (n + 1) ++ - show (getAnnotationEP (GHC.L s a) anns) - -- ++ case showWrappedDeclAnns (GHC.L s a) of - -- Nothing -> "" - -- Just annStr -> indent (n + 1) ++ annStr - Nothing -> "nnnnnnnn" - ++ showAnnData anns (n+1) a - ++ ")" +-- -- | Extend a generic query by a type-specific case +-- extQ :: ( Typeable a +-- , Typeable b +-- ) +-- => (a -> q) +-- -> (b -> q) +-- -> a +-- -> q +-- extQ f g a = maybe (f a) g (cast a) +-- -- | Flexible type extension +-- ext2 :: (Data a, Typeable t) +-- => c a +-- -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) +-- -> c a +-- ext2 def ext = maybe def id (dataCast2 ext) -occAttributes :: OccName.OccName -> String -occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" - where - ns = (GHC.showSDocUnsafe $ OccName.pprNameSpaceBrief $ GHC.occNameSpace o) ++ ", " - vo = if GHC.isVarOcc o then "Var " else "" - tv = if GHC.isTvOcc o then "Tv " else "" - tc = if GHC.isTcOcc o then "Tc " else "" - d = if GHC.isDataOcc o then "Data " else "" - ds = if GHC.isDataSymOcc o then "DataSym " else "" - s = if GHC.isSymOcc o then "Sym " else "" - v = if GHC.isValOcc o then "Val " else "" -{- -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. --} - - -- --------------------------------------------------------------------- - -showSDoc_ :: GHC.SDoc -> String -showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags - -showSDocDebug_ :: GHC.SDoc -> String -#if __GLASGOW_HASKELL__ <= 710 -showSDocDebug_ = GHC.showSDoc GHC.unsafeGlobalDynFlags -#else -showSDocDebug_ = GHC.showSDocDebug GHC.unsafeGlobalDynFlags -#endif +-- -- | Extend a generic monadic transformation by a type-specific case +-- extM :: ( Typeable a +-- , Typeable b +-- ) +-- => (a -> m a) -> (b -> m b) -> a -> m a +-- extM def ext = unM ((M def) `ext0` (M ext)) --- --------------------------------------------------------------------- --- Putting these here for the time being, to avoid import loops +-- -- | Type extension of monadic transformations for type constructors +-- ext2M :: (Data d, Typeable t) +-- => (forall e. Data e => e -> m e) +-- -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2)) +-- -> d -> m d +-- ext2M def ext = unM ((M def) `ext2` (M ext)) -ghead :: String -> [a] -> a -ghead info [] = error $ "ghead "++info++" []" -ghead _info (h:_) = h +-- -- | The type constructor for transformations +-- newtype M m x = M { unM :: x -> m x } -glast :: String -> [a] -> a -glast info [] = error $ "glast " ++ info ++ " []" -glast _info h = last h +-- -- | Generic monadic transformations, +-- -- i.e., take an \"a\" and compute an \"a\" +-- -- +-- type GenericM m = forall a. Data a => a -> m a -gtail :: String -> [a] -> [a] -gtail info [] = error $ "gtail " ++ info ++ " []" -gtail _info h = tail h +-- -- | Monadic variation on everywhere +-- everywhereM :: forall m. Monad m => GenericM m -> GenericM m -gfromJust :: String -> Maybe a -> a -gfromJust _info (Just h) = h -gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing" +-- -- Bottom-up order is also reflected in order of do-actions +-- everywhereM f = go +-- where +-- go :: GenericM m +-- go x = do +-- x' <- gmapM go x +-- f x' diff --git a/tests/Roundtrip.hs b/tests/Roundtrip.hs --- a/tests/Roundtrip.hs +++ b/tests/Roundtrip.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where +import qualified GHC.Paths import Control.Exception import Control.Monad import Data.Time.Clock @@ -13,7 +14,6 @@ import System.Exit import System.FilePath import System.IO --- import System.IO.Temp import Test.Common import Test.CommonUtils import Test.HUnit @@ -74,6 +74,7 @@ main :: IO () main = do + let libdir = GHC.Paths.libdir createDirectoryIfMissing True workDir createDirectoryIfMissing True configDir createDirectoryIfMissing True failuresDir @@ -82,7 +83,7 @@ [] -> putStrLn "Must enter directory to process" ["failures"] -> do fs <- lines <$> readFile origFailuresFile - () <$ runTests (TestList (map mkParserTest fs)) + () <$ runTests (TestList (map (mkParserTest libdir) fs)) ["clean"] -> do putStrLn "Cleaning..." writeFile processed "" @@ -101,7 +102,7 @@ !cppList <- lines <$> readFile cppFile !parseFailList <- lines <$> readFile parseFailFile let done = S.fromList (processedList ++ cppList ++ blackList ++ knownFailures ++ parseFailList) - tsts <- TestList <$> mapM (tests done) ds + tsts <- TestList <$> mapM (tests libdir done) ds _ <- runTests tsts return () @@ -112,34 +113,34 @@ putStrLn $ "Verbosity: " ++ show verb runTestTT t -tests :: S.Set String -> FilePath -> IO Test -tests done dir = do - roundTripHackage done dir +tests :: LibDir -> S.Set String -> FilePath -> IO Test +tests libdir done dir = do + roundTripHackage libdir done dir -- Selection: -- Hackage dir -roundTripHackage :: S.Set String -> FilePath -> IO Test -roundTripHackage done hackageDir = do +roundTripHackage :: LibDir -> S.Set String -> FilePath -> IO Test +roundTripHackage libdir done hackageDir = do packageDirs <- drop 2 <$> getDirectoryContents hackageDir when (verb <= Debug) (traceShowM hackageDir) when (verb <= Debug) (traceShowM packageDirs) - TestList <$> mapM (roundTripPackage done) (zip [0..] (map (hackageDir ) packageDirs)) + TestList <$> mapM (roundTripPackage libdir done) (zip [0..] (map (hackageDir ) packageDirs)) -roundTripPackage :: S.Set String -> (Int, FilePath) -> IO Test -roundTripPackage done (n, dir) = do +roundTripPackage :: LibDir -> S.Set String -> (Int, FilePath) -> IO Test +roundTripPackage libdir done (n, dir) = do putStrLn (show n) when (verb <= Status) (traceM dir) hsFiles <- filter (flip S.notMember done) <$> findSrcFiles dir - return (TestLabel (dropFileName dir) (TestList $ map mkParserTest hsFiles)) + return (TestLabel (dropFileName dir) (TestList $ map (mkParserTest libdir) hsFiles)) -mkParserTest :: FilePath -> Test -mkParserTest fp = +mkParserTest :: LibDir -> FilePath -> Test +mkParserTest libdir fp = TestLabel fp $ TestCase (do writeLog $ "starting:" ++ fp - r1 <- catchAny (roundTripTest fp) $ \e -> do + r1 <- catchAny (roundTripTest libdir fp) $ \e -> do writeError fp throwIO e case r1 of diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -6,7 +5,7 @@ module Main where -- import Language.Haskell.GHC.ExactPrint.Utils ( showGhc ) - +import qualified GHC.Paths import Control.Monad import System.Directory import System.FilePath @@ -28,44 +27,21 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 | GHC810 | GHC90 +data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 | GHC810 | GHC90 | GHC92 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion -ghcVersion = -#if __GLASGOW_HASKELL__ >= 900 - GHC90 -#elif __GLASGOW_HASKELL__ > 808 - GHC810 -#elif __GLASGOW_HASKELL__ > 806 - GHC88 -#elif __GLASGOW_HASKELL__ > 804 - GHC86 -#elif __GLASGOW_HASKELL__ > 802 - GHC84 -#elif __GLASGOW_HASKELL__ > 800 - GHC82 -#elif __GLASGOW_HASKELL__ >= 711 - GHC80 -#else - GHC710 -#endif +ghcVersion = GHC92 -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of - GHC710 -> ["ghc710-only", "ghc710", "vect"] - GHC80 -> [ "pre-ghc90", "ghc710", "ghc80", "vect"] - GHC82 -> ["pre-ghc86", "pre-ghc90", "ghc710", "ghc80", "ghc82", "vect"] - GHC84 -> ["pre-ghc86", "pre-ghc810", "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ] - GHC86 -> ["pre-ghc810", "pre-ghc810", "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ] - GHC88 -> ["pre-ghc810", "pre-ghc810", "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ] - GHC810 -> [ "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810" ] - GHC90 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90"] + GHC90 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90"] + GHC92 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92"] - -- GHC90 -> ["ghc90-copied"] - -- GHC90 -> ["ghc90"] + -- GHC92 -> ["ghc92-copied"] + -- GHC92 -> ["ghc92"] -- --------------------------------------------------------------------- @@ -81,7 +57,8 @@ transform :: IO () transform = hSilence [stderr] $ do - cnts <- fst <$> runTestText (putTextToHandle stdout True) transformTests + let libdir = GHC.Paths.libdir + cnts <- fst <$> runTestText (putTextToHandle stdout True) (transformTestsTT libdir) putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure @@ -89,37 +66,21 @@ -- --------------------------------------------------------------------- -findTests :: IO Test -findTests = testList "Round-trip tests" <$> mapM (findTestsDir id mkParserTest) testDirs +findTests :: LibDir -> IO Test +findTests libdir + = testList "Round-trip tests" <$> mapM (findTestsDir id (mkParserTest libdir)) testDirs -findPrettyTests :: IO Test -findPrettyTests = +findPrettyTests :: LibDir -> IO Test +findPrettyTests libdir = testList "Default Annotations round-trip tests" - <$> mapM (findTestsDir filterPrettyRoundTrip mkPrettyRoundtrip) testDirs + <$> mapM (findTestsDir filterPrettyRoundTrip (mkPrettyRoundtrip libdir)) testDirs -- | 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 @@ -142,48 +103,39 @@ mkTests :: IO Test mkTests = do -- listTests - roundTripTests <- findTests - prettyRoundTripTests <- findPrettyTests + let libdir = GHC.Paths.libdir + roundTripTests <- findTests libdir + prettyRoundTripTests <- findPrettyTests libdir return $ TestList [ internalTests, roundTripTests , - transformTests - , failingTests - , noAnnotationTests - , - prettyRoundTripTests + (transformTests libdir) + , (failingTests libdir) + -- , noAnnotationTests + -- , + -- prettyRoundTripTests ] --- Tests that will fail until https://phabricator.haskell.org/D907 lands in a --- future GHC -failingTests :: Test -failingTests = testList "Failing tests" +failingTests :: LibDir -> Test +failingTests libdir = testList "Failing tests" [ -- Tests requiring future GHC modifications - mkTestModBad "InfixOperator.hs" -#if __GLASGOW_HASKELL__ > 802 -#elif __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 - , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.4 - , mkTestModBad "UnicodeSyntax.hs" - , mkTestModBad "UnicodeRules.hs" - , mkTestModBad "Deprecation.hs" - , mkTestModBad "MultiLineWarningPragma.hs" -#endif + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20243 + mkTestModBad libdir "n-plus-k-patterns.hs" + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20258 + , mkTestModBad libdir "TopLevelSemis.hs" + -- We do not capture EOF location very well any more + , mkTestModBad libdir "T10970a.hs" + ] -mkParserTest :: FilePath -> FilePath -> Test -mkParserTest dir fp = mkParsingTest roundTripTest dir fp +mkParserTest :: LibDir -> FilePath -> FilePath -> Test +mkParserTest libdir dir fp = mkParsingTest (roundTripTest libdir) dir fp -- --------------------------------------------------------------------- @@ -199,76 +151,161 @@ tr :: IO (Counts,Int) tr = hSilence [stderr] $ do - prettyRoundTripTests <- findPrettyTests + let libdir = GHC.Paths.libdir + prettyRoundTripTests <- findPrettyTests libdir runTestText (putTextToHandle stdout True) prettyRoundTripTests tt' :: IO (Counts,Int) -tt' = runTestText (putTextToHandle stdout True) $ TestList [ +tt' = do + let libdir = GHC.Paths.libdir + runTestText (putTextToHandle stdout True) $ TestList [ - -- mkTestModChange changeRenameCase1 "RenameCase1.hs" + -- mkTestModChange libdir changeRenameCase1 "RenameCase1.hs" - -- mkParserTest "ghc710" "Associated.hs" + -- mkParserTest libdir "ghc710" "UnicodeSyntaxFailure.hs" + -- mkParserTest libdir "ghc80" "Class.hs" + -- mkParserTest libdir "ghc82" "Completesig03A.hs" + -- mkParserTest libdir "ghc82" "brackets.hs" + -- mkParserTest libdir "ghc84" "T13747.hs" + -- mkParserTest libdir "ghc86" "SlidingTypeSyn.hs" - -- mkParserTest "ghc710" "BracesSemiDataDecl.hs" - -- mkParserTest "ghc710" "GADTRecords.hs" - -- mkParserTest "ghc710" "RdrNames.hs" - -- mkParserTest "ghc710" "RdrNames1.hs" + -- mkParserTest libdir "ghc86" "dynamic-paper.hs" + -- mkParserTest libdir "ghc90" "ArrowLambdaCase.hs" + -- mkParserTest libdir "ghc80" "T6018failclosed.hs" + -- mkParserTest libdir "failing" "InfixOperator.hs" - -- mkParserTest "ghc80" "T11010.hs" - -- mkParserTest "ghc80" "Test10399.hs" - -- mkParserTest "ghc90" "Linear12.hs" - -- mkParserTest "ghc90" "T17544_kw.hs" + -- mkParserTest libdir "ghc92-copied" "AddLocalDecl5.expected.hs" + -- mkParserTest libdir "ghc92" "ScopesBug.hs" + -- mkParserTest libdir "ghc92-copied" "T10279.hs" + -- mkParserTest libdir "ghc92-copied" "T10891.hs" + -- mkParserTest libdir "ghc92-copied" "T2632.hs" + -- mkParserTest libdir "ghc92-copied" "T4442.hs" + -- mkParserTest libdir "ghc92-copied" "TH_reifyExplicitForAllFams.hs" + -- mkParserTest libdir "ghc92-copied" "TH_unresolvedInfix.hs" + -- mkParserTest libdir "ghc92-copied" "regalloc_unit_tests.hs" - -- mkParserTest "ghc90" "FromManual.hs" - -- mkPrettyRoundtrip "ghc90" "FromManual.hs" + -- mkParserTest libdir "ghc92" "Checkpoint.hs" + -- mkParserTest libdir "ghc710" "MultiLineCommentWithPragmas.hs" - -- mkParserTest "ghc90" "Linear1Rule.hs" - -- mkPrettyRoundtrip "ghc90" "Linear1Rule.hs" + -- mkParserTest libdir "ghc710" "Process.hs" + -- mkParserTest libdir "ghc92" "PostgreSQL.hs" + -- mkParserTest libdir "ghc92" "Main.hs" + -- mkParserTest libdir "ghc92" "MainHareTest.hs" + -- mkParserTest libdir "ghc92" "TH.hs" + -- mkParserTest libdir "ghc92" "LeapSeconds.hs" + -- mkParserTest libdir "ghc92" "proc-lets.hs" + -- mkParserTest libdir "ghc92" "n-plus-k-patterns.hs" + -- mkParserTest libdir "ghc92" "TopLevelSemis.hs" + -- mkParserTest libdir "ghc92" "MiniBall.hs" - -- mkParserTest "ghc80" "Test11018.hs" - -- mkPrettyRoundtrip "ghc80" "Test11018.hs" + mkParserTest libdir "ghc80" "T10970a.hs" - -- mkParserTest "ghc86" "UnicodeSyntax.hs" - -- mkPrettyRoundtrip "ghc86" "UnicodeSyntax.hs" - mkParserTest "ghc86" "empty-foralls.hs" - -- mkPrettyRoundtrip "ghc86" "empty-foralls.hs" + -- mkTestModChange libdir rmDecl1 "RmDecl1.hs" - -- mkParserTest "ghc710" "PatSynBind.hs" - -- mkPrettyRoundtrip "ghc710" "PatSynBind.hs" + -- mkParserTest libdir "ghc92" "LinearArrow.hs" + -- mkParserTest libdir "transform" "AddLocalDecl5.1.hs" + -- mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" + -- mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs" + -- mkTestModChange libdir addLocaLDecl1 "AddLocalDecl1.hs" + {- + ### Failure in: 1:Round-trip tests:1:ghc80:27:Decision.hs + ### Failure in: 2:transformation tests:0:Low level transformations:15 + AddLocalDecl1.hs + AddLocalDecl4.hs + AddLocalDecl5.hs + AddLocalDecl6.hs + -} + -- mkParserTest libdir "ghc710" "EmptyMostly.hs" + + -- comment problem + -- mkParserTest libdir "ghc710" "Move1.hs" + -- mkParserTest libdir "ghc80" "Decision.hs" + -- mkParserTest libdir "ghc80" "RandomPGC.hs" + -- mkParserTest libdir "ghc92" "BlockComment.hs" + -- mkParserTest libdir "ghc92" "CommentPlacement.hs" + -- mkParserTest libdir "ghc92" "CommentPlacement2.hs" + -- mkParserTest libdir "ghc80" "Decision.hs" + + -- mkParserTest libdir "ghc92-copied" "AddLocalDecl5.expected.hs" + -- mkParserTest libdir "ghc92-copied" "AtomicPrimops.hs" + -- mkParserTest libdir "ghc92-copied" "BinaryLiterals0.hs" + -- mkParserTest libdir "ghc92-copied" "CountDeps.hs" + -- mkParserTest libdir "ghc92-copied" "regalloc_unit_tests.hs" + + + +-- ### Failure in: 1:Round-trip tests:0:ghc710:20:Control.hs +-- ### Failure in: 1:Round-trip tests:0:ghc710:21:CoreIr.hs +-- ### Failure in: 1:Round-trip tests:0:ghc710:23:Cpp.hs +-- ### Failure in: 1:Round-trip tests:0:ghc710:38:EmptyMostly.hs +-- ### Failure in: 1:Round-trip tests:0:ghc710:39:EmptyMostly2.hs +-- ### Failure in: 1:Round-trip tests:0:ghc710:40:EmptyMostlyInst.hs +-- ### Failure in: 1:Round-trip tests:0:ghc710:41:EmptyMostlyNoSemis.hs +-- ### Error in: 1:Round-trip tests:0:ghc710:50:ForeignDecl.hs + + -- mkParserTest libdir "ghc710" "BracesSemiDataDecl.hs" + -- mkParserTest libdir "ghc710" "GADTRecords.hs" + -- mkParserTest libdir "ghc710" "RdrNames.hs" + -- mkParserTest libdir "ghc710" "RdrNames1.hs" + + -- mkParserTest libdir "ghc80" "T11010.hs" + -- mkParserTest libdir "ghc80" "Test10399.hs" + -- mkParserTest libdir "ghc90" "Linear12.hs" + -- mkParserTest libdir "ghc90" "T17544_kw.hs" + + -- mkParserTest libdir "ghc90" "FromManual.hs" + -- mkPrettyRoundtrip libdir "ghc90" "FromManual.hs" + + -- mkParserTest libdir "ghc90" "Linear1Rule.hs" + -- mkPrettyRoundtrip libdir "ghc90" "Linear1Rule.hs" + + -- mkParserTest libdir "ghc80" "Test11018.hs" + -- mkPrettyRoundtrip libdir "ghc80" "Test11018.hs" + + -- mkParserTest libdir "ghc86" "UnicodeSyntax.hs" + -- mkPrettyRoundtrip libdir "ghc86" "UnicodeSyntax.hs" + + -- mkParserTest libdir "ghc86" "empty-foralls.hs" + -- mkPrettyRoundtrip libdir "ghc86" "empty-foralls.hs" + + -- mkParserTest libdir "ghc710" "PatSynBind.hs" + -- mkPrettyRoundtrip libdir "ghc710" "PatSynBind.hs" + -- --------------------------------------------- - -- mkParserTest "ghc86" "Webhook.hs" + -- mkParserTest libdir "ghc86" "Webhook.hs" - -- mkParserTest "ghc710" "TypeBrackets2.hs" - -- mkPrettyRoundtrip "ghc710" "TypeBrackets2.hs" + -- mkParserTest libdir "ghc710" "TypeBrackets2.hs" + -- mkPrettyRoundtrip libdir "ghc710" "TypeBrackets2.hs" - -- mkParserTest "ghc710" "DataDecl.hs" - -- mkPrettyRoundtrip "ghc710" "DataDecl.hs" + -- mkParserTest libdir "ghc710" "DataDecl.hs" + -- mkPrettyRoundtrip libdir "ghc710" "DataDecl.hs" - -- mkParserTest "ghc90" "BaseDescriptor.hs" - -- mkPrettyRoundtrip "ghc90" "BaseDescriptor.hs" + -- mkParserTest libdir "ghc90" "BaseDescriptor.hs" + -- mkPrettyRoundtrip libdir "ghc90" "BaseDescriptor.hs" - -- mkParserTest "ghc90" "BaseDescriptors2.hs" - -- mkPrettyRoundtrip "ghc90" "BaseDescriptors2.hs" + -- mkParserTest libdir "ghc90" "BaseDescriptors2.hs" + -- mkPrettyRoundtrip libdir "ghc90" "BaseDescriptors2.hs" -- Needs GHC changes ] -testsTT :: Test -testsTT = TestList +testsTT :: LibDir -> Test +testsTT libdir = TestList [ - mkParserTest "ghc710" "Cpp.hs" - , mkParserTest "ghc710" "DroppedDoSpace.hs" + mkParserTest libdir "ghc710" "Cpp.hs" + , mkParserTest libdir "ghc710" "DroppedDoSpace.hs" ] tt :: IO () -- tt = hSilence [stderr] $ do tt = do - cnts <- fst <$> runTestText (putTextToHandle stdout True) testsTT + let libdir = GHC.Paths.libdir + cnts <- fst <$> runTestText (putTextToHandle stdout True) (testsTT libdir) putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -22,42 +21,27 @@ , genTest , noChange , mkDebugOutput -#if __GLASGOW_HASKELL__ > 808 , showErrorMessages -#endif + , LibDir ) where import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCpp) +import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Preprocess -import Language.Haskell.GHC.ExactPrint.Types - +-- import Language.Haskell.GHC.ExactPrint.Types -#if __GLASGOW_HASKELL__ >= 900 import qualified Control.Monad.IO.Class as GHC import qualified GHC as GHC hiding (parseModule) import qualified GHC.Data.Bag as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.Utils.Error as GHC -import qualified GHC.Utils.Outputable as GHC -#else -import qualified ApiAnnotation as GHC -import qualified DynFlags as GHC -#if __GLASGOW_HASKELL__ > 808 -import qualified Bag as GHC -import qualified ErrUtils as GHC -#endif -import qualified GHC as GHC hiding (parseModule) -import qualified MonadUtils as GHC -#endif +-- import qualified GHC.Utils.Outputable as GHC +-- import qualified GHC.Hs.Dump as GHC -#if __GLASGOW_HASKELL__ <= 710 -#else import qualified GHC.LanguageExtensions as LangExt -#endif -- import qualified Data.Map as Map @@ -66,7 +50,7 @@ import System.Directory -import Test.Consistency +-- import Test.Consistency import Test.HUnit import System.FilePath @@ -88,7 +72,7 @@ { debugTxt :: String , status :: ReportType , cppStatus :: Maybe String -- Result of CPP if invoked - , inconsistent :: Maybe [(AnnSpan, (GHC.AnnKeywordId, [AnnSpan]))] + -- , inconsistent :: Maybe [(AnnSpan, (GHC.AnnKeywordId, [AnnSpan]))] } data ParseFailure = ParseFailure String @@ -116,8 +100,8 @@ removeSpaces = map (\case {'\160' -> ' '; s -> s}) -} -roundTripTest :: FilePath -> IO Report -roundTripTest f = genTest noChange f f +roundTripTest :: LibDir -> FilePath -> IO Report +roundTripTest libdir f = genTest libdir noChange f f mkParsingTest :: (FilePath -> IO Report) -> FilePath -> FilePath -> Test @@ -125,88 +109,75 @@ let basename = testPrefix dir fp writeFailure = writeFile (basename <.> "out") writeHsPP = writeFile (basename <.> "hspp") - writeIncons s = writeFile (basename <.> "incons") (showGhc s) + -- writeIncons s = writeFile (basename <.> "incons") (showGhc s) in TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id <$> tester basename writeFailure (debugTxt r) - forM_ (inconsistent r) writeIncons + -- forM_ (inconsistent r) writeIncons forM_ (cppStatus r) writeHsPP assertBool fp (status r == Success)) -type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) +-- type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) +-- First param is libdir +type Changer = LibDir -> (GHC.ParsedSource -> IO GHC.ParsedSource) noChange :: Changer -noChange ans parsed = return (ans,parsed) +noChange _libdir parsed = return parsed -genTest :: Changer -> FilePath -> FilePath -> IO Report -genTest f origFile expectedFile = do - res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile +genTest :: LibDir -> Changer -> FilePath -> FilePath -> IO Report +genTest libdir f origFile expectedFile = do + res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions origFile expected <- GHC.liftIO $ readFileGhc expectedFile orig <- GHC.liftIO $ readFileGhc origFile -- let pristine = removeSpaces expected let pristine = expected case res of -#if __GLASGOW_HASKELL__ > 808 Left m -> return . Left $ ParseFailure (showErrorMessages m) -#else - Left (_ss, m) -> return . Left $ ParseFailure m -#endif - Right (apianns, injectedComments, dflags, pmod) -> do - (printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments) -#if __GLASGOW_HASKELL__ <= 710 - let useCpp = GHC.xopt GHC.Opt_Cpp dflags -#else + Right (injectedComments, dflags, pmod) -> do + (printed', pmod') <- GHC.liftIO (runRoundTrip libdir f pmod injectedComments) let useCpp = GHC.xopt LangExt.Cpp dflags -#endif printed = trimPrinted printed' - -- let (printed, anns) = first trimPrinted $ runRoundTrip apianns pmod injectedComments -- Clang cpp adds an extra newline character -- Do not remove this line! trimPrinted p = if useCpp then unlines $ take (length (lines pristine)) (lines p) else p - debugTxt = mkDebugOutput origFile printed pristine apianns anns pmod' - consistency = checkConsistency apianns pmod - inconsistent = if null consistency then Nothing else Just consistency + debugTxt = mkDebugOutput origFile printed pristine pmod' + -- consistency = checkConsistency apianns pmod + -- inconsistent = if null consistency then Nothing else Just consistency status = if printed == pristine then Success else RoundTripFailure cppStatus = if useCpp then Just orig else Nothing return $ Right Report {..} mkDebugOutput :: FilePath -> String -> String - -> GHC.ApiAnns - -> Anns -> GHC.ParsedSource -> String -mkDebugOutput filename printed original apianns anns parsed = +mkDebugOutput filename printed original parsed = intercalate sep [ printed , filename , "lengths:" ++ show (length printed,length original) ++ "\n" - , showAnnData anns 0 parsed - , showGhc anns - , showGhc apianns + -- , showAnnData anns 0 parsed + , showAst parsed + -- , showGhc anns ] where sep = "\n==============\n" -runRoundTrip :: Changer -#if __GLASGOW_HASKELL__ >= 900 - -> GHC.ApiAnns -> GHC.Located GHC.HsModule -#else - -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GhcPs) -#endif - -> [Comment] - -> IO (String, Anns, GHC.ParsedSource) -runRoundTrip f !anns !parsedOrig cs = do - let !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns - (annsMod, pmod) <- f relAnns parsedOrig - let !printed = exactPrint pmod annsMod - -- return (printed, relAnns, pmod) - return (printed, annsMod, pmod) +runRoundTrip :: LibDir + -> Changer + -> GHC.Located GHC.HsModule + -> [GHC.LEpaComment] + -> IO (String, GHC.ParsedSource) +runRoundTrip libdir f !parsedOrig cs = do + let !parsedOrigWithComments = insertCppComments parsedOrig cs + pmod <- f libdir parsedOrigWithComments + let !printed = exactPrint pmod + return (printed, pmod) -- ---------------------------------------------------------------------` @@ -230,11 +201,7 @@ cfileName <- GHC.liftIO $ canonicalizePath fileName graph <- GHC.getModuleGraph -#if __GLASGOW_HASKELL__ >= 804 cgraph <- GHC.liftIO $ canonicalizeGraph (GHC.mgModSummaries graph) -#else - cgraph <- GHC.liftIO $ canonicalizeGraph graph -#endif let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph case mm of @@ -243,20 +210,16 @@ -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 808 showErrorMessages :: GHC.ErrorMessages -> String showErrorMessages m = show $ GHC.bagToList m -#endif -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 900 -instance GHC.Outputable GHC.ApiAnns where - ppr (GHC.ApiAnns items eof comments rogueComments) - = GHC.text "ApiAnns" GHC.<+> GHC.ppr items - GHC.<+> GHC.ppr eof - GHC.<+> GHC.ppr comments - GHC.<+> GHC.ppr rogueComments -#endif +-- instance GHC.Outputable GHC.ApiAnns where +-- ppr (GHC.ApiAnns items eof comments rogueComments) +-- = GHC.text "ApiAnns" GHC.<+> GHC.ppr items +-- GHC.<+> GHC.ppr eof +-- GHC.<+> GHC.ppr comments +-- GHC.<+> GHC.ppr rogueComments -- --------------------------------------------------------------------- diff --git a/tests/Test/CommonUtils.hs b/tests/Test/CommonUtils.hs --- a/tests/Test/CommonUtils.hs +++ b/tests/Test/CommonUtils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} module Test.CommonUtils ( findSrcFiles @@ -25,11 +24,7 @@ import Data.List hiding (find) import System.FilePath import System.FilePath.Find -#if __GLASGOW_HASKELL__ >= 900 import qualified GHC.Data.StringBuffer as GHC -#else -import qualified StringBuffer as GHC -#endif -- --------------------------------------------------------------------- diff --git a/tests/Test/Consistency.hs b/tests/Test/Consistency.hs deleted file mode 100644 --- a/tests/Test/Consistency.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE CPP #-} -module Test.Consistency where - -import Data.Data -import GHC -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Generics (everything, mkQ) - -import Language.Haskell.GHC.ExactPrint.Types (AnnSpan) -import Language.Haskell.GHC.ExactPrint.Utils (isPointSrcSpan, rs) - --- import Debug.Trace - -checkConsistency :: Data a => GHC.ApiAnns -> a -> [(AnnSpan, (AnnKeywordId, [AnnSpan]))] -checkConsistency anns ast = - let srcspans = Set.fromList $ map rs $ getAllSrcSpans ast - cons (s, (_, vs)) = Set.member s srcspans || (all (isPointSrcSpan) vs) - in filter (\s -> not (cons s)) (getAnnSrcSpans anns) - -getAnnSrcSpans :: ApiAnns -> [(AnnSpan,(AnnKeywordId,[AnnSpan]))] -#if __GLASGOW_HASKELL__ >= 900 -getAnnSrcSpans anns = map (\((ss,k),v) -> (ss,(k,v))) $ Map.toList (GHC.apiAnnItems anns) -#else -getAnnSrcSpans (anns,_) = map (\((ss,k),v) -> (ss,(k,v))) $ Map.toList anns -#endif - -getAllSrcSpans :: (Data t) => t -> [SrcSpan] -getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [SrcSpan] - getSrcSpan ss = [ss] - diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,61 +8,26 @@ -- import Control.Monad.State import Data.Algorithm.Diff import Data.Algorithm.DiffOutput -import Data.Data (Data, toConstr, showConstr, cast) -import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) +-- import Data.Data (Data, toConstr, showConstr, cast) +-- import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) import Data.List -- import Data.Ord (comparing) -import qualified Data.ByteString as B +-- import qualified Data.ByteString as B import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils -#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Utils.Outputable as GHC import qualified Control.Monad.IO.Class as GHC -import qualified GHC as GHC hiding (parseModule) -import qualified GHC.Data.Bag as GHC -import qualified GHC.Data.FastString as GHC --- import qualified GHC.Data.StringBuffer as GHC --- import qualified GHC.Driver.Phases as GHC --- import qualified GHC.Driver.Pipeline as GHC --- import qualified GHC.Driver.Session as GHC --- import qualified GHC.Driver.Types as GHC --- import qualified GHC.Fingerprint.Type as GHC --- import qualified GHC.Utils.Fingerprint as GHC --- import qualified GHC.Parser.Lexer as GHC --- import qualified GHC.Settings as GHC -import qualified GHC.Types.SrcLoc as GHC --- import qualified GHC.Utils.Error as GHC -import qualified GHC.Utils.Outputable as GHC -import qualified GHC.Types.Name.Occurrence as OccName (occNameString) -import qualified GHC.Types.Var as GHC -import qualified GHC.Types.Name.Set as GHC -#else -import qualified ApiAnnotation as GHC -import qualified Bag as GHC -import qualified FastString as GHC -import qualified GHC as GHC hiding (parseModule) -import qualified MonadUtils as GHC -import qualified NameSet as GHC -import qualified Outputable as GHC -import qualified SrcLoc as GHC -import qualified Var as GHC - -import qualified OccName(occNameString) -#endif - - - +import qualified GHC as GHC hiding (parseModule) +-- import qualified GHC.Driver.Ppr as GHC +import qualified GHC.Hs.Dump as GHC import System.Directory import System.FilePath -#if __GLASGOW_HASKELL__ < 900 -import qualified Data.Map as Map -#endif - import Test.Common import Test.HUnit @@ -86,80 +50,67 @@ -- --------------------------------------------------------------------- -mkPrettyRoundtrip :: FilePath -> FilePath -> Test -mkPrettyRoundtrip dir fp = mkParsingTest prettyRoundtripTest dir fp +mkPrettyRoundtrip :: LibDir -> FilePath -> FilePath -> Test +mkPrettyRoundtrip libdir dir fp = mkParsingTest (prettyRoundtripTest libdir) dir fp -prettyRoundtripTest :: FilePath -> IO Report -prettyRoundtripTest origFile = do - res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile +prettyRoundtripTest :: LibDir -> FilePath -> IO Report +prettyRoundtripTest libdir origFile = do + -- res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile + res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions origFile case res of -#if __GLASGOW_HASKELL__ > 808 Left m -> return . Left $ ParseFailure (showErrorMessages m) -#else - Left (_ss, m) -> return . Left $ ParseFailure m -#endif - Right (apianns, injectedComments, _dflags, parsed) -> do - res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments) + Right (injectedComments, _dflags, parsed) -> do + res2 <- GHC.liftIO (runPrettyRoundTrip libdir origFile parsed injectedComments) case res2 of -#if __GLASGOW_HASKELL__ > 808 Left m -> return . Left $ ParseFailure (showErrorMessages m) -#else - Left (_ss, m) -> return . Left $ ParseFailure m -#endif - Right (_anns', parsed') -> do + Right parsed' -> do let - originalStructure = astStructure parsed [] - roundtripStructure = astStructure parsed' [] + originalStructure = astStructure parsed + roundtripStructure = astStructure parsed' (status,debugTxt') = if roundtripStructure == originalStructure then (Success, "ok") else (RoundTripFailure,diffText originalStructure roundtripStructure ++ sep ++ originalStructure ++ sep ++ roundtripStructure) cppStatus = Nothing - inconsistent = Nothing - !annsOrig = relativiseApiAnnsWithComments injectedComments parsed apianns debugTxt = intercalate sep [ debugTxt' , originalStructure , roundtripStructure - , showAnnData annsOrig 0 parsed + , showAst parsed ] sep = "\n=====================================\n" - return $ Right Report {debugTxt,status,cppStatus,inconsistent} + return $ Right Report {debugTxt,status,cppStatus} -- --------------------------------------------------------------------- -runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource - -> [Comment] +runPrettyRoundTrip :: LibDir -> FilePath -> GHC.ParsedSource + -> [GHC.LEpaComment] -> IO (ParseResult GHC.ParsedSource) -runPrettyRoundTrip origFile !anns !parsedOrig _cs = do - let !newAnns = addAnnotationsForPretty [] parsedOrig mempty -#if __GLASGOW_HASKELL__ >= 900 - let comments = map tokComment $ GHC.sortRealLocated (GHC.apiAnnRogueComments anns) -#else - let comments = case Map.lookup GHC.noSrcSpan (snd anns) of - Nothing -> [] - Just cl -> map tokComment $ GHC.sortLocated cl -#endif +runPrettyRoundTrip libdir origFile !parsedOrig _cs = do + -- let !newAnns = addAnnotationsForPretty [] parsedOrig mempty + let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn $ GHC.unLoc parsedOrig + -- let comments = map tokComment $ GHC.sortRealLocated priorComments + let comments = map tokComment priorComments let pragmas = filter (\(Comment c _ _) -> isPrefixOf "{-#" c ) comments let pragmaStr = intercalate "\n" $ map commentContents pragmas - let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig newAnns + let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig -- let !printed = pragmaStr ++ "\n" ++ (showSDoc_ $ GHC.ppr parsedOrig) - parseString origFile printed newAnns parsedOrig + parseString libdir origFile printed parsedOrig -parseString :: FilePath -> String -> Anns -> GHC.ParsedSource +parseString :: LibDir -> FilePath -> String -> GHC.ParsedSource -> IO (ParseResult GHC.ParsedSource) -parseString origFile src newAnns origParsed = do +parseString libdir origFile src origParsed = do tmpDir <- getTemporaryDirectory let workDir = tmpDir "ghc-exactprint" "noannotations" -- putStrLn $ "workDir=" ++ workDir createDirectoryIfMissing True workDir let fileName = workDir takeFileName origFile writeFile (workDir takeFileName origFile <.> ".anns") - (showAnnData newAnns 0 origParsed) + (showAst origParsed) writeFile fileName src - parseModule fileName + parseModule libdir fileName -- --------------------------------------------------------------------- @@ -174,81 +125,8 @@ -- |Convert an AST with comments into a string representing the structure only -- (i.e. ignoring locations), to be used for comparisons between the original -- AST and the one after pretty-print roundtripping. --- Based on @showAnnData@ -astStructure :: GHC.ParsedSource -> [Comment] -> String -astStructure parsed _cs = r +astStructure :: GHC.ParsedSource -> String +astStructure parsed = r where - r = showAstData 0 parsed - - - --- | Show a GHC AST with interleaved Annotation information. -showAstData :: Data a => Int -> a -> String -showAstData n = - generic -- `ext1Q` located - `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan - `extQ` bytestring - `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon - `extQ` overLit - `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet -#if __GLASGOW_HASKELL__ >= 900 - `extQ` layoutInfo -#endif - `extQ` fixity - `ext2Q` located - where generic :: Data a => a -> String - generic t = indent n ++ "(" ++ showConstr (toConstr t) - ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")" - space "" = "" - space s = ' ':s - indent i = "\n" ++ replicate i ' ' - string = show :: String -> String - fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String - bytestring = show :: B.ByteString -> String - list l = indent n ++ "[" - ++ intercalate "," (map (showAstData (n+1)) l) ++ "]" - - name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String - occName = ("{OccName: "++) . (++"}") . OccName.occNameString - moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String - - srcSpan :: GHC.SrcSpan -> String - srcSpan _ss = "{ "++ "ss" ++"}" - - var = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String - dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String - - overLit :: GHC.HsOverLit GhcPs -> String - overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr - - bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String - bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList - bagName :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String - bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList - bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> 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 - -#if __GLASGOW_HASKELL__ >= 900 - layoutInfo = const "{LayoutInfo: blanked }" :: GHC.LayoutInfo -> String -#endif - - located :: (Data b,Data loc) => GHC.GenLocated loc b -> String - located (GHC.L ss a) = - indent n ++ "(" - ++ case cast ss of - Just (s :: GHC.SrcSpan) -> - srcSpan s - Nothing -> "nnnnnnnn" - ++ showAstData (n+1) a - ++ ")" - --- --------------------------------------------------------------------- + r = GHC.showSDocUnsafe + $ GHC.showAstData GHC.BlankSrcSpanFile GHC.NoBlankEpAnnotations parsed diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -1,873 +1,1118 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -module Test.Transform where - -import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Parsers -import Language.Haskell.GHC.ExactPrint.Utils - -#if __GLASGOW_HASKELL__ >= 900 -import qualified GHC as GHC -import qualified GHC.Data.Bag as GHC -import qualified GHC.Data.FastString as GHC -import qualified GHC.Types.Name.Occurrence as GHC -import qualified GHC.Types.Name.Reader as GHC -import qualified GHC.Types.SrcLoc as GHC -#else -import qualified Bag as GHC -import qualified GHC as GHC -import qualified OccName as GHC -import qualified RdrName as GHC -import qualified SrcLoc as GHC -import qualified FastString as GHC -#endif - -import qualified Data.Generics as SYB - -import System.FilePath -import qualified Data.Map as Map --- import Data.List --- import Data.Maybe - -import Test.Common - -import Test.HUnit - -transformTests :: Test -transformTests = TestLabel "transformation tests" $ TestList - [ - TestLabel "Low level transformations" - (TestList transformLowLevelTests) - , TestLabel "High level transformations" - (TestList transformHighLevelTests) - ] - -transformLowLevelTests :: [Test] -transformLowLevelTests = [ - mkTestModChange changeRenameCase1 "RenameCase1.hs" - , mkTestModChange changeLayoutLet2 "LayoutLet2.hs" - , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" - , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" - , mkTestModChange changeRename1 "Rename1.hs" - , mkTestModChange changeRename2 "Rename2.hs" - , mkTestModChange changeLayoutIn1 "LayoutIn1.hs" - , mkTestModChange changeLayoutIn3 "LayoutIn3.hs" - , mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" - , mkTestModChange changeLayoutIn3 "LayoutIn3b.hs" - , mkTestModChange changeLayoutIn4 "LayoutIn4.hs" - , mkTestModChange changeLocToName "LocToName.hs" - , mkTestModChange changeLetIn1 "LetIn1.hs" - , mkTestModChange changeWhereIn4 "WhereIn4.hs" - , mkTestModChange changeAddDecl "AddDecl.hs" - , mkTestModChange changeLocalDecls "LocalDecls.hs" - , mkTestModChange changeLocalDecls2 "LocalDecls2.hs" - , mkTestModChange changeWhereIn3a "WhereIn3a.hs" --- , mkTestModChange changeCifToCase "C.hs" "C" - ] - -mkTestModChange :: Changer -> FilePath -> Test -mkTestModChange = mkTestMod "expected" "transform" - -mkTestModBad :: FilePath -> Test -mkTestModBad = mkTestMod "bad" "failing" noChange - - -mkTestMod :: String -> FilePath -> Changer -> FilePath -> Test -mkTestMod suffix dir f fp = - let basename = testPrefix dir fp - expected = basename <.> suffix - writeFailure = writeFile (basename <.> "out") - in - TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id - <$> genTest f basename expected - writeFailure (debugTxt r) - assertBool fp (status r == Success)) - - --- --------------------------------------------------------------------- - -changeWhereIn3a :: Changer -changeWhereIn3a ans (GHC.L l p) = do - let decls = GHC.hsmodDecls p - -- (GHC.L _ (GHC.SigD sig)) = head $ drop 1 decls - d1 = head $ drop 2 decls - d2 = head $ drop 3 decls - let (_p1,(ans',_),_w) = runTransform ans (balanceComments d1 d2) - let p2 = p { GHC.hsmodDecls = d2:d1:decls} - return (ans',GHC.L l p2) - --- --------------------------------------------------------------------- - --- | Add a local declaration with signature to LocalDecl, where there was no --- prior local decl. So it adds a "where" annotation. -changeLocalDecls2 :: Changer -changeLocalDecls2 ans (GHC.L l p) = do -#if __GLASGOW_HASKELL__ > 804 - Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") -#else - Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") -#endif - let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns - let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns - -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns - -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns - -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns' - let (p',(ans',_),_w) = runTransform ans doAddLocal - doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p - replaceLocalBinds :: GHC.LMatch GhcPs (GHC.LHsExpr GhcPs) - -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) -#if __GLASGOW_HASKELL__ <= 710 - replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do -#elif __GLASGOW_HASKELL__ <= 802 - replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do -#elif __GLASGOW_HASKELL__ <= 804 - replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do -#else - replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L _ GHC.EmptyLocalBinds{})))) = do -#endif - newSpan <- uniqueSrcSpanT - let - newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds") - addWhere mkds = - case Map.lookup (mkAnnKey m) mkds of - Nothing -> error "wtf" - Just ann -> Map.insert newAnnKey ann2 mkds2 - where - ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))] - , annCapturedSpan = Just newAnnKey - , annSortKey = Just [rs ls, rs ld] - } - mkds2 = Map.insert (mkAnnKey m) ann1 mkds - ann2 = annNone - { annEntryDelta = DP (1,0) } - modifyAnnsT addWhere - let decls = [s,d] - -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) - modifyAnnsT (captureOrderAnnKey newAnnKey decls) -#if __GLASGOW_HASKELL__ > 804 - let binds = (GHC.HsValBinds noExt (GHC.ValBinds noExt (GHC.listToBag $ [GHC.L ld decl]) - [GHC.L ls sig])) -#else - let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl]) - [GHC.L ls sig])) -#endif -#if __GLASGOW_HASKELL__ <= 710 - return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds))) -#elif __GLASGOW_HASKELL__ <= 802 - bindSpan <- uniqueSrcSpanT - return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L bindSpan binds)))) -#elif __GLASGOW_HASKELL__ <= 804 - bindSpan <- uniqueSrcSpanT - return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L bindSpan binds)))) -#else - bindSpan <- uniqueSrcSpanT - return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L bindSpan binds)))) -#endif - replaceLocalBinds x = return x - -- putStrLn $ "log:" ++ intercalate "\n" w - return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p') - --- --------------------------------------------------------------------- - --- | Add a local declaration with signature to LocalDecl -changeLocalDecls :: Changer -changeLocalDecls ans (GHC.L l p) = do -#if __GLASGOW_HASKELL__ > 804 - Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") -#else - Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") -#endif - let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns - let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns - -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns - -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns - -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns' - let (p',(ans',_),_w) = runTransform ans doAddLocal - doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p - replaceLocalBinds :: GHC.LMatch GhcPs (GHC.LHsExpr GhcPs) - -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) -#if __GLASGOW_HASKELL__ <= 710 - replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do -#elif __GLASGOW_HASKELL__ <= 802 - replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do -#elif __GLASGOW_HASKELL__ <= 804 - replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do -#else - replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L lb (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)))))) = do -#endif - a1 <- getAnnsT - a' <- case sigs of - [] -> return a1 - (s1:_) -> do - let a2 = setPrecedingLines s1 2 0 a1 - return a2 - putAnnsT a' - let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs - let decls = s:d:oldDecls - -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) - modifyAnnsT (captureOrder m decls) -#if __GLASGOW_HASKELL__ > 804 - let binds' = (GHC.HsValBinds noExt - (GHC.ValBinds noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) - (GHC.L ls sig:sigs))) -#else - let binds' = (GHC.HsValBinds - (GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) - (GHC.L ls sig:sigs))) -#endif -#if __GLASGOW_HASKELL__ <= 710 - return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds'))) -#elif __GLASGOW_HASKELL__ <= 802 - return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb binds')))) -#elif __GLASGOW_HASKELL__ <= 804 - return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb binds')))) -#else - return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L lb binds')))) -#endif - replaceLocalBinds x = return x - -- putStrLn $ "log:" ++ intercalate "\n" w - return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p') - --- --------------------------------------------------------------------- - --- | Add a declaration to AddDecl -changeAddDecl :: Changer -changeAddDecl ans top = do - Right (declAnns, decl) <- withDynFlags (\df -> parseDecl df "" "nn = n2") - -- putStrLn $ "changeDecl:(declAnns,decl)=" ++ showGhc (declAnns,decl) - let declAnns' = setPrecedingLines decl 2 0 declAnns - -- putStrLn $ "changeDecl:(declAnns',decl)=" ++ showGhc (declAnns',decl) - - let (p',(ans',_),_) = runTransform ans doAddDecl - doAddDecl = SYB.everywhereM (SYB.mkM replaceTopLevelDecls) top - replaceTopLevelDecls :: GHC.ParsedSource -> Transform (GHC.ParsedSource) - replaceTopLevelDecls m = insertAtStart m decl - return (mergeAnns declAnns' ans',p') - --- --------------------------------------------------------------------- - --- |Remove a decl with a trailing comment, and remove the trailing comment too -changeWhereIn3 :: Int -> Changer -changeWhereIn3 declIndex ans p = return (ans',p') - where - (p',(ans',_),_) = runTransform ans doTransform - doTransform = doRmDecl p - -#if __GLASGOW_HASKELL__ >= 900 - doRmDecl (GHC.L l (GHC.HsModule lo mmn mexp imps decls mdepr haddock)) = do -#else - doRmDecl (GHC.L l (GHC.HsModule mmn mexp imps decls mdepr haddock)) = do -#endif - let - -- declIndex = 2 -- zero based - decls1 = take declIndex decls - decls2 = drop (declIndex + 1) decls - decls' = decls1 ++ decls2 -#if __GLASGOW_HASKELL__ >= 900 - return (GHC.L l (GHC.HsModule lo mmn mexp imps decls' mdepr haddock)) -#else - return (GHC.L l (GHC.HsModule mmn mexp imps decls' mdepr haddock)) -#endif - -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2) - --- --------------------------------------------------------------------- - -changeRenameCase1 :: Changer -changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed) --- changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,17))] parsed) - -changeRenameCase2 :: Changer -changeRenameCase2 ans parsed = return (ans,rename "fooLonger" [((3,1),(3,4))] parsed) - -changeLayoutLet2 :: Changer -changeLayoutLet2 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) - -changeLocToName :: Changer -changeLocToName ans parsed = return (ans,rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed) - -changeLayoutIn3 :: Changer -changeLayoutIn3 ans parsed = return (ans,rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed) --- changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38))] parsed - -changeLayoutIn4 :: Changer -changeLayoutIn4 ans parsed = return (ans,rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed) - -changeLayoutIn1 :: Changer -changeLayoutIn1 ans parsed = return (ans,rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed) - -changeRename1 :: Changer -changeRename1 ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed) - -changeRename2 :: Changer -changeRename2 ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed) - -changeLayoutLet3 :: Changer -changeLayoutLet3 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed) - -changeLayoutLet5 :: Changer -changeLayoutLet5 ans parsed = return (ans,rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed) - --- AZ:TODO: the GHC 8 version only needs to consider Located RdrName -rename :: (SYB.Data a) => String -> [(Pos, Pos)] -> a -> a -rename newNameStr spans a - = SYB.everywhere ( SYB.mkT replaceRdr - `SYB.extT` replaceHsVar - `SYB.extT` replacePat - ) a - where - newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr) - - cond :: GHC.SrcSpan -> Bool - cond ln = ss2range ln `elem` spans - - replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName - replaceRdr (GHC.L ln _) - | cond ln = GHC.L ln newName - replaceRdr x = x - - replaceHsVar :: GHC.LHsExpr GhcPs -> GHC.LHsExpr GhcPs - replaceHsVar (GHC.L ln (GHC.HsVar{})) -#if __GLASGOW_HASKELL__ <= 710 - | cond ln = GHC.L ln (GHC.HsVar newName) -#elif __GLASGOW_HASKELL__ <= 804 - | cond ln = GHC.L ln (GHC.HsVar (GHC.L ln newName)) -#else - | cond ln = GHC.L ln (GHC.HsVar noExt (GHC.L ln newName)) -#endif - replaceHsVar x = x - - - -#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) - replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs - replacePat (GHC.dL->GHC.L ln (GHC.VarPat {})) - | cond ln = GHC.cL ln (GHC.VarPat noExt (GHC.cL ln newName)) -#elif __GLASGOW_HASKELL__ > 804 - replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs - replacePat (GHC.L ln (GHC.VarPat {})) - | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName)) -#elif __GLASGOW_HASKELL__ > 802 - replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs - replacePat (GHC.L ln (GHC.VarPat {})) - | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName)) -#elif __GLASGOW_HASKELL__ >= 800 - replacePat (GHC.L ln (GHC.VarPat {})) - | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName)) -#else - replacePat (GHC.L ln (GHC.VarPat {})) - | cond ln = GHC.L ln (GHC.VarPat newName) -#endif - replacePat x = x - - - --- #if __GLASGOW_HASKELL__ > 802 --- replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs --- #endif --- replacePat (GHC.L ln (GHC.VarPat {})) --- #if __GLASGOW_HASKELL__ <= 710 --- | cond ln = GHC.L ln (GHC.VarPat newName) --- #elif __GLASGOW_HASKELL__ <= 804 --- | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName)) --- #else --- | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName)) --- #endif --- replacePat x = x - - - --- --------------------------------------------------------------------- - -changeWhereIn4 :: Changer -changeWhereIn4 ans parsed - = return (ans,SYB.everywhere (SYB.mkT replace) parsed) - where - replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName - replace (GHC.L ln _n) - | ss2range ln == ((12,16),(12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2")) - replace x = x - --- --------------------------------------------------------------------- - -changeLetIn1 :: Changer -changeLetIn1 ans parsed - = return (ans,SYB.everywhere (SYB.mkT replace) parsed) - where - replace :: GHC.HsExpr GhcPs -> GHC.HsExpr GhcPs -#if __GLASGOW_HASKELL__ <= 710 - replace (GHC.HsLet localDecls expr@(GHC.L _ _)) -#elif __GLASGOW_HASKELL__ <= 804 - replace (GHC.HsLet (GHC.L lb localDecls) expr@(GHC.L _ _)) -#else - replace (GHC.HsLet _ (GHC.L lb localDecls) expr@(GHC.L _ _)) -#endif - = -#if __GLASGOW_HASKELL__ > 804 - let (GHC.HsValBinds x (GHC.ValBinds xv bagDecls sigs)) = localDecls - bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls -#else - let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls - bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls -#endif -#if __GLASGOW_HASKELL__ <= 710 - in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr) -#elif __GLASGOW_HASKELL__ <= 802 - in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr) -#elif __GLASGOW_HASKELL__ <= 804 - in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr) -#else - in (GHC.HsLet noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) -#endif - - replace x = x - --- --------------------------------------------------------------------- - -transformHighLevelTests :: [Test] -transformHighLevelTests = - [ - mkTestModChange addLocaLDecl1 "AddLocalDecl1.hs" - , mkTestModChange addLocaLDecl2 "AddLocalDecl2.hs" - , mkTestModChange addLocaLDecl3 "AddLocalDecl3.hs" - , mkTestModChange addLocaLDecl4 "AddLocalDecl4.hs" - , mkTestModChange addLocaLDecl5 "AddLocalDecl5.hs" - , mkTestModChange addLocaLDecl6 "AddLocalDecl6.hs" - - , mkTestModChange rmDecl1 "RmDecl1.hs" - , mkTestModChange rmDecl2 "RmDecl2.hs" - , mkTestModChange rmDecl3 "RmDecl3.hs" - , mkTestModChange rmDecl4 "RmDecl4.hs" - , mkTestModChange rmDecl5 "RmDecl5.hs" - , mkTestModChange rmDecl6 "RmDecl6.hs" - , mkTestModChange rmDecl7 "RmDecl7.hs" - - , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" - , mkTestModChange rmTypeSig2 "RmTypeSig2.hs" - - , mkTestModChange addHiding1 "AddHiding1.hs" - , mkTestModChange addHiding2 "AddHiding2.hs" - - , mkTestModChange cloneDecl1 "CloneDecl1.hs" - ] - --- --------------------------------------------------------------------- - -addLocaLDecl1 :: Changer -addLocaLDecl1 ans lp = do - Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - let declAnns' = setPrecedingLines newDecl 1 4 declAnns - doAddLocal = do - (d1:d2:_) <- hsDecls lp - balanceComments d1 d2 - (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m d -> do - return ((newDecl : d),Nothing) - replaceDecls lp [d1', d2] - - (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal - -- putStrLn $ "log:\n" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -addLocaLDecl2 :: Changer -addLocaLDecl2 ans lp = do - Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - let - doAddLocal = do - tlDecs <- hsDecls lp - let parent = head tlDecs - balanceComments parent (head $ tail tlDecs) - - (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do - transferEntryDPT (head decls) newDecl - setEntryDPT (head decls) (DP (1, 0)) - return ((newDecl:decls),Nothing) - - replaceDecls lp (parent':tail tlDecs) - - let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal - -- putStrLn $ "log:\n" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -addLocaLDecl3 :: Changer -addLocaLDecl3 ans lp = do - Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - let - doAddLocal = do - -- logDataWithAnnsTr "parsed:" lp - logDataWithAnnsTr "newDecl:" newDecl - tlDecs <- hsDecls lp - let parent = head tlDecs - balanceComments parent (head $ tail tlDecs) - - (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \m decls -> do - setPrecedingLinesT newDecl 1 0 - moveTrailingComments m (last decls) - return ((decls++[newDecl]),Nothing) - - replaceDecls lp (parent':tail tlDecs) - - let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal - -- putStrLn $ "log\n" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -addLocaLDecl4 :: Changer -addLocaLDecl4 ans lp = do - Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") - Right (sigAnns, newSig) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") - -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp - let - doAddLocal = do - tlDecs <- hsDecls lp - let parent = head tlDecs - - setPrecedingLinesT newSig 1 0 - setPrecedingLinesT newDecl 1 0 - - (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do - return ((decls++[newSig,newDecl]),Nothing) - - replaceDecls lp (parent':tail tlDecs) - - let (lp',(ans',_),_w) = runTransform (mergeAnnList [ans,declAnns,sigAnns]) doAddLocal - -- putStrLn $ "log\n" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -addLocaLDecl5 :: Changer -addLocaLDecl5 ans lp = do - let - doAddLocal = do - [s1,d1,d2,d3] <- hsDecls lp - - transferEntryDPT d2 d3 - - (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m _decls -> do - return ([d2],Nothing) - replaceDecls lp [s1,d1',d3] - - (lp',(ans',_),_w) <- runTransformT ans doAddLocal - -- putStrLn $ "log\n" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -addLocaLDecl6 :: Changer -addLocaLDecl6 ans lp = do - Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "x = 3") - let declAnns' = setPrecedingLines newDecl 1 4 declAnns - doAddLocal = do - [d1,d2] <- hsDecls lp - balanceComments d1 d2 - -#if __GLASGOW_HASKELL__ >= 900 - let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _)) = d1 -#elif __GLASGOW_HASKELL__ > 808 - let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1 -#elif __GLASGOW_HASKELL__ > 804 - let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1 -#elif __GLASGOW_HASKELL__ > 710 - let GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ [m1,m2]) _ _ _) _ _ _)) = d1 -#else - let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1 -#endif - balanceComments m1 m2 - - (d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do - return ((newDecl : decls),Nothing) - replaceDecls lp [d1', d2] - - (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal - -- putStrLn $ "log:\n" ++ intercalate "\n" _w - return (ans',lp') --- --------------------------------------------------------------------- - -rmDecl1 :: Changer -rmDecl1 ans lp = do - let doRmDecl = do - tlDecs <- hsDecls lp - let (d1:s1:d2:ds) = tlDecs - - -- First delete the decl (d2) only - balanceComments s1 d2 -- ++AZ++ - balanceComments d2 (head ds) - lp1 <- replaceDecls lp (d1:s1:ds) - -- return lp1 - - -- Then delete the sig separately - tlDecs1 <- hsDecls lp1 - let (d1':s1':ds') = tlDecs1 - -- transferEntryDPT s1' (head ds') -- required in HaRe. - balanceComments d1' s1' - balanceComments s1' (head ds') - transferEntryDPT s1' (head ds') -- required in HaRe. - replaceDecls lp (d1':ds') - - (lp',(ans',_),_w) <- runTransformT ans doRmDecl - return (ans',lp') - --- --------------------------------------------------------------------- - -rmDecl2 :: Changer -rmDecl2 ans lp = do - let - doRmDecl = do - let - go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs) - go e@(GHC.L _ (GHC.HsLet{})) = do - decs <- hsDecls e - e' <- replaceDecls e (init decs) - return e' - go x = return x - - SYB.everywhereM (SYB.mkM go) lp - - let (lp',(ans',_),_w) = runTransform ans doRmDecl - -- putStrLn $ "log:\n" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -rmDecl3 :: Changer -rmDecl3 ans lp = do - let - doRmDecl = do - [d1,d2] <- hsDecls lp - - (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1] -> do - setPrecedingLinesDeclT sd1 2 0 - return ([],Just sd1) - - replaceDecls lp [d1',sd1,d2] - - (lp',(ans',_),_w) <- runTransformT ans doRmDecl - -- putStrLn $ "log:\n" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -rmDecl4 :: Changer -rmDecl4 ans lp = do - let - doRmDecl = do - [d1] <- hsDecls lp - - (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1,sd2] -> do - -- [sd1,sd2] <- hsDecls d1 - transferEntryDPT sd1 sd2 - - setPrecedingLinesDeclT sd1 2 0 - -- d1' <- replaceDecls d1 [sd2] - return ([sd2],Just sd1) - - replaceDecls lp [d1',sd1] - - (lp',(ans',_),_w) <- runTransformT ans doRmDecl - return (ans',lp') - --- --------------------------------------------------------------------- - -rmDecl5 :: Changer -rmDecl5 ans lp = do - let - doRmDecl = do - let - go :: GHC.HsExpr GhcPs -> Transform (GHC.HsExpr GhcPs) -#if __GLASGOW_HASKELL__ <= 710 - go (GHC.HsLet lb expr) = do -#elif __GLASGOW_HASKELL__ <= 804 - go (GHC.HsLet (GHC.L l lb) expr) = do -#else - go (GHC.HsLet _ (GHC.L l lb) expr) = do -#endif - decs <- hsDeclsValBinds lb - let dec = last decs - transferEntryDPT (head decs) dec - lb' <- replaceDeclsValbinds lb [dec] -#if __GLASGOW_HASKELL__ <= 710 - return (GHC.HsLet lb' expr) -#elif __GLASGOW_HASKELL__ <= 804 - return (GHC.HsLet (GHC.L l lb') expr) -#else - return (GHC.HsLet noExt (GHC.L l lb') expr) -#endif - go x = return x - - SYB.everywhereM (SYB.mkM go) lp - - let (lp',(ans',_),_w) = runTransform ans doRmDecl - -- putStrLn $ "log:" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -rmDecl6 :: Changer -rmDecl6 ans lp = do - let - doRmDecl = do - [d1] <- hsDecls lp - - (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m subDecs -> do - let (ss1:_sd1:sd2:sds) = subDecs - transferEntryDPT ss1 sd2 - - return (sd2:sds,Nothing) - - replaceDecls lp [d1'] - - (lp',(ans',_),_w) <- runTransformT ans doRmDecl - -- putStrLn $ "log:" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -rmDecl7 :: Changer -rmDecl7 ans lp = do - let - doRmDecl = do - tlDecs <- hsDecls lp - let [s1,d1,d2,d3] = tlDecs - - balanceComments d1 d2 - balanceComments d2 d3 - - transferEntryDPT d2 d3 - - replaceDecls lp [s1,d1,d3] - - let (lp',(ans',_),_w) = runTransform ans doRmDecl - -- putStrLn $ "log:" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -rmTypeSig1 :: Changer -rmTypeSig1 ans lp = do - let doRmDecl = do - tlDecs <- hsDecls lp - let (s1:d1:d2) = tlDecs -#if __GLASGOW_HASKELL__ <= 710 - (GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1 - s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p))) -#elif __GLASGOW_HASKELL__ <= 804 - (GHC.L l (GHC.SigD (GHC.TypeSig names typ))) = s1 - s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ))) -#else - (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 names typ))) = s1 - s1' = (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 (tail names) typ))) -#endif - replaceDecls lp (s1':d1:d2) - - let (lp',(ans',_),_w) = runTransform ans doRmDecl - return (ans',lp') - --- --------------------------------------------------------------------- - -rmTypeSig2 :: Changer -rmTypeSig2 ans lp = do - let doRmDecl = do - tlDecs <- hsDecls lp - let [d1] = tlDecs - - (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m [s,d] -> do - transferEntryDPT s d - return ([d],Nothing) - replaceDecls lp [d1'] - - let (lp',(ans',_),_w) = runTransform ans doRmDecl - -- putStrLn $ "log:" ++ intercalate "\n" _w - return (ans',lp') - --- --------------------------------------------------------------------- - -addHiding1 :: Changer -addHiding1 ans (GHC.L l p) = do - let doTransform = do - l0 <- uniqueSrcSpanT - l1 <- uniqueSrcSpanT - l2 <- uniqueSrcSpanT - let - [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__ > 804 - v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) - v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) -#elif __GLASGOW_HASKELL__ > 800 - v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) - v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) -#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]} - addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] - addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] - addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] - addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] - return (GHC.L l p') - - let (lp',(ans',_),_w) = runTransform ans doTransform - return (ans',lp') - --- --------------------------------------------------------------------- - -addHiding2 :: Changer -addHiding2 ans (GHC.L l p) = do - let doTransform = do - l1 <- uniqueSrcSpanT - l2 <- uniqueSrcSpanT - let - [GHC.L li imp1] = GHC.hsmodImports p - 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__ > 804 - v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) - v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) -#elif __GLASGOW_HASKELL__ > 800 - v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) - v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) -#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))] - addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] - addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] - addTrailingCommaT (last ns) - return (GHC.L l p') - - let (lp',(ans',_),_w) = runTransform ans doTransform - return (ans',lp') - --- --------------------------------------------------------------------- - -cloneDecl1 :: Changer -cloneDecl1 ans lp = do - let doChange = do - tlDecs <- hsDecls lp - let (d1:d2:ds) = tlDecs - d2' <- fst <$> cloneT d2 - replaceDecls lp (d1:d2:d2':ds) - - let (lp',(ans',_),_w) = runTransform ans doChange - return (ans',lp') +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +module Test.Transform where + +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint.Utils + +import GHC as GHC +import GHC.Data.Bag as GHC +import GHC.Data.FastString as GHC +import GHC.Types.Name.Occurrence as GHC +import GHC.Types.Name.Reader as GHC + +import Data.Generics as SYB + +import System.FilePath +import Data.List + +import Test.Common + +import Test.HUnit + +transformTestsTT :: LibDir -> Test +transformTestsTT libdir = TestLabel "transformTestsTT" $ TestList + [ + mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" + ] + +transformTests :: LibDir -> Test +transformTests libdir = TestLabel "transformation tests" $ TestList + [ + TestLabel "Low level transformations" + (TestList (transformLowLevelTests libdir)) + , TestLabel "High level transformations" + (TestList (transformHighLevelTests libdir)) + ] + +transformLowLevelTests :: LibDir -> [Test] +transformLowLevelTests libdir = [ + mkTestModChange libdir changeRenameCase1 "RenameCase1.hs" + , mkTestModChange libdir changeLayoutLet2 "LayoutLet2.hs" + , mkTestModChange libdir changeLayoutLet3 "LayoutLet3.hs" + , mkTestModChange libdir changeLayoutLet3 "LayoutLet4.hs" + , mkTestModChange libdir changeRename1 "Rename1.hs" + , mkTestModChange libdir changeRename2 "Rename2.hs" + , mkTestModChange libdir changeLayoutIn1 "LayoutIn1.hs" + , mkTestModChange libdir changeLayoutIn3 "LayoutIn3.hs" + , mkTestModChange libdir changeLayoutIn3 "LayoutIn3a.hs" + , mkTestModChange libdir changeLayoutIn3 "LayoutIn3b.hs" + , mkTestModChange libdir changeLayoutIn4 "LayoutIn4.hs" + , mkTestModChange libdir changeLocToName "LocToName.hs" + , mkTestModChange libdir changeLetIn1 "LetIn1.hs" + , mkTestModChange libdir changeWhereIn4 "WhereIn4.hs" + , mkTestModChange libdir changeAddDecl "AddDecl.hs" + , mkTestModChange libdir changeLocalDecls "LocalDecls.hs" + , mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs" + , mkTestModChange libdir changeWhereIn3a "WhereIn3a.hs" +-- , mkTestModChange changeCifToCase "C.hs" "C" + ] + +mkTestModChange :: LibDir -> Changer -> FilePath -> Test +mkTestModChange libdir f file = mkTestMod libdir "expected" "transform" f file + +mkTestModBad :: LibDir -> FilePath -> Test +mkTestModBad libdir file + = mkTestMod libdir "bad" "failing" noChange file + + +mkTestMod :: LibDir -> String -> FilePath -> Changer -> FilePath -> Test +mkTestMod libdir suffix dir f fp = + let basename = testPrefix dir fp + expected = basename <.> suffix + writeFailure = writeFile (basename <.> "out") + in + TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id + <$> genTest libdir f basename expected + writeFailure (debugTxt r) + assertBool fp (status r == Success)) + + +-- --------------------------------------------------------------------- + +-- changeWhereIn3a :: Changer +-- changeWhereIn3a ans (GHC.L l p) = do +-- let decls = GHC.hsmodDecls p +-- -- (GHC.L _ (GHC.SigD sig)) = head $ drop 1 decls +-- d1 = head $ drop 2 decls +-- d2 = head $ drop 3 decls +-- let (_p1,(ans',_),_w) = runTransform ans (balanceComments d1 d2) +-- let p2 = p { GHC.hsmodDecls = d2:d1:decls} +-- return (ans',GHC.L l p2) + +-- | Check that balanceCommentsList is idempotent +changeWhereIn3a :: Changer +changeWhereIn3a _libdir (L l p) = do + let decls0 = hsmodDecls p + (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0) + (_de0:_:de1:_d2:_) = decls + debugM $ unlines w + debugM $ "changeWhereIn3a:de1:" ++ showAst de1 + let p2 = p { hsmodDecls = decls} + return (L l p2) + +-- --------------------------------------------------------------------- + +changeWhereIn3b :: Changer +changeWhereIn3b _libdir (L l p) = do + let decls0 = hsmodDecls p + (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0) + (de0:_:de1:d2:_) = decls + de0' = setEntryDP' de0 (DifferentLine 2 0) + de1' = setEntryDP' de1 (DifferentLine 2 0) + d2' = setEntryDP' d2 (DifferentLine 2 0) + decls' = d2':de1':de0':(tail decls) + debugM $ unlines w + debugM $ "changeWhereIn3b:de1':" ++ showAst de1' + let p2 = p { hsmodDecls = decls'} + return (L l p2) + +-- --------------------------------------------------------------------- + +-- -- | Add a local declaration with signature to LocalDecl, where there was no +-- -- prior local decl. So it adds a "where" annotation. +-- changeLocalDecls2 :: Changer +-- changeLocalDecls2 ans (GHC.L l p) = do +-- Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") +-- Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") +-- let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns +-- let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns +-- -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns +-- -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns +-- -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns' +-- let (p',(ans',_),_w) = runTransform ans doAddLocal +-- doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p +-- replaceLocalBinds :: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) +-- -> Transform (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) +-- replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L _ GHC.EmptyLocalBinds{})))) = do +-- newSpan <- uniqueSrcSpanT +-- let +-- newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds") +-- addWhere mkds = +-- case Map.lookup (mkAnnKey m) mkds of +-- Nothing -> error "wtf" +-- Just ann -> Map.insert newAnnKey ann2 mkds2 +-- where +-- ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))] +-- , annCapturedSpan = Just newAnnKey +-- , annSortKey = Just [rs ls, rs ld] +-- } +-- mkds2 = Map.insert (mkAnnKey m) ann1 mkds +-- ann2 = annNone +-- { annEntryDelta = DP (1,0) } +-- modifyAnnsT addWhere +-- let decls = [s,d] +-- -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) +-- modifyAnnsT (captureOrderAnnKey newAnnKey decls) +-- let binds = (GHC.HsValBinds noExt (GHC.ValBinds noExt (GHC.listToBag $ [GHC.L ld decl]) +-- [GHC.L ls sig])) +-- bindSpan <- uniqueSrcSpanT +-- return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L bindSpan binds)))) +-- replaceLocalBinds x = return x +-- -- putStrLn $ "log:" ++ intercalate "\n" w +-- return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p') + + +-- | Add a local declaration with signature to LocalDecl, where there was no +-- prior local decl. So it adds a "where" annotation. +changeLocalDecls2 :: Changer +changeLocalDecls2 libdir (L l p) = do + Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0) + let sig' = setEntryDP' (L ls sig) (SameLine 2) + let (p',(_,_),_w) = runTransform mempty doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) p + replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) + -> Transform (LMatch GhcPs (LHsExpr GhcPs)) + replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do + newSpan <- uniqueSrcSpanT + let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3))) + let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5))) + let an = EpAnn anc + (AnnList (Just anc2) Nothing Nothing + [(undeltaSpan (rs newSpan) AnnWhere (SameLine 0))] []) + emptyComments + let decls = [s,d] + let sortKey = captureOrder decls + let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl']) + [sig'])) + return (L lm (Match ma mln pats (GRHSs noExtField rhs binds))) + replaceLocalBinds x = return x + return (L l p') + +-- --------------------------------------------------------------------- + +-- -- | Add a local declaration with signature to LocalDecl +-- changeLocalDecls :: Changer +-- changeLocalDecls ans (GHC.L l p) = do +-- Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") +-- Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") +-- let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns +-- let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns +-- -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns +-- -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns +-- -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns' +-- let (p',(ans',_),_w) = runTransform ans doAddLocal +-- doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p +-- replaceLocalBinds :: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) +-- -> Transform (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) +-- replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L lb (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)))))) = do +-- a1 <- getAnnsT +-- a' <- case sigs of +-- [] -> return a1 +-- (s1:_) -> do +-- let a2 = setPrecedingLines s1 2 0 a1 +-- return a2 +-- putAnnsT a' +-- let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs +-- let decls = s:d:oldDecls +-- -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) +-- modifyAnnsT (captureOrder m decls) +-- let binds' = (GHC.HsValBinds noExt +-- (GHC.ValBinds noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) +-- (GHC.L ls sig:sigs))) +-- return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L lb binds')))) +-- replaceLocalBinds x = return x +-- -- putStrLn $ "log:" ++ intercalate "\n" w +-- return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p') + + +-- | Add a local declaration with signature to LocalDecl +changeLocalDecls :: Changer +changeLocalDecls libdir (L l p) = do + Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0) + let sig' = setEntryDP' (L ls sig) (SameLine 0) + let (p',(_,_),_w) = runTransform mempty doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) p + replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) + -> Transform (LMatch GhcPs (LHsExpr GhcPs)) + replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do + let oldDecls = sortLocatedA $ map wrapDecl (bagToList binds) ++ map wrapSig sigs + let decls = s:d:oldDecls + let oldDecls' = captureLineSpacing oldDecls + let oldBinds = concatMap decl2Bind oldDecls' + (os:oldSigs) = concatMap decl2Sig oldDecls' + os' = setEntryDP' os (DifferentLine 2 0) + let sortKey = captureOrder decls + let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van + let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs) + let binds' = (HsValBinds van' + (ValBinds sortKey + (listToBag $ decl':oldBinds) + (sig':os':oldSigs))) + return (L lm (Match an mln pats (GRHSs noExtField rhs binds'))) + replaceLocalBinds x = return x + return (L l p') + +-- --------------------------------------------------------------------- + +-- | Add a declaration to AddDecl +-- changeAddDecl :: Changer +-- changeAddDecl ans top = do +-- Right (declAnns, decl) <- withDynFlags (\df -> parseDecl df "" "nn = n2") +-- -- putStrLn $ "changeDecl:(declAnns,decl)=" ++ showGhc (declAnns,decl) +-- let declAnns' = setPrecedingLines decl 2 0 declAnns +-- -- putStrLn $ "changeDecl:(declAnns',decl)=" ++ showGhc (declAnns',decl) + +-- let (p',(ans',_),_) = runTransform ans doAddDecl +-- doAddDecl = SYB.everywhereM (SYB.mkM replaceTopLevelDecls) top +-- replaceTopLevelDecls :: GHC.ParsedSource -> Transform (GHC.ParsedSource) +-- replaceTopLevelDecls m = insertAtStart m decl +-- return (mergeAnns declAnns' ans',p') + +-- | Add a declaration to AddDecl +changeAddDecl :: Changer +changeAddDecl libdir top = do + Right decl <- withDynFlags libdir (\df -> parseDecl df "" "nn = n2") + let decl' = setEntryDP' decl (DifferentLine 2 0) + + let (p',(_,_),_) = runTransform mempty doAddDecl + doAddDecl = everywhereM (mkM replaceTopLevelDecls) top + replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource + replaceTopLevelDecls m = insertAtStart m decl' + return p' +-- --------------------------------------------------------------------- + +-- -- |Remove a decl with a trailing comment, and remove the trailing comment too +-- changeWhereIn3 :: Int -> Changer +-- changeWhereIn3 declIndex ans p = return (ans',p') +-- where +-- (p',(ans',_),_) = runTransform ans doTransform +-- doTransform = doRmDecl p + +-- doRmDecl (GHC.L l (GHC.HsModule lo mmn mexp imps decls mdepr haddock)) = do +-- let +-- -- declIndex = 2 -- zero based +-- decls1 = take declIndex decls +-- decls2 = drop (declIndex + 1) decls +-- decls' = decls1 ++ decls2 +-- return (GHC.L l (GHC.HsModule lo mmn mexp imps decls' mdepr haddock)) +-- -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2) + +-- --------------------------------------------------------------------- + +changeRenameCase1 :: Changer +changeRenameCase1 _libdir parsed = return (rename "bazLonger" [((3,15),(3,18))] parsed) + +changeRenameCase2 :: Changer +changeRenameCase2 _libdir parsed = return (rename "fooLonger" [((3,1),(3,4))] parsed) + +changeLayoutLet2 :: Changer +changeLayoutLet2 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) + +changeLocToName :: Changer +changeLocToName _libdir parsed = return (rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed) + +changeLayoutIn3 :: Changer +changeLayoutIn3 _libdir parsed = return (rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed) +-- changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38))] parsed + +changeLayoutIn4 :: Changer +changeLayoutIn4 _libdir parsed = return (rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed) + +changeLayoutIn1 :: Changer +changeLayoutIn1 _libdir parsed = return (rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed) + +changeRename1 :: Changer +changeRename1 _libdir parsed = return (rename "bar2" [((3,1),(3,4))] parsed) + +changeRename2 :: Changer +changeRename2 _libdir parsed = return (rename "joe" [((2,1),(2,5))] parsed) + +changeLayoutLet3 :: Changer +changeLayoutLet3 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed) + +changeLayoutLet5 :: Changer +changeLayoutLet5 _libdir parsed = return (rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed) + + +rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a +rename newNameStr spans' a + = everywhere (mkT replaceRdr) a + where + newName = mkRdrUnqual (mkVarOcc newNameStr) + + cond :: SrcSpan -> Bool + cond ln = ss2range ln `elem` spans' + + replaceRdr :: LocatedN RdrName -> LocatedN RdrName + replaceRdr (L ln _) + | cond (locA ln) = L ln newName + replaceRdr x = x + + +-- --------------------------------------------------------------------- + +-- changeWhereIn4 :: Changer +-- changeWhereIn4 ans parsed +-- = return (ans,SYB.everywhere (SYB.mkT replace) parsed) +-- where +-- replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName +-- replace (GHC.L ln _n) +-- | ss2range ln == ((12,16),(12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2")) +-- replace x = x + +changeWhereIn4 :: Changer +changeWhereIn4 _libdir parsed + = return (everywhere (mkT replace) parsed) + where + replace :: LocatedN RdrName -> LocatedN RdrName + replace (L ln _n) + | ss2range (locA ln) == ((12,16),(12,17)) = L ln (mkRdrUnqual (mkVarOcc "p_2")) + replace x = x +-- --------------------------------------------------------------------- + +-- changeLetIn1 :: Changer +-- changeLetIn1 ans parsed +-- = return (ans,SYB.everywhere (SYB.mkT replace) parsed) +-- where +-- replace :: GHC.HsExpr GHC.GhcPs -> GHC.HsExpr GHC.GhcPs +-- replace (GHC.HsLet _ (GHC.L lb localDecls) expr@(GHC.L _ _)) +-- = +-- let (GHC.HsValBinds x (GHC.ValBinds xv bagDecls sigs)) = localDecls +-- bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls +-- in (GHC.HsLet noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) + +-- replace x = x + +changeLetIn1 :: Changer +changeLetIn1 _libdir parsed + = return (everywhere (mkT replace) parsed) + where + replace :: HsExpr GhcPs -> HsExpr GhcPs + replace (HsLet (EpAnn anc (AnnsLet l _i) cs) localDecls expr) + = + let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls + [l2,_l1] = map wrapDecl $ bagToList bagDecls + bagDecls' = listToBag $ concatMap decl2Bind [l2] + (L (SrcSpanAnn _ le) e) = expr + a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) mempty emptyComments) le) + expr' = L a e + in (HsLet (EpAnn anc (AnnsLet l (EpaDelta (DifferentLine 1 0))) cs) + (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') + + replace x = x + +-- --------------------------------------------------------------------- + +transformHighLevelTests :: LibDir -> [Test] +transformHighLevelTests libdir = + [ + mkTestModChange libdir addLocaLDecl1 "AddLocalDecl1.hs" + , mkTestModChange libdir addLocaLDecl2 "AddLocalDecl2.hs" + , mkTestModChange libdir addLocaLDecl3 "AddLocalDecl3.hs" + , mkTestModChange libdir addLocaLDecl4 "AddLocalDecl4.hs" + , mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" + , mkTestModChange libdir addLocaLDecl6 "AddLocalDecl6.hs" + + , mkTestModChange libdir rmDecl1 "RmDecl1.hs" + , mkTestModChange libdir rmDecl2 "RmDecl2.hs" + , mkTestModChange libdir rmDecl3 "RmDecl3.hs" + , mkTestModChange libdir rmDecl4 "RmDecl4.hs" + , mkTestModChange libdir rmDecl5 "RmDecl5.hs" + , mkTestModChange libdir rmDecl6 "RmDecl6.hs" + , mkTestModChange libdir rmDecl7 "RmDecl7.hs" + + , mkTestModChange libdir rmTypeSig1 "RmTypeSig1.hs" + , mkTestModChange libdir rmTypeSig2 "RmTypeSig2.hs" + + , mkTestModChange libdir addHiding1 "AddHiding1.hs" + , mkTestModChange libdir addHiding2 "AddHiding2.hs" + + , mkTestModChange libdir cloneDecl1 "CloneDecl1.hs" + ] + +-- --------------------------------------------------------------------- + +-- addLocaLDecl1 :: Changer +-- addLocaLDecl1 ans lp = do +-- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") +-- let declAnns' = setPrecedingLines newDecl 1 4 declAnns +-- doAddLocal = do +-- (d1:d2:_) <- hsDecls lp +-- balanceComments d1 d2 +-- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m d -> do +-- return ((newDecl : d),Nothing) +-- replaceDecls lp [d1', d2] + +-- (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal +-- -- putStrLn $ "log:\n" ++ intercalate "\n" _w +-- return (ans',lp') + +addLocaLDecl1 :: Changer +addLocaLDecl1 libdir lp = do + Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + let decl' = setEntryDP' (L ld decl) (DifferentLine 1 5) + doAddLocal = do + (de1:d2:d3:_) <- hsDecls lp + (de1'',d2') <- balanceComments de1 d2 + (de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do + return ((wrapDecl decl' : d),Nothing) + replaceDecls lp [de1', d2', d3] + + (lp',(_,_),w) <- runTransformT mempty doAddLocal + debugM $ "addLocaLDecl1:" ++ intercalate "\n" w + return lp' +-- --------------------------------------------------------------------- + +-- addLocaLDecl2 :: Changer +-- addLocaLDecl2 ans lp = do +-- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") +-- let +-- doAddLocal = do +-- tlDecs <- hsDecls lp +-- let parent = head tlDecs +-- balanceComments parent (head $ tail tlDecs) + +-- (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do +-- transferEntryDPT (head decls) newDecl +-- setEntryDPT (head decls) (DP (1, 0)) +-- return ((newDecl:decls),Nothing) + +-- replaceDecls lp (parent':tail tlDecs) + +-- let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal +-- -- putStrLn $ "log:\n" ++ intercalate "\n" _w +-- return (ans',lp') + +addLocaLDecl2 :: Changer +addLocaLDecl2 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + let + doAddLocal = do + (de1:d2:_) <- hsDecls lp + (de1'',d2') <- balanceComments de1 d2 + + (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do + newDecl' <- transferEntryDP' d newDecl + let d' = setEntryDP' d (DifferentLine 1 0) + return ((newDecl':d':ds),Nothing) + + replaceDecls lp [parent',d2'] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- addLocaLDecl3 :: Changer +-- addLocaLDecl3 ans lp = do +-- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") +-- let +-- doAddLocal = do +-- -- logDataWithAnnsTr "parsed:" lp +-- logDataWithAnnsTr "newDecl:" newDecl +-- tlDecs <- hsDecls lp +-- let parent = head tlDecs +-- balanceComments parent (head $ tail tlDecs) + +-- (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \m decls -> do +-- setPrecedingLinesT newDecl 1 0 +-- moveTrailingComments m (last decls) +-- return ((decls++[newDecl]),Nothing) + +-- replaceDecls lp (parent':tail tlDecs) + +-- let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal +-- -- putStrLn $ "log\n" ++ intercalate "\n" _w +-- return (ans',lp') + +addLocaLDecl3 :: Changer +addLocaLDecl3 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + let + doAddLocal = do + (de1:d2:_) <- hsDecls lp + (de1'',d2') <- balanceComments de1 d2 + + (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do + let newDecl' = setEntryDP' newDecl (DifferentLine 1 0) + return (((d:ds) ++ [newDecl']),Nothing) + + replaceDecls (anchorEof lp) [parent',d2'] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- addLocaLDecl4 :: Changer +-- addLocaLDecl4 ans lp = do +-- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") +-- Right (sigAnns, newSig) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") +-- -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp +-- let +-- doAddLocal = do +-- tlDecs <- hsDecls lp +-- let parent = head tlDecs + +-- setPrecedingLinesT newSig 1 0 +-- setPrecedingLinesT newDecl 1 0 + +-- (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do +-- return ((decls++[newSig,newDecl]),Nothing) + +-- replaceDecls lp (parent':tail tlDecs) + +-- let (lp',(ans',_),_w) = runTransform (mergeAnnList [ans,declAnns,sigAnns]) doAddLocal +-- -- putStrLn $ "log\n" ++ intercalate "\n" _w +-- return (ans',lp') + + +addLocaLDecl4 :: Changer +addLocaLDecl4 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + let + doAddLocal = do + (parent:ds) <- hsDecls lp + + let newDecl' = setEntryDP' newDecl (DifferentLine 1 0) + let newSig' = setEntryDP' newSig (DifferentLine 1 5) + + (parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do + return ((decls++[newSig',newDecl']),Nothing) + + replaceDecls (anchorEof lp) (parent':ds) + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- addLocaLDecl5 :: Changer +-- addLocaLDecl5 ans lp = do +-- let +-- doAddLocal = do +-- [s1,d1,d2,d3] <- hsDecls lp + +-- transferEntryDPT d2 d3 + +-- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m _decls -> do +-- return ([d2],Nothing) +-- replaceDecls lp [s1,d1',d3] + +-- (lp',(ans',_),_w) <- runTransformT ans doAddLocal +-- -- putStrLn $ "log\n" ++ intercalate "\n" _w +-- return (ans',lp') + +addLocaLDecl5 :: Changer +addLocaLDecl5 _libdir lp = do + let + doAddLocal = do + decls <- hsDecls lp + [s1,de1,d2,d3] <- balanceCommentsList decls + + let d3' = setEntryDP' d3 (DifferentLine 2 0) + + (de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do + let d2' = setEntryDP' d2 (DifferentLine 1 0) + return ([d2'],Nothing) + replaceDecls lp [s1,de1',d3'] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- addLocaLDecl6 :: Changer +-- addLocaLDecl6 ans lp = do +-- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "x = 3") +-- let declAnns' = setPrecedingLines newDecl 1 4 declAnns +-- doAddLocal = do +-- [d1,d2] <- hsDecls lp +-- balanceComments d1 d2 + +-- let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _)) = d1 +-- balanceComments m1 m2 + +-- (d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do +-- return ((newDecl : decls),Nothing) +-- replaceDecls lp [d1', d2] + +-- (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal +-- -- putStrLn $ "log:\n" ++ intercalate "\n" _w +-- return (ans',lp') + + +addLocaLDecl6 :: Changer +addLocaLDecl6 libdir lp = do + Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") + let + newDecl' = setEntryDP' newDecl (DifferentLine 1 5) + doAddLocal = do + decls0 <- hsDecls lp + [de1'',d2] <- balanceCommentsList decls0 + + let de1 = captureMatchLineSpacing de1'' + let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms) _) _)) = de1 + let [ma1,_ma2] = ms + + (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do + return ((newDecl' : decls),Nothing) + replaceDecls lp [de1', d2] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +-- rmDecl1 :: Changer +-- rmDecl1 ans lp = do +-- let doRmDecl = do +-- tlDecs <- hsDecls lp +-- let (d1:s1:d2:ds) = tlDecs + +-- -- First delete the decl (d2) only +-- balanceComments s1 d2 -- ++AZ++ +-- balanceComments d2 (head ds) +-- lp1 <- replaceDecls lp (d1:s1:ds) +-- -- return lp1 + +-- -- Then delete the sig separately +-- tlDecs1 <- hsDecls lp1 +-- let (d1':s1':ds') = tlDecs1 +-- -- transferEntryDPT s1' (head ds') -- required in HaRe. +-- balanceComments d1' s1' +-- balanceComments s1' (head ds') +-- transferEntryDPT s1' (head ds') -- required in HaRe. +-- replaceDecls lp (d1':ds') + +-- (lp',(ans',_),_w) <- runTransformT ans doRmDecl +-- return (ans',lp') + +rmDecl1 :: Changer +rmDecl1 _libdir lp = do + let doRmDecl = do + tlDecs0 <- hsDecls lp + tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0 + let (de1:_s1:_d2:ds) = tlDecs + + replaceDecls lp (de1:ds) + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- rmDecl2 :: Changer +-- rmDecl2 ans lp = do +-- let +-- doRmDecl = do +-- let +-- go :: GHC.LHsExpr GHC.GhcPs -> Transform (GHC.LHsExpr GHC.GhcPs) +-- go e@(GHC.L _ (GHC.HsLet{})) = do +-- decs <- hsDecls e +-- e' <- replaceDecls e (init decs) +-- return e' +-- go x = return x + +-- SYB.everywhereM (SYB.mkM go) lp + +-- let (lp',(ans',_),_w) = runTransform ans doRmDecl +-- -- putStrLn $ "log:\n" ++ intercalate "\n" _w +-- return (ans',lp') + +rmDecl2 :: Changer +rmDecl2 _libdir lp = do + let + doRmDecl = do + let + go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs) + go e@(GHC.L _ (GHC.HsLet{})) = do + decs0 <- hsDecls e + decs <- balanceCommentsList $ captureLineSpacing decs0 + e' <- replaceDecls e (init decs) + return e' + go x = return x + + everywhereM (mkM go) lp + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +-- rmDecl3 :: Changer +-- rmDecl3 ans lp = do +-- let +-- doRmDecl = do +-- [d1,d2] <- hsDecls lp + +-- (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1] -> do +-- setPrecedingLinesDeclT sd1 2 0 +-- return ([],Just sd1) + +-- replaceDecls lp [d1',sd1,d2] + +-- (lp',(ans',_),_w) <- runTransformT ans doRmDecl +-- -- putStrLn $ "log:\n" ++ intercalate "\n" _w +-- return (ans',lp') + +rmDecl3 :: Changer +rmDecl3 _libdir lp = do + let + doRmDecl = do + [de1,d2] <- hsDecls lp + + (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do + let sd1' = setEntryDP' sd1 (DifferentLine 2 0) + return ([],Just sd1') + + replaceDecls lp [de1',sd1,d2] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +-- rmDecl4 :: Changer +-- rmDecl4 ans lp = do +-- let +-- doRmDecl = do +-- [d1] <- hsDecls lp + +-- (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1,sd2] -> do +-- -- [sd1,sd2] <- hsDecls d1 +-- transferEntryDPT sd1 sd2 + +-- setPrecedingLinesDeclT sd1 2 0 +-- -- d1' <- replaceDecls d1 [sd2] +-- return ([sd2],Just sd1) + +-- replaceDecls lp [d1',sd1] + +-- (lp',(ans',_),_w) <- runTransformT ans doRmDecl +-- return (ans',lp') + +rmDecl4 :: Changer +rmDecl4 _libdir lp = do + let + doRmDecl = do + [de1] <- hsDecls lp + + (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do + sd2' <- transferEntryDP' sd1 sd2 + + let sd1' = setEntryDP' sd1 (DifferentLine 2 0) + return ([sd2'],Just sd1') + + replaceDecls (anchorEof lp) [de1',sd1] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +-- rmDecl5 :: Changer +-- rmDecl5 ans lp = do +-- let +-- doRmDecl = do +-- let +-- go :: GHC.HsExpr GHC.GhcPs -> Transform (GHC.HsExpr GHC.GhcPs) +-- go (GHC.HsLet _ (GHC.L l lb) expr) = do +-- decs <- hsDeclsValBinds lb +-- let dec = last decs +-- transferEntryDPT (head decs) dec +-- lb' <- replaceDeclsValbinds lb [dec] +-- return (GHC.HsLet noExt (GHC.L l lb') expr) +-- go x = return x + +-- SYB.everywhereM (SYB.mkM go) lp + +-- let (lp',(ans',_),_w) = runTransform ans doRmDecl +-- -- putStrLn $ "log:" ++ intercalate "\n" _w +-- return (ans',lp') + +rmDecl5 :: Changer +rmDecl5 _libdir lp = do + let + doRmDecl = do + let + go :: HsExpr GhcPs -> Transform (HsExpr GhcPs) + go (HsLet a lb expr) = do + decs <- hsDeclsValBinds lb + let dec = last decs + _ <- transferEntryDPT (head decs) dec + lb' <- replaceDeclsValbinds WithoutWhere lb [dec] + return (HsLet a lb' expr) + go x = return x + + everywhereM (mkM go) lp + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- rmDecl6 :: Changer +-- rmDecl6 ans lp = do +-- let +-- doRmDecl = do +-- [d1] <- hsDecls lp + +-- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m subDecs -> do +-- let (ss1:_sd1:sd2:sds) = subDecs +-- transferEntryDPT ss1 sd2 + +-- return (sd2:sds,Nothing) + +-- replaceDecls lp [d1'] + +-- (lp',(ans',_),_w) <- runTransformT ans doRmDecl +-- -- putStrLn $ "log:" ++ intercalate "\n" _w +-- return (ans',lp') + +rmDecl6 :: Changer +rmDecl6 _libdir lp = do + let + doRmDecl = do + [de1] <- hsDecls lp + + (de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do + let (ss1:_sd1:sd2:sds) = subDecs + sd2' <- transferEntryDP' ss1 sd2 + + return (sd2':sds,Nothing) + + replaceDecls lp [de1'] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +-- rmDecl7 :: Changer +-- rmDecl7 ans lp = do +-- let +-- doRmDecl = do +-- tlDecs <- hsDecls lp +-- let [s1,d1,d2,d3] = tlDecs + +-- balanceComments d1 d2 +-- balanceComments d2 d3 + +-- transferEntryDPT d2 d3 + +-- replaceDecls lp [s1,d1,d3] + +-- let (lp',(ans',_),_w) = runTransform ans doRmDecl +-- -- putStrLn $ "log:" ++ intercalate "\n" _w +-- return (ans',lp') + +rmDecl7 :: Changer +rmDecl7 _libdir lp = do + let + doRmDecl = do + tlDecs <- hsDecls lp + [s1,de1,d2,d3] <- balanceCommentsList tlDecs + + d3' <- transferEntryDP' d2 d3 + + replaceDecls lp [s1,de1,d3'] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +-- rmTypeSig1 :: Changer +-- rmTypeSig1 ans lp = do +-- let doRmDecl = do +-- tlDecs <- hsDecls lp +-- let (s1:d1:d2) = tlDecs +-- (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 names typ))) = s1 +-- s1' = (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 (tail names) typ))) +-- replaceDecls lp (s1':d1:d2) + +-- let (lp',(ans',_),_w) = runTransform ans doRmDecl +-- return (ans',lp') +rmTypeSig1 :: Changer +rmTypeSig1 _libdir lp = do + let doRmDecl = do + tlDecs <- hsDecls lp + let (s0:de1:d2) = tlDecs + s1 = captureTypeSigSpacing s0 + (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1 + n2' <- transferEntryDP n1 n2 + let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ))) + replaceDecls lp (s1':de1:d2) + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- rmTypeSig2 :: Changer +-- rmTypeSig2 ans lp = do +-- let doRmDecl = do +-- tlDecs <- hsDecls lp +-- let [d1] = tlDecs + +-- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m [s,d] -> do +-- transferEntryDPT s d +-- return ([d],Nothing) +-- replaceDecls lp [d1'] + +-- let (lp',(ans',_),_w) = runTransform ans doRmDecl +-- -- putStrLn $ "log:" ++ intercalate "\n" _w +-- return (ans',lp') + +rmTypeSig2 :: Changer +rmTypeSig2 _libdir lp = do + let doRmDecl = do + tlDecs <- hsDecls lp + let [de1] = tlDecs + + (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do + d' <- transferEntryDPT s d + return ([d'],Nothing) + replaceDecls lp [de1'] + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' + +-- --------------------------------------------------------------------- + +-- addHiding1 :: Changer +-- addHiding1 ans (GHC.L l p) = do +-- let doTransform = do +-- l0 <- uniqueSrcSpanT +-- l1 <- uniqueSrcSpanT +-- l2 <- uniqueSrcSpanT +-- let +-- [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")) +-- v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) +-- v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) +-- impHiding = GHC.L l0 [v1,v2] +-- imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)} +-- p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]} +-- addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] +-- addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] +-- addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] +-- addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] +-- return (GHC.L l p') + +-- let (lp',(ans',_),_w) = runTransform ans doTransform +-- return (ans',lp') + +addHiding1 :: Changer +addHiding1 _libdir (L l p) = do + let doTransform = do + l0 <- uniqueSrcSpanT + l1 <- uniqueSrcSpanT + l2 <- uniqueSrcSpanT + let + [L li imp1,imp2] = hsmodImports p + n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) + n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2))) + impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0) + (AnnList Nothing + (Just (AddEpAnn AnnOpenP d1)) + (Just (AddEpAnn AnnCloseP d0)) + [(AddEpAnn AnnHiding d1)] + []) + emptyComments) l0) [v1,v2] + imp1' = imp1 { ideclHiding = Just (True,impHiding)} + p' = p { hsmodImports = [L li imp1',imp2]} + return (L l p') + + let (lp',(_ans',_),_w) = runTransform mempty doTransform + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +-- addHiding2 :: Changer +-- addHiding2 ans (GHC.L l p) = do +-- let doTransform = do +-- l1 <- uniqueSrcSpanT +-- l2 <- uniqueSrcSpanT +-- let +-- [GHC.L li imp1] = GHC.hsmodImports p +-- 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")) +-- v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) +-- v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) +-- 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))] +-- addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] +-- addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] +-- addTrailingCommaT (last ns) +-- return (GHC.L l p') + +-- let (lp',(ans',_),_w) = runTransform ans doTransform +-- return (ans',lp') + +addHiding2 :: Changer +addHiding2 _libdir (L l p) = do + let doTransform = do + l1 <- uniqueSrcSpanT + l2 <- uniqueSrcSpanT + let + [L li imp1] = hsmodImports p + Just (_,L lh ns) = ideclHiding imp1 + lh' = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan (locA lh)) m0) + (AnnList Nothing + (Just (AddEpAnn AnnOpenP d1)) + (Just (AddEpAnn AnnCloseP d0)) + [(AddEpAnn AnnHiding d1)] + []) + emptyComments) (locA lh)) + n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) + n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2))) + L ln n = last ns + n' = L (addComma ln) n + imp1' = imp1 { ideclHiding = Just (True,L lh' (init ns ++ [n',v1,v2]))} + p' = p { hsmodImports = [L li imp1']} + return (L l p') + + let (lp',(_ans',_),_w) = runTransform mempty doTransform + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return lp' +-- --------------------------------------------------------------------- + +cloneDecl1 :: Changer +cloneDecl1 _libdir lp = do + let doChange = do + tlDecs <- hsDecls lp + let (d1':d2:ds) = tlDecs + d2' <- fst <$> cloneT d2 + let d2'' = setEntryDP' d2' (DifferentLine 2 0) + replaceDecls lp (d1':d2:d2'':ds) + + let (lp',(_ans',_),_w) = runTransform mempty doChange + return lp' -- --------------------------------------------------------------------- diff --git a/tests/examples/failing/InfixOperator.hs b/tests/examples/failing/InfixOperator.hs deleted file mode 100644 --- a/tests/examples/failing/InfixOperator.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} - -#define BACKSLASH 92 -#define CLOSE_CURLY 125 -#define CLOSE_SQUARE 93 -#define COMMA 44 -#define DOUBLE_QUOTE 34 -#define OPEN_CURLY 123 -#define OPEN_SQUARE 91 -#define C_0 48 -#define C_9 57 -#define C_A 65 -#define C_F 70 -#define C_a 97 -#define C_f 102 -#define C_n 110 -#define C_t 116 - -json_ :: Parser Value -> Parser Value -> Parser Value -json_ obj ary = do - w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE) - if w == OPEN_CURLY - then obj - else ary -{-# INLINE json_ #-} - diff --git a/tests/examples/failing/InfixOperator.hs.bad b/tests/examples/failing/InfixOperator.hs.bad deleted file mode 100644 --- a/tests/examples/failing/InfixOperator.hs.bad +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} - -#define BACKSLASH 92 -#define CLOSE_CURLY 125 -#define CLOSE_SQUARE 93 -#define COMMA 44 -#define DOUBLE_QUOTE 34 -#define OPEN_CURLY 123 -#define OPEN_SQUARE 91 -#define C_0 48 -#define C_9 57 -#define C_A 65 -#define C_F 70 -#define C_a 97 -#define C_f 102 -#define C_n 110 -#define C_t 116 - -json_ :: Parser Value -> Parser Value -> Parser Value -json_ obj ary = do - w <- skipSpace *> A.satisfy (\w -> w == 123OPEN_CURLY w ==||) == OPEN_SQUARE) - if w == 123OPEN_CURLY - then obj - else ary -{-# INLINE json_ #-} diff --git a/tests/examples/failing/List2.hs b/tests/examples/failing/List2.hs deleted file mode 100644 --- a/tests/examples/failing/List2.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- | --- Module : Type.Family.List --- Copyright : Copyright (C) 2015 Kyle Carter --- License : BSD3 --- --- Maintainer : Kyle Carter --- Stability : experimental --- Portability : RankNTypes --- --- Convenient aliases and type families for working with --- type-level lists. ----------------------------------------------------------------------------- - -module Type.Family.List where - -import Type.Family.Constraint -import Type.Family.Monoid -import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) -import Type.Class.Witness - -type Ø = '[] -type (:<) = '(:) -infixr 5 :< - diff --git a/tests/examples/failing/List2.hs.bad b/tests/examples/failing/List2.hs.bad deleted file mode 100644 --- a/tests/examples/failing/List2.hs.bad +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- | --- Module : Type.Family.List --- Copyright : Copyright (C) 2015 Kyle Carter --- License : BSD3 --- --- Maintainer : Kyle Carter --- Stability : experimental --- Portability : RankNTypes --- --- Convenient aliases and type families for working with --- type-level lists. ----------------------------------------------------------------------------- - -module Type.Family.List where - -import Type.Family.Constraint -import Type.Family.Monoid -import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) -import Type.Class.Witness - -type Ø = '[] -type (:<) = (:) -infixr 5 :< - diff --git a/tests/examples/failing/MultiLineWarningPragma.hs b/tests/examples/failing/MultiLineWarningPragma.hs deleted file mode 100644 --- a/tests/examples/failing/MultiLineWarningPragma.hs +++ /dev/null @@ -1,18 +0,0 @@ - -{-# WARNING Logic - , mkSolver - , mkSimpleSolver - , mkSolverForLogic - , solverSetParams - , solverPush - , solverPop - , solverReset - , solverGetNumScopes - , solverAssertCnstr - , solverAssertAndTrack - , solverCheck - , solverCheckAndGetModel - , solverGetReasonUnknown - "New Z3 API support is still incomplete and fragile: \ - \you may experience segmentation faults!" - #-} diff --git a/tests/examples/failing/MultiLineWarningPragma.hs.bad b/tests/examples/failing/MultiLineWarningPragma.hs.bad deleted file mode 100644 --- a/tests/examples/failing/MultiLineWarningPragma.hs.bad +++ /dev/null @@ -1,17 +0,0 @@ - -{-# WARNING Logic - , mkSolver - , mkSimpleSolver - , mkSolverForLogic - , solverSetParams - , solverPush - , solverPop - , solverReset - , solverGetNumScopes - , solverAssertCnstr - , solverAssertAndTrack - , solverCheck - , solverCheckAndGetModel - , solverGetReasonUnknown - "New Z3 API support is still incomplete and fragile: you may experience segmentation faults!" - #-} diff --git a/tests/examples/failing/OverloadedLabelsRun04_A.hs b/tests/examples/failing/OverloadedLabelsRun04_A.hs deleted file mode 100644 --- a/tests/examples/failing/OverloadedLabelsRun04_A.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-} -module OverloadedLabelsRun04_A where - -import GHC.OverloadedLabels -import Language.Haskell.TH - -instance IsLabel x (Q [Dec]) where - fromLabel _ = [d| main = putStrLn "Ok" |] diff --git a/tests/examples/failing/T10970a.hs b/tests/examples/failing/T10970a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/T10970a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +main = do +#ifndef VERSION_containers + putStrLn "OK" +#endif +#ifndef MIN_VERSION_base + putStrLn "OK" +#endif diff --git a/tests/examples/failing/T10970a.hs.bad b/tests/examples/failing/T10970a.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/T10970a.hs.bad @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +main = do +#ifndef VERSION_containers + putStrLn "OK" +#endif +#ifndef MIN_VERSION_base + putStrLn "OK" diff --git a/tests/examples/failing/T17544_kw.hs b/tests/examples/failing/T17544_kw.hs deleted file mode 100644 --- a/tests/examples/failing/T17544_kw.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS -haddock -ddump-parsed-ast #-} - --- Haddock comments in this test case should all be rejected, but they are not. --- --- This is a known issue. Users should avoid writing comments in such --- positions, as a future fix will disallow them. --- --- See Note [Register keyword location] in GHC.Parser.PostProcess.Haddock - -module - -- | Bad comment for the module - T17544_kw where - -data Foo -- | Bad comment for MkFoo - where MkFoo :: Foo - -newtype Bar -- | Bad comment for MkBar - where MkBar :: () -> Bar - -class Cls a - -- | Bad comment for clsmethod - where - clsmethod :: a - diff --git a/tests/examples/failing/TensorTests.hs b/tests/examples/failing/TensorTests.hs deleted file mode 100644 --- a/tests/examples/failing/TensorTests.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module TensorTests (tensorTests) where - -import Apply.Cyc -import Tests -import Utils - -import TestTypes - -import Crypto.Lol -import Crypto.Lol.CRTrans -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types - -import Control.Applicative - -import Data.Maybe - -import Data.Singletons -import Data.Promotion.Prelude.Eq -import Data.Singletons.TypeRepStar () - -import qualified Test.Framework as TF - -type TMRParams = ( '(,) <$> Tensors) <*> MRCombos -tmrParams :: Proxy TMRParams -tmrParams = Proxy - ---type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos -type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos -tremParams :: Proxy TrEmParams -tremParams = Proxy - -type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) - -data Liftable :: TyFun (Factored, *) Bool -> * -type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) - diff --git a/tests/examples/failing/TensorTests.hs.bad b/tests/examples/failing/TensorTests.hs.bad deleted file mode 100644 --- a/tests/examples/failing/TensorTests.hs.bad +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module TensorTests (tensorTests) where - -import Apply.Cyc -import Tests -import Utils - -import TestTypes - -import Crypto.Lol -import Crypto.Lol.CRTrans -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types - -import Control.Applicative - -import Data.Maybe - -import Data.Singletons -import Data.Promotion.Prelude.Eq -import Data.Singletons.TypeRepStar () - -import qualified Test.Framework as TF - -type TMRParams = ( (,) <$> Tensors) <*> MRCombos -tmrParams :: Proxy TMRParams -tmrParams = Proxy - ---type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos -type TrEmParams = ( (,) <$> Tensors) <*> MM'RCombos -tremParams :: Proxy TrEmParams -tremParams = Proxy - -type NormParams = ( (,) <$> '[RT]) <*> (Filter Liftable MRCombos) - -data Liftable :: TyFun (Factored, *) Bool -> * -type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) - diff --git a/tests/examples/failing/TopLevelSemis.hs b/tests/examples/failing/TopLevelSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/TopLevelSemis.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.MoHWS.HTTP.Header where + +x = 1 + +-- Comment +; + +data Foo = Foo + +-- After TyClD +; + +instance Monoid CIRB where + mempty = CIRB mempty mempty mempty mempty + +-- After InstD +; + +deriving instance Eq (GenTickish 'TickishPassCore) + +-- After DerivD +; + +transferCodingStr DeflateTransferCoding = "deflate" + +-- After ValD +; + +getContentType :: Int + +-- After SigD +; + +type MyMaybe :: Type -> Type + +-- After KindSigD +; + +default (Integer) + +-- After DefD +; + +foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int + +-- After ForD +; + +{-# DEPRECATED foo2 [] #-} + +-- After WarningD +; + +{-# ANN module FromA #-} + +-- After AnnD +; + +{-# RULES "myrule2" id f = f #-} + +-- After RuleD +; + +$foo + +-- After SpliceD +; + +type role Representational representational + +-- After RoleAnnotD +; + +getContentType = 1 + +-- Note: skipping DocD, only generated in haddock mode + diff --git a/tests/examples/failing/TopLevelSemis.hs.bad b/tests/examples/failing/TopLevelSemis.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/TopLevelSemis.hs.bad @@ -0,0 +1,94 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.MoHWS.HTTP.Header where + +x = 1 + + +; + + +data Foo = Foo + + +; + + +instance Monoid CIRB where + mempty = CIRB mempty mempty mempty mempty + + +; + + +deriving instance Eq (GenTickish 'TickishPassCore) + + +; + + +transferCodingStr DeflateTransferCoding = "deflate" + + +; + + +getContentType :: Int + + +; + + +type MyMaybe :: Type -> Type + + +; + + +default (Integer) + + +; + + +foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int + + +; + + +{-# DEPRECATED foo2 [] #-} + + +; + + +{-# ANN module FromA #-} + + +; + + +{-# RULES "myrule2" id f = f #-} + + +; + + +$foo + + +; + + +type role Representational representational + + +; + + +getContentType = 1 + +-- Note: skipping DocD, only generated in haddock mode + diff --git a/tests/examples/failing/UnicodeRules.hs b/tests/examples/failing/UnicodeRules.hs deleted file mode 100644 --- a/tests/examples/failing/UnicodeRules.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE - BangPatterns - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , UnboxedTuples - , UndecidableInstances - , UnicodeSyntax - #-} - -strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool -{-# RULES "head → strictHead" [1] - ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). - head v = strictHead v #-} -{-# INLINE strictHead #-} -strictHead (Bitstream _ v) = head (SV.head v) diff --git a/tests/examples/failing/UnicodeRules.hs.bad b/tests/examples/failing/UnicodeRules.hs.bad deleted file mode 100644 --- a/tests/examples/failing/UnicodeRules.hs.bad +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE - BangPatterns - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , UnboxedTuples - , UndecidableInstances - , UnicodeSyntax - #-} - -strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool -{-# RULES "head \8594 strictHead" [1] - ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). - head v = strictHead v #-} -{-# INLINE strictHead #-} -strictHead (Bitstream _ v) = head (SV.head v) diff --git a/tests/examples/failing/UnicodeSyntax.hs b/tests/examples/failing/UnicodeSyntax.hs deleted file mode 100644 --- a/tests/examples/failing/UnicodeSyntax.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE Arrows #-} - -module Tutorial where - --- import Abt.Class --- import Abt.Types --- import Abt.Concrete.LocallyNameless - -import Control.Applicative -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Except --- import Data.Vinyl -import Prelude hiding (pi) - --- | We'll start off with a monad in which to manipulate ABTs; we'll need some --- state for fresh variable generation. --- -newtype M α - = M - { _M ∷ State Int α - } deriving (Functor, Applicative, Monad) - --- | We'll run an ABT computation by starting the variable counter at @0@. --- -runM ∷ M α → α -runM (M m) = evalState m 0 - --- | Check out the source to see fresh variable generation. --- -instance MonadVar Var M where - fresh = M $ do - n ← get - let n' = n + 1 - put n' - return $ Var Nothing n' - - named a = do - v ← fresh - return $ v { _varName = Just a } - --- | Next, we'll define the operators for a tiny lambda calculus as a datatype --- indexed by arities. --- -data Lang ns where - LAM ∷ Lang '[S Z] - APP ∷ Lang '[Z, Z] - PI ∷ Lang '[Z, S Z] - UNIT ∷ Lang '[] - AX ∷ Lang '[] - -instance Show1 Lang where - show1 = \case - LAM → "lam" - APP → "ap" - PI → "pi" - UNIT → "unit" - AX → "<>" - -instance HEq1 Lang where - heq1 LAM LAM = Just Refl - heq1 APP APP = Just Refl - heq1 PI PI = Just Refl - heq1 UNIT UNIT = Just Refl - heq1 AX AX = Just Refl - heq1 _ _ = Nothing - -lam ∷ Tm Lang (S Z) → Tm0 Lang -lam e = LAM $$ e :& RNil - -app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang -app m n = APP $$ m :& n :& RNil - -ax ∷ Tm0 Lang -ax = AX $$ RNil - -unit ∷ Tm0 Lang -unit = UNIT $$ RNil - -pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang -pi α xβ = PI $$ α :& xβ :& RNil - --- | A monad transformer for small step operational semantics. --- -newtype StepT m α - = StepT - { runStepT ∷ MaybeT m α - } deriving (Monad, Functor, Applicative, Alternative) - --- | To indicate that a term is in normal form. --- -stepsExhausted - ∷ Applicative m - ⇒ StepT m α -stepsExhausted = StepT . MaybeT $ pure Nothing - -instance MonadVar Var m ⇒ MonadVar Var (StepT m) where - fresh = StepT . MaybeT $ Just <$> fresh - named str = StepT . MaybeT $ Just <$> named str - --- | A single evaluation step. --- -step - ∷ Tm0 Lang - → StepT M (Tm0 Lang) -step tm = - out tm >>= \case - APP :$ m :& n :& RNil → - out m >>= \case - LAM :$ xe :& RNil → xe // n - _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n - PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ - _ → stepsExhausted - --- | The reflexive-transitive closure of a small-step operational semantics. --- -star - ∷ Monad m - ⇒ (α → StepT m α) - → (α → m α) -star f a = - runMaybeT (runStepT $ f a) >>= - return a `maybe` star f - --- | Evaluate a term to normal form --- -eval ∷ Tm0 Lang → Tm0 Lang -eval = runM . star step - -newtype JudgeT m α - = JudgeT - { runJudgeT ∷ ExceptT String m α - } deriving (Monad, Functor, Applicative, Alternative) - -instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where - fresh = JudgeT . ExceptT $ Right <$> fresh - named str = JudgeT . ExceptT $ Right <$> named str - -type Ctx = [(Var, Tm0 Lang)] - -raise ∷ Monad m ⇒ String → JudgeT m α -raise = JudgeT . ExceptT . return . Left - -checkTy - ∷ Ctx - → Tm0 Lang - → Tm0 Lang - → JudgeT M () -checkTy g tm ty = do - let ntm = eval tm - nty = eval ty - (,) <$> out ntm <*> out nty >>= \case - (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do - z ← fresh - ez ← xe // var z - βz ← yβ // var z - checkTy ((z,α):g) ez βz - (AX :$ RNil, UNIT :$ RNil) → return () - _ → do - ty' ← inferTy g tm - if ty' === nty - then return () - else raise "Type error" - -inferTy - ∷ Ctx - → Tm0 Lang - → JudgeT M (Tm0 Lang) -inferTy g tm = do - out (eval tm) >>= \case - V v | Just (eval → ty) ← lookup v g → return ty - | otherwise → raise "Ill-scoped variable" - APP :$ m :& n :& RNil → do - inferTy g m >>= out >>= \case - PI :$ α :& xβ :& RNil → do - checkTy g n α - eval <$> xβ // n - _ → raise "Expected pi type for lambda abstraction" - _ → raise "Only infer neutral terms" - --- | @λx.x@ --- -identityTm ∷ M (Tm0 Lang) -identityTm = do - x ← fresh - return $ lam (x \\ var x) - --- | @(λx.x)(λx.x)@ --- -appTm ∷ M (Tm0 Lang) -appTm = do - tm ← identityTm - return $ app tm tm - --- | A demonstration of evaluating (and pretty-printing). Output: --- --- @ --- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] --- @ --- -main ∷ IO () -main = do - -- Try out the type checker - either fail print . runM . runExceptT . runJudgeT $ do - x ← fresh - checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) - - print . runM $ do - mm ← appTm - mmStr ← toString mm - mmStr' ← toString $ eval mm - return $ mmStr ++ " ~>* " ++ mmStr' - -doMap ∷ FilePath → IOSArrow XmlTree TiledMap -doMap mapPath = proc m → do - mapWidth ← getAttrR "width" ⤙ m - returnA -< baz - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data Recorder fr ch (r ∷ ★ → ★) - = Recorder { - reRate ∷ !Int - , reHandle ∷ !Handle - , reCloseH ∷ !(FinalizerHandle r) - } - diff --git a/tests/examples/failing/UnicodeSyntax.hs.bad b/tests/examples/failing/UnicodeSyntax.hs.bad deleted file mode 100644 --- a/tests/examples/failing/UnicodeSyntax.hs.bad +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE Arrows #-} - -module Tutorial where - --- import Abt.Class --- import Abt.Types --- import Abt.Concrete.LocallyNameless - -import Control.Applicative -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Except --- import Data.Vinyl -import Prelude hiding (pi) - --- | We'll start off with a monad in which to manipulate ABTs; we'll need some --- state for fresh variable generation. --- -newtype M α - = M - { _M ∷ State Int α - } deriving (Functor, Applicative, Monad) - --- | We'll run an ABT computation by starting the variable counter at @0@. --- -runM ∷ M α → α -runM (M m) = evalState m 0 - --- | Check out the source to see fresh variable generation. --- -instance MonadVar Var M where - fresh = M $ do - n ← get - let n' = n + 1 - put n' - return $ Var Nothing n' - - named a = do - v ← fresh - return $ v { _varName = Just a } - --- | Next, we'll define the operators for a tiny lambda calculus as a datatype --- indexed by arities. --- -data Lang ns where - LAM ∷ Lang '[S Z] - APP ∷ Lang '[Z, Z] - PI ∷ Lang '[Z, S Z] - UNIT ∷ Lang '[] - AX ∷ Lang '[] - -instance Show1 Lang where - show1 = \case - LAM → "lam" - APP → "ap" - PI → "pi" - UNIT → "unit" - AX → "<>" - -instance HEq1 Lang where - heq1 LAM LAM = Just Refl - heq1 APP APP = Just Refl - heq1 PI PI = Just Refl - heq1 UNIT UNIT = Just Refl - heq1 AX AX = Just Refl - heq1 _ _ = Nothing - -lam ∷ Tm Lang (S Z) → Tm0 Lang -lam e = LAM $$ e :& RNil - -app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang -app m n = APP $$ m :& n :& RNil - -ax ∷ Tm0 Lang -ax = AX $$ RNil - -unit ∷ Tm0 Lang -unit = UNIT $$ RNil - -pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang -pi α xβ = PI $$ α :& xβ :& RNil - --- | A monad transformer for small step operational semantics. --- -newtype StepT m α - = StepT - { runStepT ∷ MaybeT m α - } deriving (Monad, Functor, Applicative, Alternative) - --- | To indicate that a term is in normal form. --- -stepsExhausted - ∷ Applicative m - ⇒ StepT m α -stepsExhausted = StepT . MaybeT $ pure Nothing - -instance MonadVar Var m ⇒ MonadVar Var (StepT m) where - fresh = StepT . MaybeT $ Just <$> fresh - named str = StepT . MaybeT $ Just <$> named str - --- | A single evaluation step. --- -step - ∷ Tm0 Lang - → StepT M (Tm0 Lang) -step tm = - out tm >>= \case - APP :$ m :& n :& RNil → - out m >>= \case - LAM :$ xe :& RNil → xe // n - _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n - PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ - _ → stepsExhausted - --- | The reflexive-transitive closure of a small-step operational semantics. --- -star - ∷ Monad m - ⇒ (α → StepT m α) - → (α → m α) -star f a = - runMaybeT (runStepT $ f a) >>= - return a `maybe` star f - --- | Evaluate a term to normal form --- -eval ∷ Tm0 Lang → Tm0 Lang -eval = runM . star step - -newtype JudgeT m α - = JudgeT - { runJudgeT ∷ ExceptT String m α - } deriving (Monad, Functor, Applicative, Alternative) - -instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where - fresh = JudgeT . ExceptT $ Right <$> fresh - named str = JudgeT . ExceptT $ Right <$> named str - -type Ctx = [(Var, Tm0 Lang)] - -raise ∷ Monad m ⇒ String → JudgeT m α -raise = JudgeT . ExceptT . return . Left - -checkTy - ∷ Ctx - → Tm0 Lang - → Tm0 Lang - → JudgeT M () -checkTy g tm ty = do - let ntm = eval tm - nty = eval ty - (,) <$> out ntm <*> out nty >>= \case - (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do - z ← fresh - ez ← xe // var z - βz ← yβ // var z - checkTy ((z,α):g) ez βz - (AX :$ RNil, UNIT :$ RNil) → return () - _ → do - ty' ← inferTy g tm - if ty' === nty - then return () - else raise "Type error" - -inferTy - ∷ Ctx - → Tm0 Lang - → JudgeT M (Tm0 Lang) -inferTy g tm = do - out (eval tm) >>= \case - V v | Just (eval → ty) ← lookup v g → return ty - | otherwise → raise "Ill-scoped variable" - APP :$ m :& n :& RNil → do - inferTy g m >>= out >>= \case - PI :$ α :& xβ :& RNil → do - checkTy g n α - eval <$> xβ // n - _ → raise "Expected pi type for lambda abstraction" - _ → raise "Only infer neutral terms" - --- | @λx.x@ --- -identityTm ∷ M (Tm0 Lang) -identityTm = do - x ← fresh - return $ lam (x \\ var x) - --- | @(λx.x)(λx.x)@ --- -appTm ∷ M (Tm0 Lang) -appTm = do - tm ← identityTm - return $ app tm tm - --- | A demonstration of evaluating (and pretty-printing). Output: --- --- @ --- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] --- @ --- -main ∷ IO () -main = do - -- Try out the type checker - either fail print . runM . runExceptT . runJudgeT $ do - x ← fresh - checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) - - print . runM $ do - mm ← appTm - mmStr ← toString mm - mmStr' ← toString $ eval mm - return $ mmStr ++ " ~>* " ++ mmStr' - -doMap ∷ FilePath → IOSArrow XmlTree TiledMap -doMap mapPath = proc m → do - mapWidth ← getAttrR "width" ⤙ m - returnA -< baz - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data Recorder fr ch (r ∷ * → *) - = Recorder { - reRate ∷ !Int - , reHandle ∷ !Handle - , reCloseH ∷ !(FinalizerHandle r) - } - diff --git a/tests/examples/failing/dsrun010.hs b/tests/examples/failing/dsrun010.hs deleted file mode 100644 --- a/tests/examples/failing/dsrun010.hs +++ /dev/null @@ -1,25 +0,0 @@ --- Check that pattern match failure in do-notation --- is reflected by calling the monadic 'fail', not by a --- runtime exception - -{-# LANGUAGE NoMonadFailDesugaring #-} -{-# OPTIONS -Wno-missing-monadfail-instances #-} - -import Control.Monad -import Data.Maybe - -test :: (MonadPlus m) => [a] -> m Bool -test xs - = do - (_:_) <- return xs - -- Should fail here - return True - `mplus` - -- Failure in LH arg should trigger RH arg - do - return False - -main :: IO () -main - = do let x = fromJust (test []) - putStrLn (show x) diff --git a/tests/examples/failing/n-plus-k-patterns.hs b/tests/examples/failing/n-plus-k-patterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/n-plus-k-patterns.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE NPlusKPatterns #-} +singleline :: Int +singleline (n + 1) = n + +multiline :: Int +multiline(n + + 1) = n + +n :: Int +(n + 1) = 3 + diff --git a/tests/examples/failing/n-plus-k-patterns.hs.bad b/tests/examples/failing/n-plus-k-patterns.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/n-plus-k-patterns.hs.bad @@ -0,0 +1,11 @@ +{-# LANGUAGE NPlusKPatterns #-} +singleline :: Int +singleline (n 1) = n + +multiline :: Int +multiline(n + 1) = n + +n :: Int +(n 1) = 3 + diff --git a/tests/examples/failing/overloadedlabelsrun04.hs b/tests/examples/failing/overloadedlabelsrun04.hs deleted file mode 100644 --- a/tests/examples/failing/overloadedlabelsrun04.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE OverloadedLabels, TemplateHaskell #-} - -import OverloadedLabelsRun04_A - --- Who knew that there were so many ways that a line could start with --- a # sign in Haskell? None of these are overloaded labels: -#line 7 "overloadedlabelsrun04.hs" -# 8 "overloadedlabelsrun04.hs" -#!notashellscript -#pragma foo - --- But this one is: -#foo diff --git a/tests/examples/failing/overloadedlabelsrun04.hs.bad b/tests/examples/failing/overloadedlabelsrun04.hs.bad deleted file mode 100644 --- a/tests/examples/failing/overloadedlabelsrun04.hs.bad +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE OverloadedLabels, TemplateHaskell #-} - -import OverloadedLabelsRun04_A - --- Who knew that there were so many ways that a line could start with --- a # sign in Haskell? None of these are overloaded labels: - - -#!notashellscript - --- But this one is: -#foo diff --git a/tests/examples/ghc710/EmptyMostly.hs b/tests/examples/ghc710/EmptyMostly.hs --- a/tests/examples/ghc710/EmptyMostly.hs +++ b/tests/examples/ghc710/EmptyMostly.hs @@ -11,3 +11,4 @@ -- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;} -- ;; } +-- really trailing diff --git a/tests/examples/ghc710/TypeBrackets2.hs b/tests/examples/ghc710/TypeBrackets2.hs --- a/tests/examples/ghc710/TypeBrackets2.hs +++ b/tests/examples/ghc710/TypeBrackets2.hs @@ -16,8 +16,8 @@ baz :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v instance Dsp (S n) where - data (ASig (S n)) = S_A CVar - data (KSig (S n)) = S_K CVar - data (INum (S n)) = S_I CVar + data (ASig (S n)) = S_A CVar + data ((KSig (S n))) = S_K CVar + data (((INum (S n)))) = S_I CVar getSr = fst <$> ask getKsmps = snd <$> ask diff --git a/tests/examples/ghc710/TypeSynParens.hs b/tests/examples/ghc710/TypeSynParens.hs --- a/tests/examples/ghc710/TypeSynParens.hs +++ b/tests/examples/ghc710/TypeSynParens.hs @@ -13,7 +13,7 @@ type CompileResult InterpreterStmt = [Hask.Stmt] instance Compilable ModuleSpan where - type CompileResult ModuleSpan = Hask.Module + type ((CompileResult ModuleSpan)) = Hask.Module instance Compilable StatementSpan where type (CompileResult StatementSpan) = [Stmt] diff --git a/tests/examples/ghc80/MonadFailErrors.hs b/tests/examples/ghc80/MonadFailErrors.hs --- a/tests/examples/ghc80/MonadFailErrors.hs +++ b/tests/examples/ghc80/MonadFailErrors.hs @@ -1,7 +1,7 @@ -- Test purpose: -- Break properly if MonadFail is live -{-# LANGUAGE MonadFailDesugaring #-} +{- # LANGUAGE MonadFailDesugaring # -} module MonadFailWarnings where diff --git a/tests/examples/ghc80/T10970a.hs b/tests/examples/ghc80/T10970a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10970a.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} -main = do -#ifndef VERSION_containers - putStrLn "OK" -#endif -#ifndef MIN_VERSION_base - putStrLn "OK" -#endif diff --git a/tests/examples/ghc92/Binary.hs b/tests/examples/ghc92/Binary.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Binary.hs @@ -0,0 +1,259 @@ +{-# OPTIONS -fno-warn-orphans #-} + +module Data.Curve.Binary + ( module Data.Curve + , Point(..) + -- * Binary curves + , BCurve(..) + , BPoint + -- ** Binary affine curves + , BACurve(..) + , BAPoint + -- ** Binary projective curves + , BPCurve(..) + , BPPoint + ) where + +import Protolude + +import Data.Field.Galois as F (GaloisField, PrimeField, frob, quad) +import GHC.Natural (Natural) +import Text.PrettyPrint.Leijen.Text (Pretty(..)) + +import Data.Curve + +------------------------------------------------------------------------------- +-- Binary form +------------------------------------------------------------------------------- + +-- | Binary points. +type BPoint = Point 'Binary + +-- | Binary curves. +class (GaloisField q, PrimeField r, Curve 'Binary c e q r) => BCurve c e q r where + {-# MINIMAL a_, b_, h_, p_, r_ #-} + a_ :: BPoint c e q r -> q -- ^ Coefficient @A@. + b_ :: BPoint c e q r -> q -- ^ Coefficient @B@. + h_ :: BPoint c e q r -> Natural -- ^ Curve cofactor. + p_ :: BPoint c e q r -> Natural -- ^ Curve polynomial. + r_ :: BPoint c e q r -> Natural -- ^ Curve order. + +------------------------------------------------------------------------------- +-- Affine coordinates +------------------------------------------------------------------------------- + +-- | Binary affine points. +type BAPoint = BPoint 'Affine + +-- | Binary affine curves @y^2 + xy = x^3 + Ax^2 + B@. +class BCurve 'Affine e q r => BACurve e q r where + {-# MINIMAL gA_ #-} + gA_ :: BAPoint e q r -- ^ Curve generator. + +-- Binary affine curves are elliptic curves. +instance BACurve e q r => Curve 'Binary 'Affine e q r where + + data instance Point 'Binary 'Affine e q r = A q q -- ^ Affine point. + | O -- ^ Infinite point. + deriving (Eq, Generic, NFData, Read, Show) + + add p O = p + add O q = q + add (A x1 y1) (A x2 y2) + | xx == 0 = O + | otherwise = A x3 y3 + where + a = a_ (witness :: BAPoint e q r) + xx = x1 + x2 + yy = y1 + y2 + l = yy / xx + x3 = l * (l + 1) + xx + a + y3 = l * (x1 + x3) + x3 + y1 + {-# INLINABLE add #-} + + char = const 2 + {-# INLINABLE char #-} + + cof = h_ + {-# INLINABLE cof #-} + + dbl O = O + dbl (A x y) + | x == 0 = O + | otherwise = A x' y' + where + a = a_ (witness :: BAPoint e q r) + l = x + y / x + l' = l + 1 + x' = l * l' + a + y' = x * x + l' * x' + {-# INLINABLE dbl #-} + + def O = True + def (A x y) = ((x + a) * x + y) * x + b + y * y == 0 + where + a = a_ (witness :: BAPoint e q r) + b = b_ (witness :: BAPoint e q r) + {-# INLINABLE def #-} + + disc _ = b_ (witness :: BAPoint e q r) + {-# INLINABLE disc #-} + + frob O = O + frob (A x y) = A (F.frob x) (F.frob y) + {-# INLINABLE frob #-} + + fromA = identity + {-# INLINABLE fromA #-} + + gen = gA_ + {-# INLINABLE gen #-} + + id = O + {-# INLINABLE id #-} + + inv O = O + inv (A x y) = A x (x + y) + {-# INLINABLE inv #-} + + order = r_ + {-# INLINABLE order #-} + + point x y = let p = A x y in if def p then Just p else Nothing + {-# INLINABLE point #-} + + pointX x = A x <$> yX (witness :: BAPoint e q r) x + {-# INLINABLE pointX #-} + + toA = identity + {-# INLINABLE toA #-} + + yX _ x = quad 1 x ((x + a) * x * x + b) + where + a = a_ (witness :: BAPoint e q r) + b = b_ (witness :: BAPoint e q r) + {-# INLINABLE yX #-} + +-- Binary affine points are pretty. +instance BACurve e q r => Pretty (BAPoint e q r) where + + pretty (A x y) = pretty (x, y) + pretty O = "O" + +------------------------------------------------------------------------------- +-- Projective coordinates +------------------------------------------------------------------------------- + +-- | Binary projective points. +type BPPoint = BPoint 'Projective + +-- | Binary projective curves @y^2z + xyz = x^3 + Ax^2z + Bz@. +class BCurve 'Projective e q r => BPCurve e q r where + {-# MINIMAL gP_ #-} + gP_ :: BPPoint e q r -- ^ Curve generator. + +-- Binary projective curves are elliptic curves. +instance BPCurve e q r => Curve 'Binary 'Projective e q r where + + data instance Point 'Binary 'Projective e q r = P q q q -- ^ Projective point. + deriving (Generic, NFData, Read, Show) + + -- Addition formula add-2008-bl + add p (P _ _ 0) = p + add (P _ _ 0) q = q + add (P x1 y1 z1) (P x2 y2 z2) = P x3 y3 z3 + where + a' = a_ (witness :: BPPoint e q r) + y1z2 = y1 * z2 + x1z2 = x1 * z2 + a = y1z2 + z1 * y2 + b = x1z2 + z1 * x2 + ab = a + b + c = b * b + d = z1 * z2 + e = b * c + f = (a * ab + a' * c) * d + e + x3 = b * f + y3 = c * (a * x1z2 + b * y1z2) + ab * f + z3 = e * d + {-# INLINABLE add #-} + + char = const 2 + {-# INLINABLE char #-} + + cof = h_ + {-# INLINABLE cof #-} + + -- Doubling formula dbl-2008-bl + dbl (P _ _ 0) = P 0 1 0 + dbl (P x1 y1 z1) = P x3 y3 z3 + where + a' = a_ (witness :: BPPoint e q r) + a = x1 * x1 + b = a + y1 * z1 + c = x1 * z1 + bc = b + c + d = c * c + e = b * bc + a' * d + x3 = c * e + y3 = bc * e + a * a * c + z3 = c * d + {-# INLINABLE dbl #-} + + def (P x y z) = ((x + a * z) * x + yz) * x + y * yz + b * z * z * z == 0 + where + a = a_ (witness :: BPPoint e q r) + b = b_ (witness :: BPPoint e q r) + yz = y * z + {-# INLINABLE def #-} + + disc _ = b_ (witness :: BPPoint e q r) + {-# INLINABLE disc #-} + + frob (P x y z) = P (F.frob x) (F.frob y) (F.frob z) + {-# INLINABLE frob #-} + + fromA (A x y) = P x y 1 + fromA _ = P 0 1 0 + {-# INLINABLE fromA #-} + + gen = gP_ + {-# INLINABLE gen #-} + + id = P 0 1 0 + {-# INLINABLE id #-} + + inv (P x y z) = P x (x + y) z + {-# INLINABLE inv #-} + + order = r_ + {-# INLINABLE order #-} + + point x y = let p = P x y 1 in if def p then Just p else Nothing + {-# INLINABLE point #-} + + pointX x = flip (P x) 1 <$> yX (witness :: BPPoint e q r) x + {-# INLINABLE pointX #-} + + toA (P _ _ 0) = O + toA (P x y z) = A (x / z) (y / z) + {-# INLINABLE toA #-} + + yX _ x = quad 1 x ((x + a) * x * x + b) + where + a = a_ (witness :: BPPoint e q r) + b = b_ (witness :: BPPoint e q r) + {-# INLINABLE yX #-} + +-- Binary projective points are equatable. +instance BPCurve e q r => Eq (BPPoint e q r) where + + P x1 y1 z1 == P x2 y2 z2 = z1 == 0 && z2 == 0 + || x1 * z2 == x2 * z1 && y1 * z2 == y2 * z1 + {-# INLINABLE (==) #-} + +-- Binary projective points are pretty. +instance BPCurve e q r => Pretty (BPPoint e q r) where + + pretty (P x y z) = pretty (x, y, z) + diff --git a/tests/examples/ghc92/BlockComment.hs b/tests/examples/ghc92/BlockComment.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/BlockComment.hs @@ -0,0 +1,7 @@ +module BlockComment where + +foo x = do + blah + where + {- a comment -} + blah = 3 diff --git a/tests/examples/ghc92/Character.hs b/tests/examples/ghc92/Character.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Character.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE QuasiQuotes #-} +module Atomo.Kernel.Character where + +import Data.Char + +import Atomo + + +load :: VM () +load = do + [p|(c: Character) control?|] =: liftM Boolean (onCharacter isControl) + [p|(c: Character) space?|] =: liftM Boolean (onCharacter isSpace) + [p|(c: Character) lower?|] =: liftM Boolean (onCharacter isLower) + [p|(c: Character) upper?|] =: liftM Boolean (onCharacter isUpper) + [p|(c: Character) alpha?|] =: liftM Boolean (onCharacter isAlpha) + [p|(c: Character) alphanum?|] =: liftM Boolean (onCharacter isAlphaNum) + [p|(c: Character) print?|] =: liftM Boolean (onCharacter isPrint) + [p|(c: Character) digit?|] =: liftM Boolean (onCharacter isDigit) + [p|(c: Character) oct-digit?|] =: liftM Boolean (onCharacter isOctDigit) + [p|(c: Character) hex-digit?|] =: liftM Boolean (onCharacter isHexDigit) + [p|(c: Character) letter?|] =: liftM Boolean (onCharacter isLetter) + [p|(c: Character) mark?|] =: liftM Boolean (onCharacter isMark) + [p|(c: Character) number?|] =: liftM Boolean (onCharacter isNumber) + [p|(c: Character) punctuation?|] =: liftM Boolean (onCharacter isPunctuation) + [p|(c: Character) symbol?|] =: liftM Boolean (onCharacter isSymbol) + [p|(c: Character) separator?|] =: liftM Boolean (onCharacter isSeparator) + [p|(c: Character) ascii?|] =: liftM Boolean (onCharacter isAscii) + [p|(c: Character) latin1?|] =: liftM Boolean (onCharacter isLatin1) + [p|(c: Character) ascii-upper?|] =: liftM Boolean (onCharacter isAsciiLower) + [p|(c: Character) ascii-lower?|] =: liftM Boolean (onCharacter isAsciiUpper) + + [p|(c: Character) uppercase|] =: liftM Character (onCharacter toUpper) + [p|(c: Character) lowercase|] =: liftM Character (onCharacter toLower) + [p|(c: Character) titlecase|] =: liftM Character (onCharacter toTitle) + + [p|(c: Character) from-digit|] =: liftM (Integer . fromIntegral) (onCharacter digitToInt) + [p|(i: Integer) to-digit|] =: liftM Character (onInteger (intToDigit . fromIntegral)) + + [p|(c: Character) ord|] =: liftM (Integer . fromIntegral) (onCharacter ord) + [p|(i: Integer) chr|] =: liftM Character (onInteger (chr . fromIntegral)) + + [p|(c: Character) category|] =: liftM c (onCharacter generalCategory) + where + onCharacter :: (Char -> a) -> VM a + onCharacter f = here "c" >>= liftM (f . fromCharacter) . findCharacter + + onInteger :: (Integer -> a) -> VM a + onInteger f = here "i" >>= liftM (f . Atomo.fromInteger) . findInteger + + c UppercaseLetter = keyParticleN ["letter"] [particle "uppercase"] + c LowercaseLetter = keyParticleN ["letter"] [particle "lowercase"] + c TitlecaseLetter = keyParticleN ["letter"] [particle "titlecase"] + c ModifierLetter = keyParticleN ["letter"] [particle "modified"] + c OtherLetter = keyParticleN ["letter"] [particle "other"] + c NonSpacingMark = keyParticleN ["mark"] [particle "non-spacing"] + c SpacingCombiningMark = keyParticleN ["mark"] [particle "space-combining"] + c EnclosingMark = keyParticleN ["mark"] [particle "enclosing"] + c DecimalNumber = keyParticleN ["number"] [particle "decimal"] + c LetterNumber = keyParticleN ["number"] [particle "letter"] + c OtherNumber = keyParticleN ["number"] [particle "other"] + c ConnectorPunctuation = keyParticleN ["punctuation"] [particle "connector"] + c DashPunctuation = keyParticleN ["punctuation"] [particle "dash"] + c OpenPunctuation = keyParticleN ["punctuation"] [particle "open"] + c ClosePunctuation = keyParticleN ["punctuation"] [particle "close"] + c InitialQuote = keyParticleN ["quote"] [particle "initial"] + c FinalQuote = keyParticleN ["quote"] [particle "final"] + c OtherPunctuation = keyParticleN ["punctuation"] [particle "other"] + c MathSymbol = keyParticleN ["symbol"] [particle "math"] + c CurrencySymbol = keyParticleN ["symbol"] [particle "currency"] + c ModifierSymbol = keyParticleN ["symbol"] [particle "modifier"] + c OtherSymbol = keyParticleN ["symbol"] [particle "other"] + c Space = particle "space" + c LineSeparator = keyParticleN ["separator"] [particle "line"] + c ParagraphSeparator = keyParticleN ["separator"] [particle "paragraph"] + c Control = particle "control" + c Format = particle "format" + c Surrogate = particle "surrogate" + c PrivateUse = particle "private-use" + c NotAssigned = particle "not-assigned" diff --git a/tests/examples/ghc92/Checkpoint.hs b/tests/examples/ghc92/Checkpoint.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Checkpoint.hs @@ -0,0 +1,45 @@ +-- | Checkpoints in the blockchain (every 1000th blocks) + +{-# LANGUAGE CPP #-} +module Bitcoin.BlockChain.Checkpoint where + +--6----------------------------------------------------------------------------- + +import Bitcoin.Protocol.Hash + +--10---------------------------------------------------------------------------- + +#ifndef WITH_TESTNET + +--14---------------------------------------------------------------------------- +-- * the real network + +theGenesisBlock :: Hash256 +theGenesisBlock = hash256FromTextBE "000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f" + +theCheckpoints :: [(Int,Hash256)] +theCheckpoints = + [ (0 , hash256FromTextBE "000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f" ) + , (248000 , hash256FromTextBE "000000000000004d945017c14b75a3a58a2aa6772cacbfcaf907b3bee6d7f344" ) + ] + +--273--------------------------------------------------------------------------- + +#else + +--277--------------------------------------------------------------------------- +-- * testnet3 + +theGenesisBlock :: Hash256 +theGenesisBlock = hash256FromTextBE "000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943" + +theCheckpoints :: [(Int,Hash256)] +theCheckpoints = + [ (0 , hash256FromTextBE "000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943" ) + , (97000 , hash256FromTextBE "0000000000096581c7c0fe4d15ea0212f1087fc79f3735a892ee262c384b3741" ) + ] + +#endif + +--387--------------------------------------------------------------------------- + diff --git a/tests/examples/ghc92/CommentPlacement.hs b/tests/examples/ghc92/CommentPlacement.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommentPlacement.hs @@ -0,0 +1,17 @@ +module CommentPlacement where + +liftToTopLevel' modName pn@(L _ n) = do + liftToMod + --step0: comment + liftToMod + where + --step1: comment + liftToMod = return () + +c04 r@Resource{..} = do + let result = do + acceptStr <- lookup HTTP.hAccept reqHeaders + where + -- this is so that in addition to getting back the resource + provided' = map dupContentType provided + dupContentType (a, b) = (a, (a, b)) diff --git a/tests/examples/ghc92/CommentPlacement2.hs b/tests/examples/ghc92/CommentPlacement2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommentPlacement2.hs @@ -0,0 +1,8 @@ +module CommentPlacement2 where + +c04 = do + let result = do + acceptStr <- y + where + --COMMENT + aa = bb diff --git a/tests/examples/ghc92/CommonUI.hs b/tests/examples/ghc92/CommonUI.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommonUI.hs @@ -0,0 +1,11 @@ +module CommonUI where + +-- | Prints a document in a none XMl format + +createRuleItem frame state g n e = + do + when (isJust maybeRes) $ + do{ + ;let ;palette = getPalette doc + } + diff --git a/tests/examples/ghc92/ExperimIOP.hs b/tests/examples/ghc92/ExperimIOP.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/ExperimIOP.hs @@ -0,0 +1,24 @@ +-- +-- (C) Susumu Katayama +-- +-- (Typed)IOPairs¾å¤Ç¥Ç¡¼¥¿¤ò¤È¤ë¡¥ghci¾å¤Ç :cmd ¤ò»È¤¤¤Þ¤¯¤ë´¶¤¸¡¥ +{-# LANGUAGE RankNTypes, CPP, TemplateHaskell #-} +module ExperimIOP(module ExperimIOP, module MagicHaskeller.RunAnalytical) where + +import MagicHaskeller.Analytical +#ifdef DEBUG + hiding (rev) +#endif +import MagicHaskeller.Classification(Filtrable) +import MagicHaskeller.RunAnalytical +#ifdef DEBUG + hiding (main) +#endif +import MagicHaskeller.GetTime(batchWrite) + +main = do iop <- runQ andL + let e = getOne iop [] + putStrLn $ pprint e + +emptyBK = [d| {} |] + diff --git a/tests/examples/ghc92/FOL.hs b/tests/examples/ghc92/FOL.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/FOL.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, + TypeFamilies, TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Data.Logic.Types.Harrison.FOL + ( TermType(..) + , FOL(..) + , Function(..) + ) where + +-- Baz +import qualified Data.Logic.Types.Common ({- instance Variable String -}) +-- Bar + diff --git a/tests/examples/ghc92/Field.hs b/tests/examples/ghc92/Field.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Field.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-| + Module : AERN2.MP.Ball.Field + Description : Field operations on arbitrary precision dyadic balls + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Field operations on arbitrary precision dyadic balls +-} +module AERN2.MP.Ball.Field +(mulBalls, mulByEndpoints) +where + +import MixedTypesNumPrelude +-- import qualified Prelude as P + +import qualified Numeric.CollectErrors as CN + +import AERN2.Normalize + + +mulByEndpoints :: MPBall -> MPBall -> MPBall +mulByEndpoints b1 b2 = + fromEndpoints l r + where + (l,r) + | 0 <= l1 && 0 <= l2 = (l1*.l2, r1*^r2) -- 0 <= l1 <= r1, 0 <= l2 <= r2 + | r1 <= 0 && r2 <= 0 = (r1*.r2, l1*^l2) -- l1 <= r1 <= 0, l2 <= r2 <= 0 + | 0 <= l1 && r2 <= 0 = (r1*.l2, l1*^r2) -- l2 <= r2 <= 0 <= l1 <= r1 + | r1 <= 0 && 0 <= l2 = (l1*.r2, r1*^l2) -- l1 <= r1 <= 0 <= l2 <= r2 + | l1 < 0 && 0 < r1 && 0 <= l2 = (l1*.r2, r1*^r2) -- l1 < 0 < r1, 0 <= l2 <= r2 + | l1 < 0 && 0 < r1 && r2 <= 0 = (r1*.l2, l1*^l2) -- l1 < 0 < r1, l2 <= r2 <= 0 + | l2 < 0 && 0 < r2 && 0 <= l1 = (l2*.r1, r2*^r1) -- l2 < 0 < r2, 0 <= l1 <= r1 + | l2 < 0 && 0 < r2 && r1 <= 0 = (r2*.l1, l2*^l1) -- l2 < 0 < r2, l1 <= r1 <= 0 + | otherwise = -- l1 < 0 < r1, l2 < 0 < r2 + ((l1 *. r2) `min` (r1 *. l2) + ,(l1 *^ l2) `max` (r1 *^ r2)) + (l1,r1) = endpoints b1 + (l2,r2) = endpoints b2 + + diff --git a/tests/examples/ghc92/Group.hs b/tests/examples/ghc92/Group.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Group.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE RebindableSyntax,QuasiQuotes #-} + +-- | This module contains most of the math types not directly related to linear algebra +-- +-- FIXME: there is probably a better name for this +module SubHask.Algebra.Group + where + +import Control.Monad +import qualified Prelude as P + +import SubHask.Algebra +import SubHask.Category +import SubHask.Mutable +import SubHask.SubType +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Deriving + +------------------------------------------------------------------------------- +-- non-negative objects + +newtype NonNegative t = NonNegative { unNonNegative :: t } + +deriveHierarchy ''NonNegative [ ''Enum, ''Boolean, ''Rig, ''Metric ] + +instance (Ord t, Group t) => Cancellative (NonNegative t) where + (NonNegative t1)-(NonNegative t2) = if diff>zero + then NonNegative diff + else NonNegative zero + where + diff=t1-t2 + +------------------- + +{- +newtype a +> b = HomHask { unHomHask :: a -> b } +infixr +> + +unsafeHomHask2 :: (a -> b -> c) -> (a +> b +> c) +unsafeHomHask2 f = HomHask (\a -> HomHask $ \b -> f a b) + +instance Category (+>) where + type ValidCategory (+>) a = () + id = HomHask id + (HomHask a).(HomHask b) = HomHask $ a.b + +instance Sup (+>) (->) (->) +instance Sup (->) (+>) (->) +instance (+>) <: (->) where + embedType_ = Embed2 unHomHask + +instance Monoidal (+>) where + type Tensor (+>) = (,) + tensor = unsafeHomHask2 $ \a b -> (a,b) + +instance Braided (+>) where + braid = HomHask $ \(a,b) -> (b,a) + unbraid = braid + +instance Closed (+>) where + curry (HomHask f) = HomHask $ \ a -> HomHask $ \b -> f (a,b) + uncurry (HomHask f) = HomHask $ \ (a,b) -> unHomHask (f a) b + +mkSubtype [t|Int|] [t|Integer|] 'toInteger + +[subhask| +poop :: (Semigroup' g, Ring g) => g +> g +poop = (+:1) +|] + +class Semigroup' a where + (+:) :: a +> a +> a + +instance Semigroup' Int where (+:) = unsafeHomHask2 (+) + +instance Semigroup' [a] where (+:) = unsafeHomHask2 (+) + +f :: Integer +> Integer +f = HomHask $ \i -> i+1 + +n1 = NonNegative 5 :: NonNegative Int +n2 = NonNegative 3 :: NonNegative Int +i1 = 5 :: Int +i2 = 3 :: Int +j1 = 5 :: Integer +j2 = 3 :: Integer +-} + +------------------------------------------------------------------------------- +-- integers modulo n + +-- | Maps members of an equivalence class into the "canonical" element. +class Quotient a (b::k) where + mkQuotient :: a -> a/b + +-- | The type of equivalence classes created by a mod b. +newtype (/) (a :: *) (b :: k) = Mod a + +-- mkDefaultMutable [t| forall a b. a/b |] + +-- newtype instance Mutable m (a/b) = Mutable_Mod (Mutable m a) + +instance (Quotient a b, Arbitrary a) => Arbitrary (a/b) where + arbitrary = liftM mkQuotient arbitrary + +deriveHierarchyFiltered ''(/) [ ''Eq_, ''P.Ord ] [''Arbitrary] + +instance (Semigroup a, Quotient a b) => Semigroup (a/b) where + (Mod z1) + (Mod z2) = mkQuotient $ z1 + z2 + +instance (Abelian a, Quotient a b) => Abelian (a/b) + +instance (Monoid a, Quotient a b) => Monoid (a/b) + where zero = Mod zero + +instance (Cancellative a, Quotient a b) => Cancellative (a/b) where + (Mod i1)-(Mod i2) = mkQuotient $ i1-i2 + +instance (Group a, Quotient a b) => Group (a/b) where + negate (Mod i) = mkQuotient $ negate i + +instance (Rg a, Quotient a b) => Rg (a/b) where + (Mod z1)*(Mod z2) = mkQuotient $ z1 * z2 + +instance (Rig a, Quotient a b) => Rig (a/b) where + one = Mod one + +instance (Ring a, Quotient a b) => Ring (a/b) where + fromInteger i = mkQuotient $ fromInteger i + +type instance ((a/b)> Module (a/b) where + (Mod a) .* r = mkQuotient $ a .* r + +-- | The type of integers modulo n +type Z (n::Nat) = Integer/n + +instance KnownNat n => Quotient Int n + where + mkQuotient i = Mod $ i `P.mod` (fromIntegral $ natVal (Proxy::Proxy n)) + +instance KnownNat n => Quotient Integer n + where + mkQuotient i = Mod $ i `P.mod` (natVal (Proxy::Proxy n)) + +-- | Extended Euclid's algorithm is used to calculate inverses in modular arithmetic +extendedEuclid :: (Eq t, Integral t) => t -> t -> (t,t,t,t,t,t) +extendedEuclid a b = go zero one one zero b a + where + go s1 s0 t1 t0 r1 r0 = if r1==zero + then (s1,s0,t1,t0,undefined,r0) + else go s1' s0' t1' t0' r1' r0' + where + q = r0 `div` r1 + (r0', r1') = (r1,r0-q*r1) + (s0', s1') = (s1,s0-q*s1) + (t0', t1') = (t1,t0-q*t1) + +------------------------------------------------------------------------------- +-- example: Galois field + +-- | @Galois p k@ is the type of integers modulo p^k, where p is prime. +-- All finite fields have this form. +-- +-- See wikipedia for more details. +-- +-- FIXME: Many arithmetic operations over Galois Fields can be implemented more efficiently than the standard operations. +-- See . +newtype Galois (p::Nat) (k::Nat) = Galois (Z (p^k)) + +type instance Galois p k >< Integer = Galois p k + +deriveHierarchy ''Galois [''Eq_,''Ring] + +instance KnownNat (p^k) => Module (Galois p k) where + z .* i = Galois (Mod i) * z + +instance (Prime p, KnownNat (p^k)) => Field (Galois p k) where + reciprocal (Galois (Mod i)) = Galois $ mkQuotient $ t + where + (_,_,_,t,_,_) = extendedEuclid n i + n = natVal (Proxy::Proxy (p^k)) + +------------------- + +class Prime (n::Nat) +instance Prime 1 +instance Prime 2 +instance Prime 3 +instance Prime 5 +instance Prime 7 +instance Prime 11 +instance Prime 13 +instance Prime 17 +instance Prime 19 +instance Prime 23 + +------------------------------------------------------------------------------- +-- the symmetric group + +-- | The symmetric group is one of the simplest and best studied finite groups. +-- It is efficiently implemented as a "BijectiveT SparseFunction (Z n) (Z n)". +-- See + +-- newtype Sym (n::Nat) = Sym (BijectiveT SparseFunction (Z n) (Z n)) +-- +-- instance KnownNat n => Monoid (Sym n) where +-- zero = Sym id +-- (Sym s1)+(Sym s2) = Sym $ s1.s2 +-- +-- instance KnownNat n => Group (Sym n) where +-- negate (Sym s) = Sym $ inverse s + +------------------------------------------------------------------------------- +-- | The GrothendieckGroup is a general way to construct groups from cancellative semigroups. +-- +-- FIXME: How should this be related to the Ratio type? +-- +-- See for more details. +data GrothendieckGroup g where + GrotheindieckGroup :: Cancellative g => g -> GrothendieckGroup g + +------------------------------------------------------------------------------- +-- the vedic square + +-- | The Vedic Square always forms a monoid, +-- and sometimes forms a group depending on the value of "n". +-- (The type system isn't powerful enough to encode these special cases.) +-- +-- See for more detail. +newtype VedicSquare (n::Nat) = VedicSquare (Z n) + +deriveHierarchy ''VedicSquare [''Eq_] + +instance KnownNat n => Semigroup (VedicSquare n) where + (VedicSquare v1)+(VedicSquare v2) = VedicSquare $ v1*v2 + +instance KnownNat n => Monoid (VedicSquare n) where + zero = VedicSquare one + +------------------------------------------------------------------------------ +-- Minkowski addition + +-- | TODO: implement +-- More details available at . + diff --git a/tests/examples/ghc92/LinearArrow.hs b/tests/examples/ghc92/LinearArrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/LinearArrow.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LinearTypes, DataKinds, UnicodeSyntax #-} + +module LinearArrow where + +import GHC.Types (Multiplicity(One, Many)) + +n1 :: a %1 -> b +n1 = undefined + +u1 :: a %1 → b +u1 = undefined + +n2 :: a %(Many) -> b +n2 = undefined + +u2 :: a %(Many) → b +u2 = undefined + +m3 :: a ⊸ b +m3 = undefined + +n4 :: a %p -> b +n4 = undefined + +u4 :: a %p → b +u4 = undefined diff --git a/tests/examples/ghc92/MatchSemis.hs b/tests/examples/ghc92/MatchSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/MatchSemis.hs @@ -0,0 +1,5 @@ +module MatchSemis where +{ +a 0 = 1; +a _ = 2; +} diff --git a/tests/examples/ghc92/Observer.hs b/tests/examples/ghc92/Observer.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Observer.hs @@ -0,0 +1,325 @@ +-- | Observer Effects +-- +-- This module supports the implementation of observerRegistry and observables. Expected use +-- case is event propagation. +-- +-- The observable event sources and the observers are usually server processes for a +-- protocol that embeds the 'ObserverRegistry' and 'Observer' 'Pdu's respectively. +-- +-- A generic FIFO queue based observer can be found in "Control.Eff.Concurrent.Protocol.Observer.Queue". +-- +-- @since 0.16.0 +module Control.Eff.Concurrent.Protocol.Observer + ( Observer (..), + ObservationSink (), + IsObservable, + CanObserve, + Pdu (RegisterObserver, ForgetObserver, Observed), + registerObserver, + forgetObserver, + forgetObserverUnsafe, + ObserverRegistry (..), + ObserverRegistryState, + observerRegistryNotify, + evalObserverRegistryState, + emptyObserverRegistry, + observerRegistryHandlePdu, + observerRegistryRemoveProcess, + ) +where + +import Control.DeepSeq (NFData (rnf)) +import Control.Eff +import Control.Eff.Concurrent.Process +import Control.Eff.Concurrent.Protocol +import Control.Eff.Concurrent.Protocol.Client +import Control.Eff.Concurrent.Protocol.Wrapper (Request (Cast)) +import Control.Eff.Log +import Control.Eff.State.Strict +import Control.Lens +import Control.Monad +import Data.Dynamic +import Data.Kind +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Proxy +import Data.Semigroup +import GHC.Generics +import GHC.Stack + +-- * Observers + +-- ** Observables + +-- | A /protocol/ to communicate 'Observed' events from a sources to many sinks. +-- +-- A sink is any process that serves a protocol with a 'Pdu' instance that embeds +-- the 'Observer' Pdu via an 'HasPduPrism' instance. +-- +-- This type has /dual use/, for one it serves as type-index for 'Pdu', i.e. +-- 'HasPdu' respectively, and secondly it contains an 'ObservationSink' and +-- a 'MonitorReference'. +-- +-- The 'ObservationSink' is used to serialize and send the 'Observed' events, +-- while the 'ProcessId' serves as key for internal maps. +-- +-- @since 0.28.0 +newtype Observer event + = MkObserver (Arg ProcessId (ObservationSink event)) + deriving (Eq, Ord, Typeable) + +instance ToTypeLogMsg event => ToLogMsg (Observer event) where + toLogMsg (MkObserver (Arg t _)) = toTypeLogMsg (Proxy @(Observer event)) <> toLogMsg t + +instance ToTypeLogMsg event => ToTypeLogMsg (Observer event) where + toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer" + +instance NFData (Observer event) where + rnf (MkObserver (Arg x y)) = rnf x `seq` rnf y + +instance (Tangible event) => HasPdu (Observer event) where + data Pdu (Observer event) r where + Observed :: event -> Pdu (Observer event) 'Asynchronous + deriving (Typeable) + +instance NFData event => NFData (Pdu (Observer event) r) where + rnf (Observed event) = rnf event + +instance ToLogMsg event => ToLogMsg (Pdu (Observer event) r) where + toLogMsg (Observed event) = + packLogMsg "observed: " <> toLogMsg event + +-- | The Information necessary to wrap an 'Observed' event to a process specific +-- message, e.g. the embedded 'Observer' 'Pdu' instance, and the 'MonitorReference' of +-- the destination process. +-- +-- @since 0.28.0 +data ObservationSink event = MkObservationSink + { _observerSerializer :: Serializer (Pdu (Observer event) 'Asynchronous), + _observerMonitorReference :: MonitorReference + } + deriving (Generic, Typeable) + +instance NFData (ObservationSink event) where + rnf (MkObservationSink s p) = s `seq` rnf p + +-- | Convenience type alias. +-- +-- @since 0.28.0 +type IsObservable eventSource event = + ( Tangible event, + Embeds eventSource (ObserverRegistry event), + HasPdu eventSource, + ToTypeLogMsg event, + ToLogMsg event + ) + +-- | Convenience type alias. +-- +-- @since 0.28.0 +type CanObserve eventSink event = + ( Tangible event, + Embeds eventSink (Observer event), + HasPdu eventSink + ) + +-- | And an 'Observer' to the set of recipients for all observations reported by 'observerRegistryNotify'. +-- Note that the observerRegistry are keyed by the observing process, i.e. a previous entry for the process +-- contained in the 'Observer' is overwritten. If you want multiple entries for a single process, just +-- combine several filter functions. +-- +-- @since 0.16.0 +registerObserver :: + forall event eventSink eventSource r q. + ( HasProcesses r q, + TangiblePdu eventSource 'Asynchronous, + IsObservable eventSource event, + TangiblePdu eventSink 'Asynchronous, + CanObserve eventSink event + ) => + Endpoint eventSource -> + Endpoint eventSink -> + Eff r () +registerObserver eventSource eventSink = + cast eventSource (RegisterObserver serializer (eventSink ^. fromEndpoint)) + where + serializer = + MkSerializer + ( toMessage + . Cast + . embedPdu @eventSink @(Observer event) @('Asynchronous) + ) + +-- | Send the 'ForgetObserver' message +-- +-- @since 0.16.0 +forgetObserver :: + forall event eventSink eventSource r q. + ( HasProcesses r q, + TangiblePdu eventSource 'Asynchronous, + IsObservable eventSource event + ) => + Endpoint eventSource -> + Endpoint eventSink -> + Eff r () +forgetObserver eventSource eventSink = + forgetObserverUnsafe @event @eventSource eventSource (eventSink ^. fromEndpoint) + +-- | Send the 'ForgetObserver' message, use a raw 'ProcessId' as parameter. +-- +-- @since 0.28.0 +forgetObserverUnsafe :: + forall event eventSource r q. + ( HasProcesses r q, + TangiblePdu eventSource 'Asynchronous, + IsObservable eventSource event + ) => + Endpoint eventSource -> + ProcessId -> + Eff r () +forgetObserverUnsafe eventSource eventSink = + cast eventSource (ForgetObserver @event eventSink) + +-- ** Observer Support Functions + +-- * Managing Observers + +-- | A protocol for managing 'Observer's, encompassing registration and de-registration of +-- 'Observer's. +-- +-- @since 0.28.0 +data ObserverRegistry (event :: Type) = MkObserverRegistry + {_observerRegistry :: Map ProcessId (ObservationSink event)} + deriving (Typeable) + +instance ToTypeLogMsg event => ToTypeLogMsg (ObserverRegistry event) where + toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer_registry_event" + +instance (Tangible event) => HasPdu (ObserverRegistry event) where + data Pdu (ObserverRegistry event) r where + -- | This message denotes that the given 'Observer' should receive observations until 'ForgetObserver' is + -- received. + -- + -- @since 0.28.0 + RegisterObserver :: Serializer (Pdu (Observer event) 'Asynchronous) -> ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous + -- | This message denotes that the given 'Observer' should not receive observations anymore. + -- + -- @since 0.16.1 + ForgetObserver :: ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous + -- -- | This message denotes that a monitored process died + -- -- + -- -- @since 0.28.0 + -- ObserverMightBeDown :: MonitorReference -> Pdu (ObserverRegistry event) ( 'Synchronous Bool) + deriving (Typeable) + +instance NFData (Pdu (ObserverRegistry event) r) where + rnf (RegisterObserver ser pid) = rnf ser `seq` rnf pid + rnf (ForgetObserver pid) = rnf pid + +instance ToTypeLogMsg event => ToLogMsg (Pdu (ObserverRegistry event) r) where + toLogMsg (RegisterObserver _ser pid) = packLogMsg "register " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid + toLogMsg (ForgetObserver pid) = packLogMsg "forget " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid + +-- ** Protocol for integrating 'ObserverRegistry' into processes. + +-- | Provide the implementation for the 'ObserverRegistry' Protocol, this handled 'RegisterObserver' and 'ForgetObserver' +-- messages. It also adds the 'ObserverRegistryState' constraint to the effect list. +-- +-- @since 0.28.0 +observerRegistryHandlePdu :: + forall event q r. + ( HasCallStack, + ToTypeLogMsg event, + HasProcesses r q, + Member (ObserverRegistryState event) r, + Member Logs r + ) => + Pdu (ObserverRegistry event) 'Asynchronous -> + Eff r () +observerRegistryHandlePdu = \case + RegisterObserver ser pid -> do + monRef <- monitor pid + let sink = MkObservationSink ser monRef + observer = MkObserver (Arg pid sink) + modify @(ObserverRegistry event) (over observerRegistry (Map.insert pid sink)) + os <- get @(ObserverRegistry event) + logDebug + (LABEL "registered" observer) + ( LABEL + "current number of observers" -- TODO put this info into the process details + (Map.size (view observerRegistry os)) + ) + ForgetObserver ob -> do + wasRemoved <- observerRegistryRemoveProcess @event ob + unless wasRemoved $ + logDebug (LABEL "unknown observer " ob) + +-- | Remove the entry in the 'ObserverRegistry' for the 'ProcessId' +-- and return 'True' if there was an entry, 'False' otherwise. +-- +-- @since 0.28.0 +observerRegistryRemoveProcess :: + forall event q r. + ( HasCallStack, + ToTypeLogMsg event, + HasProcesses r q, + Member (ObserverRegistryState event) r, + Member Logs r + ) => + ProcessId -> + Eff r Bool +observerRegistryRemoveProcess ob = do + mSink <- view (observerRegistry . at ob) <$> get @(ObserverRegistry event) + modify @(ObserverRegistry event) (observerRegistry . at ob .~ Nothing) + os <- get @(ObserverRegistry event) + maybe + (pure False) + (foundIt os) + mSink + where + foundIt os sink@(MkObservationSink _ monRef) = do + demonitor monRef + logDebug + (LABEL "removed" (MkObserver $ Arg ob sink)) + (LABEL "current number of observers" (Map.size (view observerRegistry os))) + pure True + +-- | Keep track of registered 'Observer's. +-- +-- Handle the 'ObserverRegistryState' effect, i.e. run 'evalState' on an 'emptyObserverRegistry'. +-- +-- @since 0.28.0 +evalObserverRegistryState :: Eff (ObserverRegistryState event ': r) a -> Eff r a +evalObserverRegistryState = evalState emptyObserverRegistry + +-- | The empty 'ObserverRegistryState' +-- +-- @since 0.28.0 +emptyObserverRegistry :: ObserverRegistry event +emptyObserverRegistry = MkObserverRegistry Map.empty + +-- | Alias for the effect that contains the observers managed by 'evalObserverRegistryState' +type ObserverRegistryState event = State (ObserverRegistry event) + +-- | An 'Iso' for the 'Map' used internally. +observerRegistry :: Iso' (ObserverRegistry event) (Map ProcessId (ObservationSink event)) +observerRegistry = iso _observerRegistry MkObserverRegistry + +-- | Report an observation to all observers. +-- The process needs to 'evalObserverRegistryState' and to 'observerRegistryHandlePdu'. +-- +-- @since 0.28.0 +observerRegistryNotify :: + forall event r q. + ( HasProcesses r q, + Member (ObserverRegistryState event) r + ) => + event -> + Eff r () +observerRegistryNotify observation = do + os <- view observerRegistry <$> get + mapM_ notifySomeObserver (Map.assocs os) + where + notifySomeObserver (destination, (MkObservationSink serializer _)) = + sendAnyMessage destination (runSerializer serializer (Observed observation)) + diff --git a/tests/examples/ghc92/Parse.hs b/tests/examples/ghc92/Parse.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/Parse.hs @@ -0,0 +1,5 @@ + +module Language.Python.Internal.Parse where + +compoundStatement pIndent indentBefore = + do; a <- doAsync; fundef diff --git a/tests/examples/ghc92/PostgreSQL.hs b/tests/examples/ghc92/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/PostgreSQL.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Drifter.PostgreSQL + ( PGMigration + , Method(..) + , DBConnection(..) + , ChangeHistory(..) + , runMigrations + , getChangeHistory + , getChangeNameHistory + ) where + +------------------------------------------------------------------------------- +import Control.Applicative as A +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Except +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Time +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.SqlQQ +import Drifter +------------------------------------------------------------------------------- + + +data PGMigration + + +data instance Method PGMigration = MigrationQuery Query + -- ^ Run a query against the database + | MigrationCode (Connection -> IO (Either String ())) + -- ^ Run any arbitrary IO code + + +data instance DBConnection PGMigration = DBConnection PGMigrationConnection + + +data PGMigrationConnection = PGMigrationConnection (Set ChangeName) Connection + + +instance Drifter PGMigration where + migrateSingle (DBConnection migrationConn) change = do + runExceptT $ migrateChange migrationConn change + + +------------------------------------------------------------------------------- +-- Change History Tracking +------------------------------------------------------------------------------- +newtype ChangeId = ChangeId Int deriving (Eq, Ord, Show, FromField) + + +data ChangeHistory = ChangeHistory { + histId :: ChangeId + , histName :: ChangeName + , histDescription :: Maybe Description + , histTime :: UTCTime + } deriving (Show) + + +instance Eq ChangeHistory where + a == b = (histName a) == (histName b) + + +instance Ord ChangeHistory where + compare a b = compare (histId a) (histId b) + + +instance FromRow ChangeHistory where + fromRow = ChangeHistory <$> field + <*> (ChangeName <$> field) + <*> field + <*> field + + +------------------------------------------------------------------------------- +-- Queries +------------------------------------------------------------------------------- +bootstrapQ :: Query +bootstrapQ = [sql| +CREATE TABLE IF NOT EXISTS schema_migrations ( + id serial NOT NULL, + name text NOT NULL, + description text, + time timestamptz NOT NULL DEFAULT now(), + + PRIMARY KEY (id), + UNIQUE (name) +); +|] + + +------------------------------------------------------------------------------- +changeHistoryQ :: Query +changeHistoryQ = + "SELECT id, name, description, time FROM schema_migrations ORDER BY id;" + + +------------------------------------------------------------------------------- +changeNameHistoryQ :: Query +changeNameHistoryQ = + "SELECT name FROM schema_migrations ORDER BY id;" + + +------------------------------------------------------------------------------- +insertLogQ :: Query +insertLogQ = + "INSERT INTO schema_migrations (name, description, time) VALUES (?, ?, ?);" + + +------------------------------------------------------------------------------- +migrateChange :: PGMigrationConnection -> Change PGMigration -> ExceptT String IO () +migrateChange (PGMigrationConnection hist c) ch@Change{..} = do + if Set.member changeName hist + then lift $ putStrLn $ "Skipping: " ++ show (changeNameText changeName) + else do + runMethod c changeMethod + logChange c ch + lift $ putStrLn $ "Committed: " ++ show changeName + + +------------------------------------------------------------------------------- +runMethod :: Connection -> Method PGMigration -> ExceptT String IO () +runMethod c (MigrationQuery q) = + void $ ExceptT $ (Right <$> execute_ c q) `catches` errorHandlers +runMethod c (MigrationCode f) = + ExceptT $ f c `catches` errorHandlers + + + ------------------------------------------------------------------------------- +logChange :: Connection -> Change PGMigration -> ExceptT String IO () +logChange c Change{..} = do + now <- lift getCurrentTime + void $ ExceptT $ (Right <$> go now) `catches` errorHandlers + where + go now = execute c insertLogQ (changeNameText changeName, changeDescription, now) + + +------------------------------------------------------------------------------- +errorHandlers :: [Handler (Either String b)] +errorHandlers = [ Handler (\(ex::SqlError) -> return $ Left $ show ex) + , Handler (\(ex::FormatError) -> return $ Left $ show ex) + , Handler (\(ex::ResultError) -> return $ Left $ show ex) + , Handler (\(ex::QueryError) -> return $ Left $ show ex) + ] + + +------------------------------------------------------------------------------- +-- | Takes a connection and builds the state to thread throughout the migration. +-- This includes bootstrapping the migration tables and collecting all the +-- migrations that have already been committed. +makePGMigrationConnection :: Connection -> IO PGMigrationConnection +makePGMigrationConnection conn = do + void $ execute_ conn bootstrapQ + hist <- getChangeNameHistory conn + return $ PGMigrationConnection (Set.fromList hist) conn + + +------------------------------------------------------------------------------- +-- | Takes the list of all migrations, removes the ones that have +-- already run and runs them. Use this instead of 'migrate'. +runMigrations :: Connection -> [Change PGMigration] -> IO (Either String ()) +runMigrations conn changes = do + begin conn + migrationConn <- makePGMigrationConnection conn + res <- migrate (DBConnection migrationConn) changes `onException` rollback conn + case res of + Right _ -> commit conn + Left _ -> rollback conn + return res + + +------------------------------------------------------------------------------- +-- | Get all changes from schema_migrations table for all the migrations that +-- have previously run. +getChangeHistory :: Connection -> IO [ChangeHistory] +getChangeHistory conn = query_ conn changeHistoryQ + + +------------------------------------------------------------------------------- +-- | Get just the names of all changes from schema_migrations for migrations +-- that have previously run. +getChangeNameHistory :: Connection -> IO [ChangeName] +getChangeNameHistory conn = fmap (\(Only nm) -> ChangeName nm) + A.<$> query_ conn changeNameHistoryQ + diff --git a/tests/examples/ghc92/RList.hs b/tests/examples/ghc92/RList.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/RList.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE TypeOperators, EmptyDataDecls, RankNTypes #-} +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, KindSignatures #-} +{-# LANGUAGE GADTs, TypeInType, PatternGuards #-} + +-- | +-- Module : Data.Type.RList +-- Copyright : (c) 2016 Edwin Westbrook +-- +-- License : BSD3 +-- +-- Maintainer : westbrook@galois.com +-- Stability : experimental +-- Portability : GHC +-- +-- A /right list/, or 'RList', is a list where cons adds to the end, or the +-- right-hand side, of a list. This is useful conceptually for contexts of +-- name-bindings, where the most recent name-binding is intuitively at the end +-- of the context. + +module Data.Type.RList where + +import Prelude hiding (map, foldr) +import Data.Kind +import Data.Type.Equality +import Data.Proxy (Proxy(..)) +import Data.Functor.Constant +import Data.Typeable + +------------------------------------------------------------------------------- +-- * Right-lists as a datatype +------------------------------------------------------------------------------- + +-- | A form of lists where elements are added to the right instead of the left +data RList a + = RNil + | (RList a) :> a + +-- | Append two 'RList's at the type level +type family ((r1 :: RList k) :++: (r2 :: RList k)) :: RList k +infixr 5 :++: +type instance (r :++: 'RNil) = r +type instance (r1 :++: (r2 ':> a)) = (r1 :++: r2) ':> a + +------------------------------------------------------------------------------- +-- * Proofs of membership in a type-level list +------------------------------------------------------------------------------- + +{-| + A @Member ctx a@ is a \"proof\" that the type @a@ is in the type + list @ctx@, meaning that @ctx@ equals + +> t0 ':>' a ':>' t1 ':>' ... ':>' tn + + for some types @t0,t1,...,tn@. +-} +data Member (ctx :: RList k1) (a :: k2) where + Member_Base :: Member (ctx :> a) a + Member_Step :: Member ctx a -> Member (ctx :> b) a + deriving Typeable + +instance Show (Member r a) where + showsPrec p = showsPrecMember (p > 10) where + showsPrecMember :: Bool -> Member ctx a -> ShowS + showsPrecMember _ Member_Base = showString "Member_Base" + showsPrecMember p (Member_Step prf) = showParen p $ + showString "Member_Step" . showsPrec 10 prf + +instance TestEquality (Member ctx) where + testEquality Member_Base Member_Base = Just Refl + testEquality (Member_Step memb1) (Member_Step memb2) + | Just Refl <- testEquality memb1 memb2 + = Just Refl + testEquality _ _ = Nothing + +instance Eq (Member ctx a) where + Member_Base == Member_Base = True + (Member_Step memb1) == (Member_Step memb2) = memb1 == memb2 + _ == _ = False + +--toEq :: Member (Nil :> a) b -> b :~: a +--toEq Member_Base = Refl +--toEq _ = error "Should not happen! (toEq)" + +-- | Weaken a 'Member' proof by prepending another context to the context it +-- proves membership in +weakenMemberL :: Proxy r1 -> Member r2 a -> Member (r1 :++: r2) a +weakenMemberL _ Member_Base = Member_Base +weakenMemberL tag (Member_Step mem) = Member_Step (weakenMemberL tag mem) + + +------------------------------------------------------------ +-- * Proofs that one list equals the append of two others +------------------------------------------------------------ + +{-| + An @Append ctx1 ctx2 ctx@ is a \"proof\" that @ctx = ctx1 ':++:' ctx2@. +-} +data Append ctx1 ctx2 ctx where + Append_Base :: Append ctx RNil ctx + Append_Step :: Append ctx1 ctx2 ctx -> Append ctx1 (ctx2 :> a) (ctx :> a) + +-- | Make an 'Append' proof from any 'RAssign' vector for the second +-- argument of the append. +mkAppend :: RAssign f c2 -> Append c1 c2 (c1 :++: c2) +mkAppend MNil = Append_Base +mkAppend (c :>: _) = Append_Step (mkAppend c) + +-- | A version of 'mkAppend' that takes in a 'Proxy' argument. +mkMonoAppend :: Proxy c1 -> RAssign f c2 -> Append c1 c2 (c1 :++: c2) +mkMonoAppend _ = mkAppend + +-- | The inverse of 'mkAppend', that builds an 'RAssign' from an 'Append' +proxiesFromAppend :: Append c1 c2 c -> RAssign Proxy c2 +proxiesFromAppend Append_Base = MNil +proxiesFromAppend (Append_Step a) = proxiesFromAppend a :>: Proxy + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + +{-| + An @RAssign f r@ an assignment of an @f a@ for each @a@ in the 'RList' @r@ +-} +data RAssign (f :: k -> *) (c :: RList k) where + MNil :: RAssign f RNil + (:>:) :: RAssign f c -> f a -> RAssign f (c :> a) + +-- | Create an empty 'RAssign' vector. +empty :: RAssign f RNil +empty = MNil + +-- | Create a singleton 'RAssign' vector. +singleton :: f a -> RAssign f (RNil :> a) +singleton x = MNil :>: x + +-- | Look up an element of an 'RAssign' vector using a 'Member' proof +get :: Member c a -> RAssign f c -> f a +get Member_Base (_ :>: x) = x +get (Member_Step mem') (mc :>: _) = get mem' mc + +-- | Heterogeneous type application, including a proof that the input kind of +-- the function equals the kind of the type argument +data HApply (f :: k1 -> Type) (a :: k2) where + HApply :: forall k (f :: k -> Type) (a :: k). f a -> HApply f a + +-- | Look up an element of an 'RAssign' vector using a 'Member' proof at what +-- GHC thinks might be a different kind, i.e., heterogeneously +hget :: forall k1 k2 (f :: k1 -> Type) (c :: RList k1) (a :: k2). + Member c a -> RAssign f c -> HApply f a +hget Member_Base (_ :>: x) = HApply x +hget (Member_Step mem') (mc :>: _) = hget mem' mc + +-- | Modify an element of an 'RAssign' vector using a 'Member' proof. +modify :: Member c a -> (f a -> f a) -> RAssign f c -> RAssign f c +modify Member_Base f (xs :>: x) = xs :>: f x +modify (Member_Step mem') f (xs :>: x) = modify mem' f xs :>: x + +-- | Set an element of an 'RAssign' vector using a 'Member' proof. +set :: Member c a -> f a -> RAssign f c -> RAssign f c +set memb x = modify memb (const x) + +-- | Test if an object is in an 'RAssign', returning a 'Member' proof if it is +memberElem :: TestEquality f => f a -> RAssign f ctx -> Maybe (Member ctx a) +memberElem _ MNil = Nothing +memberElem x (_ :>: y) | Just Refl <- testEquality x y = Just Member_Base +memberElem x (xs :>: _) = fmap Member_Step $ memberElem x xs + +-- | Map a function on all elements of an 'RAssign' vector. +map :: (forall x. f x -> g x) -> RAssign f c -> RAssign g c +map _ MNil = MNil +map f (mc :>: x) = map f mc :>: f x + +-- | An alternate name for 'map' that does not clash with the prelude +mapRAssign :: (forall x. f x -> g x) -> RAssign f c -> RAssign g c +mapRAssign = map + +-- | Map a binary function on all pairs of elements of two 'RAssign' vectors. +map2 :: (forall x. f x -> g x -> h x) -> + RAssign f c -> RAssign g c -> RAssign h c +map2 _ MNil MNil = MNil +map2 f (xs :>: x) (ys :>: y) = map2 f xs ys :>: f x y + +-- | Take the tail of an 'RAssign' +tail :: RAssign f (ctx :> a) -> RAssign f ctx +tail (xs :>: _) = xs + +-- | Convert a monomorphic 'RAssign' to a list +toList :: RAssign (Constant a) c -> [a] +toList = mapToList getConstant + +-- | Map a function with monomorphic output type across an 'RAssign' to create a +-- standard list: +-- +-- > mapToList f = toList . map (Constant . f) +mapToList :: (forall a. f a -> b) -> RAssign f ctx -> [b] +mapToList _ MNil = [] +mapToList f (xs :>: x) = mapToList f xs ++ [f x] + +-- | Append two 'RAssign' vectors. +append :: RAssign f c1 -> RAssign f c2 -> RAssign f (c1 :++: c2) +append mc MNil = mc +append mc1 (mc2 :>: x) = append mc1 mc2 :>: x + +-- | Perform a right fold across an 'RAssign' +foldr :: (forall a. f a -> r -> r) -> r -> RAssign f ctx -> r +foldr _ r MNil = r +foldr f r (xs :>: x) = f x $ foldr f r xs + +-- | Split an 'RAssign' vector into two pieces. The first argument is a +-- phantom argument that gives the form of the first list piece. +split :: (c ~ (c1 :++: c2)) => prx c1 -> + RAssign any c2 -> RAssign f c -> (RAssign f c1, RAssign f c2) +split _ MNil mc = (mc, MNil) +split _ (any :>: _) (mc :>: x) = (mc1, mc2 :>: x) + where (mc1, mc2) = split Proxy any mc + +-- | Create a vector of proofs that each type in @c@ is a 'Member' of @c@. +members :: RAssign f c -> RAssign (Member c) c +members MNil = MNil +members (c :>: _) = map Member_Step (members c) :>: Member_Base + +-- | A type-class which ensures that ctx is a valid context, i.e., has +-- | the form (RNil :> t1 :> ... :> tn) for some types t1 through tn +class TypeCtx ctx where + typeCtxProxies :: RAssign Proxy ctx + +instance TypeCtx RNil where + typeCtxProxies = MNil + +instance TypeCtx ctx => TypeCtx (ctx :> a) where + typeCtxProxies = typeCtxProxies :>: Proxy + diff --git a/tests/examples/ghc92/ScopesBug.hs b/tests/examples/ghc92/ScopesBug.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/ScopesBug.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} + +module ScopesBug where + +data Proxy (a :: k) = Proxy +data Con k (a :: k) = Con (Proxy a) + +tyApp :: Con k a -> Proxy a +tyApp (Con @kx @ax (x :: Proxy ax)) = x :: Proxy (ax :: kx) + diff --git a/tests/examples/ghc92/StringRef.hs b/tests/examples/ghc92/StringRef.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/StringRef.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-} +{-# LANGUAGE LambdaCase #-} + +module Data.Binary.StringRef + ( ListOfStringable(..) + , StringReferencingBinary(..) + , IntLen(..) + , ls_encode + , ls_decode + ) where + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import Control.Monad +import Control.Applicative ((<$>)) +import Data.List +import Data.ByteString.Lazy (ByteString) +import qualified Data.MyText as T +import Data.MyText (Text, decodeUtf8, encodeUtf8) +import Debug.Trace + +class StringReferencingBinary a => ListOfStringable a where + listOfStrings :: a -> [Text] + +-- | An extended version of Binary that passes the list of strings of the +-- previous sample +class StringReferencingBinary a where + ls_put :: [Text] -> a -> Put + ls_get :: [Text] -> Get a + +------------------------------------------------------------------------ +-- Instances for the first few tuples + +instance (StringReferencingBinary a, StringReferencingBinary b) => StringReferencingBinary (a,b) where + ls_put strs (a,b) = ls_put strs a >> ls_put strs b + ls_get strs = liftM2 (,) (ls_get strs) (ls_get strs) + +instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c) => StringReferencingBinary (a,b,c) where + ls_put strs (a,b,c) = ls_put strs a >> ls_put strs b >> ls_put strs c + ls_get strs = liftM3 (,,) (ls_get strs) (ls_get strs) (ls_get strs) + +instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d) => StringReferencingBinary (a,b,c,d) where + ls_put strs (a,b,c,d) = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d + ls_get strs = liftM4 (,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) + +instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d, StringReferencingBinary e) => StringReferencingBinary (a,b,c,d,e) where + ls_put strs (a,b,c,d,e) = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d >> ls_put strs e + ls_get strs = liftM5 (,,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) + + +newtype CompactNum a = CompactNum { fromCompactNum :: a } + +instance (Integral a, Num a, Binary a) => StringReferencingBinary (CompactNum a) where + ls_put _ (CompactNum i) + | 0 <= i && i < 255 = putWord8 (fromIntegral i) + | otherwise = putWord8 255 >> put i + ls_get _ = fmap CompactNum $ getWord8 >>= \case + i | 0 <= i && i < 255 -> return (fromIntegral i) + | otherwise -> get + +instance StringReferencingBinary a => StringReferencingBinary [a] where + ls_put strs l = ls_put strs (CompactNum (length l)) >> mapM_ (ls_put strs) l + ls_get strs = ls_getMany strs . fromCompactNum =<< ls_get strs + +instance StringReferencingBinary Text where + ls_put strs s = case elemIndex s strs of + Just i | 0 <= i && i < 255 -> + putWord8 (fromIntegral (succ i)) + _ -> putWord8 0 >> ls_put strs (T.unpack s) + ls_get strs = getWord8 >>= \case + 0 -> T.pack <$> ls_get strs + i -> return $! strs !! fromIntegral (pred i) + +-- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack. +ls_getMany :: StringReferencingBinary a => [Text] -> Int -> Get [a] +ls_getMany strs n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- ls_get strs + -- we must seq x to avoid stack overflows due to laziness in + -- (>>=) + x `seq` go (x:xs) (i-1) +{-# INLINE ls_getMany #-} + + +-- compat newtype for deserialization of v2-v4 CaptureData +newtype IntLen a = IntLen { fromIntLen :: a } + +-- compat instance for deserialization of v1 CaptureData +instance Binary a => Binary (IntLen a) where + put = put . fromIntLen + get = IntLen <$> get + +-- compat instance for deserialization of v2-v4 CaptureData +instance StringReferencingBinary a => StringReferencingBinary (IntLen [a]) where + ls_put strs (IntLen l) = ls_put strs (length l) >> mapM_ (ls_put strs) l + ls_get strs = fmap IntLen $ ls_getMany strs =<< ls_get strs + +-- compat instance for deserialization of v2-v4 CaptureData +instance StringReferencingBinary (IntLen Text) where + ls_put strs (IntLen s) = case elemIndex s strs of + Just i | 0 <= i && i < 255 -> + putWord8 (fromIntegral (succ i)) + _ -> putWord8 0 >> ls_put strs (IntLen (T.unpack s)) + ls_get strs = fmap IntLen $ getWord8 >>= \case + 0 -> T.pack . fromIntLen <$> ls_get strs + i -> return $! strs !! fromIntegral (pred i) + +{- +instance Binary a => StringReferencingBinary a where + ls_put _ = put + ls_get _ = get +-} + +instance StringReferencingBinary Char where { ls_put _ = put; ls_get _ = get } +instance StringReferencingBinary Int where { ls_put _ = put; ls_get _ = get } +instance StringReferencingBinary Integer where { ls_put _ = put; ls_get _ = get } +instance StringReferencingBinary Bool where { ls_put _ = put; ls_get _ = get } + +ls_encode :: StringReferencingBinary a => [Text] -> a -> ByteString +ls_encode strs = runPut . ls_put strs +{-# INLINE ls_encode #-} + +-- | Decode a value from a lazy ByteString, reconstructing the original structure. +-- +ls_decode :: StringReferencingBinary a => [Text] -> ByteString -> a +ls_decode strs = runGet (ls_get strs) + diff --git a/tests/examples/ghc92/T17544_kw.hs b/tests/examples/ghc92/T17544_kw.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/T17544_kw.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs #-} + +-- Haddock comments in this test case should all be rejected, but they are not. +-- +-- This is a known issue. Users should avoid writing comments in such +-- positions, as a future fix will disallow them. +-- +-- See Note [Register keyword location] in GHC.Parser.PostProcess.Haddock + +module + -- | Bad comment for the module + T17544_kw where + +data Foo -- | Bad comment for MkFoo + where MkFoo :: Foo + +newtype Bar -- | Bad comment for MkBar + where MkBar :: () -> Bar + +class Cls a + -- | Bad comment for clsmethod + where + clsmethod :: a + diff --git a/tests/examples/ghc92/TH.hs b/tests/examples/ghc92/TH.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/TH.hs @@ -0,0 +1,279 @@ +{-| +Module : Language.Grammars.AspectAG.TH +Description : Boilerplate generation +Copyright : (c) Juan García Garland +License : GPL +Maintainer : jpgarcia@fing.edu.uy +Stability : experimental +Portability : POSIX +-} + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Grammars.AspectAG.TH where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (showName) +import Data.Proxy +import Data.Either +import GHC.TypeLits +import Data.List +import Data.Set (Set) +import qualified Data.Set as S + +import Control.Monad + +import Data.GenRec.Label +import Data.GenRec +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.RecordInstances +import qualified Data.Kind as DK + + +-- * Attribute labels + +-- | makes a type level lit (Symbol) from a String +str2Sym s = litT$ strTyLit s -- th provides nametoSymbol, btw + + +-- | TH function to define a typed attribute label given a name +-- and a quoted type +attLabel :: String -> Name -> DecsQ +attLabel s t + = [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s) + $(conT t)) |] + +-- | for completness, to have a name as the next one +attMono = attLabel + +-- | TH function to define a polymorphic attribute +attPoly :: String -> DecsQ +attPoly s + = [d| $(varP (mkName s)) = Label :: forall a . Label ( 'Att $(str2Sym s) a) |] + +-- | multiple monomorphic attributes at once +attLabels :: [(String,Name)] -> Q [Dec] +attLabels xs = liftM concat . sequence $ [attLabel att ty | (att,ty) <- xs ] + +-- * Non terminals + +-- | add a non terminal symbol +addNont :: String -> Q [Dec] +addNont s + = liftM concat . sequence $ [addNTLabel s, addNTType s] + +addNTLabel :: String -> Q [Dec] +addNTLabel s + = [d| $(varP (mkName ("nt_" ++ s))) = Label :: Label ('NT $(str2Sym s)) |] + +addNTType :: String -> Q [Dec] +addNTType s + = return [TySynD (mkName ("Nt_"++ s)) [] (AppT (PromotedT 'NT) (LitT (StrTyLit s)))] + + +-- * Productions +--data Symbol = N String | Te Name +type family Terminal s :: Either NT T where + Terminal s = 'Right ('T s) + +type family NonTerminal s where + NonTerminal s = 'Left s + + +data SymTH = Ter Name | NonTer Name | Poly + + +addChi :: String -- chi name + -> Name -- prd + -> SymTH -- symbol type + -> Q [Dec] +addChi chi prd (Ter typ) + = [d| $(varP (mkName ("ch_" ++chi))) + = Label :: Label ( 'Chi $(str2Sym chi) + $(conT prd) + (Terminal $(conT typ)))|] +addChi chi prd (NonTer typ) + = [d| $(varP (mkName ("ch_" ++chi))) + = Label :: Label ( 'Chi $(str2Sym chi) + $(conT prd) + (NonTerminal $(conT typ)))|] +addChi chi prd poly + = [d| $(varP (mkName ("ch_" ++chi))) + = Label :: forall a . Label ( 'Chi $(str2Sym chi) + $(conT prd) + ('Right ('T a)))|] + +-- | only prod symbol +addPrd :: String --name + -> Name --nonterm + -> Q [Dec] +addPrd prd nt = liftM concat . sequence + $ [addPrdType prd nt, addPrdLabel prd nt] + +addPrdLabel prd nt + = [d| $(varP (mkName ("p_" ++ prd))) + = Label :: Label ('Prd $(str2Sym prd) $(conT nt))|] + +addPrdType prd nt + = return [TySynD (mkName ("P_"++ prd)) [] + (AppT (AppT (PromotedT 'Prd) (LitT (StrTyLit prd))) (ConT nt))] + + +-- | Productions +addProd :: String -- name + -> Name -- nt + -> [(String, SymTH)] -- chiLst + -> Q [Dec] +addProd prd nt xs + = liftM concat . sequence $ + addPrd prd nt + : addInstance nt prd (map preProc xs) + : [addChi chi (mkName ("P_" ++ prd)) sym | (chi, sym) <- xs] + where preProc (n, Ter a) = (mkName n, a) + preProc (n, NonTer a) = (mkName n, a) + preProc (n, Poly) = (mkName n, mkName "a") + +-- | class +class Prods (lhs :: NT) (name :: Symbol) (rhs :: [(Symbol, Symbol)]) where {} + +-- get a list of instances +getInstances :: Q [InstanceDec] +getInstances = do + ClassI _ instances <- reify ''Prods + return instances + +-- convert the list of instances into an Exp so they can be displayed in GHCi +showInstances :: Q Exp +showInstances = do + ins <- getInstances + return . LitE . stringL $ show $ head ins + +addInstance :: Name -> String -> [(Name, Name)] -> Q [Dec] +addInstance nt name rhs + = [d| instance Prods $(conT nt) $(str2Sym name) $(typeList rhs) where {} |] + +typeList :: [(Name, Name)] -> Q Type +typeList = foldr f promotedNilT + -- where f = \x xs -> appT (appT promotedConsT (nameToSymbolBase x)) xs + where f = \(n,t) xs + -> appT (appT promotedConsT (appT (appT (promotedTupleT 2) + (nameToSymbol n)) + (nameToSymbolBase t))) xs + +nameToSymbol = litT . strTyLit . show +nameToSymbolBase = litT . strTyLit . nameBase + +isNTName :: Name -> Bool +isNTName n + = "Nt_" `isPrefixOf` nameBase n + +closeNT :: Name -> Q [Dec] +closeNT nt + = do decs <- getInstances + let consts = map mkCon $ filter (isInstanceOf nt) decs + return [ DataD [] + (mkName $ drop 3 $ nameBase nt) [] Nothing + consts [DerivClause Nothing [ConT ''Show, ConT ''Eq, ConT ''Read]]] + +isInstanceOf nt (InstanceD _ _ (AppT (AppT (AppT (ConT prods) (ConT nt')) _ ) _) _) + = nameBase nt == nameBase nt' +isInstanceOf _ _ = False + +mkCon :: InstanceDec -> Con +mkCon i + = case i of + InstanceD _ [] (AppT (AppT (AppT (ConT _prods) (ConT nt)) (LitT (StrTyLit prdname))) tlist) _ + -> RecC (mkName prdname) (map mkBangPR $ getTList tlist) + +mkBangP (_, a) = (Bang NoSourceUnpackedness NoSourceStrictness, ConT a) +mkBangPR (n, a) = (n, Bang NoSourceUnpackedness NoSourceStrictness, ConT a) + +getTList :: Type -> [(Name, Name)] +getTList (SigT _ _) = [] +getTList (AppT (AppT (PromotedConsT) + (AppT (AppT (PromotedTupleT 2) + (LitT (StrTyLit n))) + (LitT (StrTyLit pos)))) + ts) + = (mkName n, + if "Nt_" `isPrefixOf` pos then mkName $ drop 3 pos else mkName pos) + : getTList ts +getTList _ = [] + +-- | keeps nt info +getTListNT :: Type -> [(Name, Name)] +getTListNT (SigT _ _) = [] +getTListNT (AppT (AppT (PromotedConsT) + (AppT (AppT (PromotedTupleT 2) + (LitT (StrTyLit n))) + (LitT (StrTyLit pos)))) + ts) + = (mkName n, mkName pos) : getTListNT ts +getTListNT _ = [] + +-- | like |mkCon| in semantic functions, builds a case +mkClause :: InstanceDec -> Clause +mkClause i + = case i of + InstanceD _ [] (AppT (AppT (AppT (ConT _prods) + (ConT nt)) + (LitT (StrTyLit prdname))) + tlist) _ + -> Clause [VarP (mkName "asp"), + ConP (mkName $ prdname) [ VarP a | a <- map fst (getTList tlist)]] + (NormalB ((AppE (AppE (AppE (VarE $ mkName "knitAspect") + (VarE $ mkName $ "p_"++ prdname)) + (VarE $ mkName "asp")) + (toSemRec (getTListNT tlist))))) + [] + +toSemRec :: [(Name, Name)] -> Exp +toSemRec + = foldr mkChSem (VarE (mkName "emptyGenRec")) + where mkChSem (n,pos) xs + | "Nt_" `isPrefixOf` nameBase pos = + (AppE (AppE (VarE $ mkName ".*.") + (AppE (AppE (VarE $ mkName ".=.") + (VarE $ mkName $ "ch_" ++ nameBase n)) + (AppE (AppE (VarE $ mkName $ "sem_" ++ (drop 3 $ nameBase pos)) + (VarE $ mkName "asp")) + (VarE $ n)))) + xs) + | otherwise = + (AppE (AppE (VarE $ mkName ".*.") + (AppE (AppE (VarE $ mkName ".=.") + (VarE $ mkName $ "ch_" ++ nameBase n)) + (AppE (VarE $ mkName "sem_Lit") + (VarE $ n)))) + xs) +closeNTs :: [Name] -> Q [Dec] +closeNTs = liftM concat . sequence . map (closeNT) + +mkSemFunc :: Name -- nonterm + -> Q [Dec] +mkSemFunc nt = + do decs <- getInstances + let clauses = map mkClause $ filter (isInstanceOf nt) decs + return [FunD (mkName $ "sem_" ++ drop 3 (nameBase nt)) clauses ] + +mkSemFuncs :: [Name] -> Q [Dec] +mkSemFuncs + = liftM concat . sequence . map (mkSemFunc) + diff --git a/tests/examples/ghc92/proc-do-complex-four-out.hs b/tests/examples/ghc92/proc-do-complex-four-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/proc-do-complex-four-out.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Arrows #-} + +foo + f + g + h + ma = + proc + ( (a, b) + , (c, d) + , (e, f) + ) + -> do + -- Begin do + (x, y) <- -- GHC parser fails if layed out over multiple lines + f -- Call into f + ( a + , c -- Tuple together arguments + ) + ( b + , d + ) + -< + ( b + 1 -- Funnel into arrow + , d * b + ) + if x `mod` y == 0 -- Basic condition + then case e of -- Only left case is relevant + Left + ( z + , w + ) -> \u -> -- Procs can have lambdas + let v = + u -- Actually never used + ^ 2 + in ( returnA + -< + -- Just do the calculation + (x + y * z) + ) + else do + let u = x -- Let bindings bind expressions, not commands + -- Could pattern match directly on x + i <- case u of + 0 -> (g . h -< u) + n -> + ( ( h . g + -< + y -- First actual use of y + ) + ) + returnA -< () + -- Sometimes execute effects + if i > 0 + then ma -< () + else returnA -< () + returnA + -< + ( i + + x + * y -- Just do the calculation + ) + diff --git a/tests/examples/ghc92/proc-do-complex-out.hs b/tests/examples/ghc92/proc-do-complex-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/proc-do-complex-out.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Arrows #-} + +foo + f + g + h + ma = + proc + ( (a, b), + (c, d), + (e, f) + ) + -> do + -- Begin do + (x, y) <- -- GHC parser fails if layed out over multiple lines + f -- Call into f + ( a, + c -- Tuple together arguments + ) + ( b, + d + ) + -< + ( b + 1, -- Funnel into arrow + d * b + ) + if x `mod` y == 0 -- Basic condition + then case e of -- Only left case is relevant + Left + ( z, + w + ) -> \u -> -- Procs can have lambdas + let v = + u -- Actually never used + ^ 2 + in ( returnA + -< + -- Just do the calculation + (x + y * z) + ) + else do + let u = x -- Let bindings bind expressions, not commands + -- Could pattern match directly on x + i <- case u of + 0 -> (g . h -< u) + n -> + ( ( h . g + -< + y -- First actual use of y + ) + ) + returnA -< () + -- Sometimes execute effects + if i > 0 + then ma -< () + else returnA -< () + returnA + -< + ( i + + x + * y -- Just do the calculation + ) + diff --git a/tests/examples/ghc92/proc-do-complex.hs b/tests/examples/ghc92/proc-do-complex.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/proc-do-complex.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Arrows #-} +foo + f + g + h + ma = proc ( + (a, b), + (c, d), + (e, f) + ) -> + do -- Begin do + (x,y) -- GHC parser fails if layed out over multiple lines + <- f -- Call into f + (a, + c) -- Tuple together arguments + (b, + d) + -< (b + 1, -- Funnel into arrow + d * b) + if + x `mod` y == 0 -- Basic condition + then case e -- Only left case is relevant + of Left (z, + w) -> \u -> -- Procs can have lambdas + let + v + = u -- Actually never used + ^ 2 + in + (returnA + -< -- Just do the calculation + (x + y * z)) + else do + let u = x -- Let bindings bind expressions, not commands + -- Could pattern match directly on x + i <- case u of + 0 -> (g . h -< u) + n -> ( + (h . g + -< y) -- First actual use of y + ) + returnA -< () + -- Sometimes execute effects + if i > 0 + then ma -< () + else returnA -< () + returnA -< (i + + x * + y) -- Just do the calculation + diff --git a/tests/examples/ghc92/proc-lets-out.hs b/tests/examples/ghc92/proc-lets-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/proc-lets-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> let b = a in f -< b + +bar f g = proc a -> + let h = + f + . g a + j = + g + . h + in id -< (h, j) + diff --git a/tests/examples/ghc92/proc-lets.hs b/tests/examples/ghc92/proc-lets.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/proc-lets.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> let b = a in f -< b + +bar f g = proc a -> + let + h + = f + . g a + j = g + . + h + in + id -< (h, j) + diff --git a/tests/examples/transform/AddLocalDecl1.hs b/tests/examples/transform/AddLocalDecl1.hs --- a/tests/examples/transform/AddLocalDecl1.hs +++ b/tests/examples/transform/AddLocalDecl1.hs @@ -2,8 +2,12 @@ -- |This is a function foo = x -- comment1 +-- trailing 1 -- |Another fun x = a -- comment2 where a = 3 +-- trailing 2 + +y = 3 diff --git a/tests/examples/transform/AddLocalDecl1.hs.expected b/tests/examples/transform/AddLocalDecl1.hs.expected --- a/tests/examples/transform/AddLocalDecl1.hs.expected +++ b/tests/examples/transform/AddLocalDecl1.hs.expected @@ -4,8 +4,12 @@ foo = x -- comment1 where nn = 2 +-- trailing 1 -- |Another fun x = a -- comment2 where a = 3 +-- trailing 2 + +y = 3 diff --git a/tests/examples/transform/LocalDecls2.hs.expected b/tests/examples/transform/LocalDecls2.hs.expected --- a/tests/examples/transform/LocalDecls2.hs.expected +++ b/tests/examples/transform/LocalDecls2.hs.expected @@ -4,3 +4,5 @@ where nn :: Int nn = 2 + + diff --git a/tests/examples/transform/WhereIn3a.hs.expected b/tests/examples/transform/WhereIn3a.hs.expected --- a/tests/examples/transform/WhereIn3a.hs.expected +++ b/tests/examples/transform/WhereIn3a.hs.expected @@ -1,11 +1,5 @@ module WhereIn3a where --- A leading comment -anotherFun 0 y = sq y - where sq x = x^2 -sq pow 0 = 0 -- prior comment -sq pow z = z^pow --there is a comment - --A definition can be demoted to the local 'where' binding of a friend declaration, --if it is only used by this friend declaration.