diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2024-12-06 v1.11.0.0 + * Support GHC 9.12.1 (rc1) 2024-05-21 v1.10.0.0 * Make the Language.Haskell.GHC.ExactPrint.Transform API pure * Remove EPOoptions fields that had no effect diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,12 +1,12 @@ cabal-version: 2.4 name: ghc-exactprint -version: 1.10.0.0 +version: 1.11.0.0 synopsis: ExactPrint for GHC 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. . - Note: requires GHC 9.10.*. For earlier GHC + Note: requires GHC 9.12.*. For earlier GHC versions see lower version numbers. . @@ -16,11 +16,12 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 9.10.1 +tested-with: GHC == 9.12.1 extra-doc-files: ChangeLog extra-source-files: tests/examples/failing/*.hs tests/examples/failing/*.hs.bad tests/examples/ghc910/*.hs + tests/examples/ghc912/*.hs tests/examples/pre-ghc910/*.hs tests/examples/pre-ghc910/*.hs-boot tests/examples/transform/*.hs @@ -47,7 +48,6 @@ import: warnings exposed-modules: Language.Haskell.GHC.ExactPrint , Language.Haskell.GHC.ExactPrint.ExactPrint - , Language.Haskell.GHC.ExactPrint.Lookup , Language.Haskell.GHC.ExactPrint.Parsers , Language.Haskell.GHC.ExactPrint.Preprocess , Language.Haskell.GHC.ExactPrint.Transform @@ -55,15 +55,15 @@ , Language.Haskell.GHC.ExactPrint.Utils hs-source-dirs: src - build-depends: base >=4.20 && <4.21 + build-depends: base >=4.21 && <4.22 , containers >= 0.5 && < 0.8 - , ghc >= 9.10 && < 9.11 - , ghc-boot >= 9.10 && < 9.11 + , ghc >= 9.12 && < 9.13 + , ghc-boot >= 9.12 && < 9.13 , mtl >= 2.2.1 && < 2.5 , syb >= 0.5 && < 0.8 default-language: Haskell2010 - if impl (ghc < 9.10) + if impl (ghc < 9.12) buildable: False Test-Suite test @@ -82,14 +82,14 @@ , Test.Transform GHC-Options: -threaded Default-language: Haskell2010 - Build-depends: base < 4.21 + Build-depends: base < 4.22 , HUnit >= 1.2 , containers >= 0.5 , Diff , directory >= 1.2 , extra , filepath >= 1.4 - , ghc >= 9.10 + , ghc >= 9.12 , ghc-paths >= 0.1 , syb >= 0.5 , silently >= 1.2 @@ -100,7 +100,7 @@ mtl >= 2.2.1 else build-depends: ghc-exactprint - if impl (ghc < 9.10) + if impl (ghc < 9.12) buildable: False executable roundtrip @@ -110,15 +110,15 @@ other-modules: Test.Common Test.CommonUtils default-language: Haskell2010 - if impl (ghc >= 9.10) && flag (roundtrip) + if impl (ghc >= 9.12) && flag (roundtrip) build-depends: HUnit < 1.7 - , base < 4.21 + , base < 4.22 , containers < 0.8 , directory < 1.4 , extra < 1.8 , filepath < 1.6 - , ghc >= 9.10 && < 9.11 + , ghc >= 9.12 && < 9.13 , ghc-exactprint , ghc-paths < 0.2 , time < 1.13 @@ -135,11 +135,11 @@ other-modules: Test.CommonUtils default-language: Haskell2010 if flag (roundtrip) - build-depends: base < 4.21 + build-depends: base < 4.22 , directory < 1.4 , extra < 1.8 , filepath < 1.6 - , ghc >= 9.10 && < 9.11 + , ghc >= 9.12 && < 9.13 , Diff < 0.6 buildable: True else @@ -153,12 +153,12 @@ -- hs-source-dirs: tests -- default-language: Haskell2010 -- if flag (roundtrip) --- build-depends: base < 4.21 +-- build-depends: base < 4.22 -- , containers -- , directory -- , extra -- , filepath --- , ghc >= 9.10 +-- , ghc >= 9.12 -- , HUnit -- , text >= 1.2.2 -- , turtle >= 1.3.0 diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -1,5091 +1,4946 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-} - -module Language.Haskell.GHC.ExactPrint.ExactPrint - ( - ExactPrint(..) - , exactPrint - , exactPrintWithOptions - , makeDeltaAst - - -- * Configuration - , EPOptions(epTokenPrint, epWhitespacePrint) - , stringOptions - , epOptions - , deltaOptions - ) where - -import GHC -import GHC.Base (NonEmpty(..)) -import GHC.Core.Coercion.Axiom (Role(..)) -import GHC.Data.Bag -import qualified GHC.Data.BooleanFormula as BF -import GHC.Data.FastString -import GHC.TypeLits -import GHC.Types.Basic hiding (EP) -import GHC.Types.Fixity -import GHC.Types.ForeignCall -import GHC.Types.Name.Reader -import GHC.Types.PkgQual -import GHC.Types.SourceText -import GHC.Types.SrcLoc -import GHC.Types.Var -import GHC.Unit.Module.Warnings -import GHC.Utils.Misc -import GHC.Utils.Outputable hiding ( (<>) ) -import GHC.Utils.Panic - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Control.Monad (forM, when, unless) -import Control.Monad.Identity (Identity(..)) -import qualified Control.Monad.Reader as Reader -import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask) -import Control.Monad.Trans (lift) -import Data.Data ( Data ) -import Data.Dynamic -import Data.Foldable -import Data.Functor.Const -import qualified Data.Set as Set -import Data.Typeable -import Data.List ( partition, sort, sortBy) -import qualified Data.Map.Strict as Map -import Data.Maybe ( isJust, mapMaybe ) -import Data.Void - -import Language.Haskell.GHC.ExactPrint.Lookup -import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Types - --- --------------------------------------------------------------------- - -exactPrint :: ExactPrint ast => ast -> String -exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) - --- | The additional option to specify the printing configuration. -exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m) - => EPOptions m b - -> ast - -> m (ast, b) -exactPrintWithOptions r ast = - runEP r (markAnnotated ast) - --- | Transform concrete annotations into relative annotations. --- This should be unnecessary from GHC 9.10 -makeDeltaAst :: ExactPrint ast => ast -> ast -makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) - ------------------------------------------------------- - -type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a - -runEP :: (Monad m) - => EPOptions m w - -> EP w m a -> m (a, w) -runEP epReader action = do - (ast, w) <- evalRWST action epReader defaultEPState - return (ast, output w) - --- --------------------------------------------------------------------- - -defaultEPState :: EPState -defaultEPState = EPState - { epPos = (1,1) - , dLHS = 0 - , pMarkLayout = False - , pLHS = 0 - , dMarkLayout = False - , dPriorEndPosition = (1,1) - , uAnchorSpan = badRealSrcSpan - , uExtraDP = Nothing - , uExtraDPReturn = Nothing - , pAcceptSpan = False - , epComments = [] - , epCommentsApplied = [] - , epEof = Nothing - } - - --- --------------------------------------------------------------------- --- 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 EPOptions m a = EPOptions - { epTokenPrint :: String -> m a - , epWhitespacePrint :: String -> m a - } - --- | Helper to create a 'EPOptions' -epOptions :: (String -> m a) - -> (String -> m a) - -> EPOptions m a -epOptions tokenPrint wsPrint = EPOptions - { epWhitespacePrint = wsPrint - , epTokenPrint = tokenPrint - } - --- | Options which can be used to print as a normal String. -stringOptions :: EPOptions Identity String -stringOptions = epOptions return return - --- | Options which can be used to simply update the AST to be in delta --- form, without generating output -deltaOptions :: EPOptions Identity () -deltaOptions = epOptions (\_ -> return ()) (\_ -> return ()) - -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 - , uExtraDPReturn :: !(Maybe DeltaPos) - -- ^ Used to return Delta version of uExtraDP - , pAcceptSpan :: Bool -- ^ When we have processed an - -- entry of EpaDelta, accept the - -- next `EpaSpan` start as the - -- current output position. i.e. do - -- not advance epPos. Achieved by - -- setting dPriorEndPosition to the - -- end of the span. - - -- 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] - , epCommentsApplied :: ![[Comment]] - , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan)) - } - --- --------------------------------------------------------------------- - --- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry -class HasEntry ast where - fromAnn :: ast -> Entry - -class HasTrailing a where - trailing :: a -> [TrailingAnn] - setTrailing :: a -> [TrailingAnn] -> a - -setAnchorEpa :: (HasTrailing an) - => EpAnn an -> Anchor -> [TrailingAnn] -> EpAnnComments -> EpAnn an -setAnchorEpa (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing an ts) cs - -setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs -setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} } - where - anc' = anc - an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' [] cs - -setAnchorAn :: (HasTrailing an) - => LocatedAn an a -> Anchor -> [TrailingAnn] -> EpAnnComments -> LocatedAn an a -setAnchorAn (L (EpAnn _ an _) a) anc ts cs = (L (EpAnn anc (setTrailing an ts) cs) a) - -- `debug` ("setAnchorAn: anc=" ++ showAst anc) - -setAnchorEpaL :: EpAnn AnnList -> Anchor -> [TrailingAnn] -> EpAnnComments -> EpAnn AnnList -setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = Nothing}) ts) cs - --- --------------------------------------------------------------------- - --- | Key entry point. Switches to an independent AST element with its --- own annotation, calculating new offsets, etc -markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a -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) - --- | For GenLocated SrcSpan, we construct an entry location but cannot update it. -data CanUpdateAnchor = CanUpdateAnchor - | CanUpdateAnchorOnly - | NoCanUpdateAnchor - deriving (Eq, Show, Data) - -data Entry = Entry Anchor [TrailingAnn] EpAnnComments FlushComments CanUpdateAnchor - | NoEntryVal - --- | For flagging whether to capture comments in an EpaDelta or not -data CaptureComments = CaptureComments - | NoCaptureComments - -mkEntry :: Anchor -> [TrailingAnn] -> EpAnnComments -> Entry -mkEntry anc ts cs = Entry anc ts cs NoFlushComments CanUpdateAnchor - -instance (HasTrailing a) => HasEntry (EpAnn a) where - fromAnn (EpAnn anc a cs) = mkEntry anc (trailing a) cs - --- --------------------------------------------------------------------- - -instance HasTrailing NoEpAnns where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing EpaLocation where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AddEpAnn where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing [AddEpAnn] where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing (AddEpAnn, AddEpAnn) where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing EpAnnSumPat where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnList where - trailing a = al_trailing a - setTrailing a ts = a { al_trailing = ts } - -instance HasTrailing AnnListItem where - trailing a = lann_trailing a - setTrailing a ts = a { lann_trailing = ts } - -instance HasTrailing AnnPragma where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnContext where - trailing (AnnContext ma _opens _closes) - = case ma of - Just (UnicodeSyntax, r) -> [AddDarrowUAnn r] - Just (NormalSyntax, r) -> [AddDarrowAnn r] - Nothing -> [] - - setTrailing a [AddDarrowUAnn r] = a {ac_darrow = Just (UnicodeSyntax, r)} - setTrailing a [AddDarrowAnn r] = a{ac_darrow = Just (NormalSyntax, r)} - setTrailing a [] = a{ac_darrow = Nothing} - setTrailing a ts = error $ "Cannot setTrailing " ++ showAst ts ++ " for " ++ showAst a - - -instance HasTrailing AnnParen where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnsIf where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing EpAnnHsCase where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnFieldLabel where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnProjection where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnExplicitSum where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing (Maybe EpAnnUnboundVar) where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing GrhsAnn where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnSig where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing HsRuleAnn where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing EpAnnImportDecl where - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing AnnsModule where - -- Report none, as all are used internally - trailing _ = [] - setTrailing a _ = a - -instance HasTrailing NameAnn where - trailing a = nann_trailing a - setTrailing a ts = a { nann_trailing = ts } - -instance HasTrailing Bool where - trailing _ = [] - setTrailing a _ = a - --- --------------------------------------------------------------------- - -fromAnn' :: (HasEntry a) => a -> Entry -fromAnn' an = case fromAnn an of - NoEntryVal -> NoEntryVal - Entry a ts c _ u -> Entry a ts c FlushComments u - --- --------------------------------------------------------------------- - -astId :: (Typeable a) => a -> String -astId a = show (typeOf a) - -cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a] -cua CanUpdateAnchor f = f -cua CanUpdateAnchorOnly _ = return [] -cua NoCanUpdateAnchor _ = return [] - --- | "Enter" an annotation, by using the associated 'anchor' field as --- the new reference point for calculating all DeltaPos positions. --- This is the heart of the exact printing process. --- --- 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 :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a -enterAnn NoEntryVal a = do - p <- getPosP - debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) - r <- exact a - debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) - return r -enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do - acceptSpan <- getAcceptSpan - setAcceptSpan False - case anchor' of - EpaDelta _ _ -> setAcceptSpan True - _ -> return () - p <- getPosP - pe0 <- getPriorEndD - debugM $ "enterAnn:starting:(anchor',p,pe,a) =" ++ show (showAst anchor', p, pe0, astId a) - prevAnchor <- getAnchorU - let curAnchor = case anchor' of - EpaSpan (RealSrcSpan r _) -> r - _ -> prevAnchor - debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) - case canUpdateAnchor of - CanUpdateAnchor -> pushAppliedComments - _ -> return () - case anchor' of - EpaDelta _ dcs -> do - debugM $ "enterAnn:Delta:Flushing comments" - flushComments [] - debugM $ "enterAnn:Delta:Printing prior comments:" ++ showGhc (priorComments cs) - mapM_ printOneComment (concatMap tokComment $ priorComments cs) - debugM $ "enterAnn:Delta:Printing EpaDelta comments:" ++ showGhc dcs - mapM_ printOneComment (concatMap tokComment dcs) - _ -> do - debugM $ "enterAnn:Adding comments:" ++ showGhc (priorComments cs) - addCommentsA (priorComments cs) - debugM $ "enterAnn:Added comments" - printCommentsBefore curAnchor - priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop - -- ------------------------- - case anchor' of - EpaDelta dp _ -> do - debugM $ "enterAnn: EpaDelta:" ++ show dp - -- Set the original anchor as prior end, so the rest of this AST - -- fragment has a reference - setPriorEndNoLayoutD (ss2pos curAnchor) - _ -> do - if acceptSpan - then setPriorEndNoLayoutD (ss2pos curAnchor) - else return () - - -- ------------------------- - if ((fst $ fst $ rs2range curAnchor) >= 0) - then - setAnchorU curAnchor - else - debugM $ "enterAnn: not calling setAnchorU for : " ++ show (rs2range curAnchor) - -- ------------------------------------------------------------------- - -- Make sure the running dPriorEndPosition gets updated according to - -- the change in the current anchor. - - -- Compute the distance from dPriorEndPosition to the start of the new span. - - -- While processing in the context of the prior anchor, we choose to - -- enter a new Anchor, which has a defined position relative to the - -- prior anchor, even if we do not actively output anything at that - -- point. - -- Is this edp? - - -- ------------------------------------------------------------------- - -- 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 <- getLayoutOffsetD - let spanStart = ss2pos curAnchor - priorEndAfterComments <- getPriorEndD - 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 curAnchor) - debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) - let edp'' = case anchor' of - EpaDelta dp _ -> dp - _ -> edp' - -- --------------------------------------------- - med <- getExtraDP - setExtraDP Nothing - let (edp, medr) = case med of - Nothing -> (edp'', Nothing) - Just (EpaDelta dp _) -> (dp, Nothing) - -- Replace original with desired one. Allows all - -- list entry values to be DP (1,0) - Just (EpaSpan (RealSrcSpan r _)) -> (dp, Just dp) - where - dp = adjustDeltaForOffset - off (ss2delta priorEndAfterComments r) - Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r - when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp) - when (isJust medr) $ setExtraDPReturn medr - -- --------------------------------------------- - -- Preparation complete, perform the action - when (priorEndAfterComments < spanStart) (do - debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart - modify (\s -> s { dPriorEndPosition = spanStart } )) - - debugM $ "enterAnn: (anchor', curAnchor):" ++ show (anchor', rs2range curAnchor) - -- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) - p0 <- getPosP - d <- getPriorEndD - debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d) - - -- end of delta phase processing - -- ------------------------------------------------------------------- - -- start of print phase processing - - advance edp - debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') - a' <- exact a - debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') - - -- Core recursive exactprint done, start end of Entry processing - - when (flush == FlushComments) $ do - debugM $ "flushing comments in enterAnn:" ++ showAst (cs, getFollowingComments cs) - flushComments (getFollowingComments cs) - debugM $ "flushing comments in enterAnn done" - - !eof <- getEofPos - case eof of - Nothing -> return () - Just (pos, prior) -> do - let dp = if pos == prior - then (DifferentLine 1 0) - else origDelta pos prior - debugM $ "EOF:(pos,posEnd,prior,dp) =" ++ showGhc (ss2pos pos, ss2posEnd pos, ss2pos prior, dp) - printStringAtLsDelta dp "" - setEofPos Nothing -- Only do this once - - -- Deal with exit from the current anchor - when (flush == NoFlushComments) $ do - printCommentsIn curAnchor -- Make sure all comments in the span are printed - - p1 <- getPosP - pe1 <- getPriorEndD - debugM $ "enterAnn:done:(anchor,p,pe,a) =" ++ show (showAst anchor', p1, pe1, astId a') - - case anchor' of - EpaDelta _ _ -> return () - EpaSpan (RealSrcSpan rss _) -> do - setAcceptSpan False - setPriorEndD (snd $ rs2range rss) - EpaSpan _ -> return () - - -- Outside the anchor, mark any trailing - postCs <- cua canUpdateAnchor takeAppliedCommentsPop - following <- if (flush == NoFlushComments) - then do - let (before, after) = splitAfterTrailingAnns trailing_anns - (getFollowingComments cs) - addCommentsA before - return after - else return [] - !trailing' <- markTrailing trailing_anns - -- mapM_ printOneComment (concatMap tokComment $ following) - addCommentsA following - - -- Update original anchor, comments based on the printing process - let newAnchor = EpaDelta edp [] - debugM $ "enterAnn:setAnnotationAnchor:(canUpdateAnchor,newAnchor,priorCs,postCs):" ++ showAst (canUpdateAnchor,newAnchor,priorCs,postCs) - let r = case canUpdateAnchor of - CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) - CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments - NoCanUpdateAnchor -> a' - return r - --- --------------------------------------------------------------------- - --- | Split the span following comments into ones that occur prior to --- the last trailing ann, and ones after. -splitAfterTrailingAnns :: [TrailingAnn] -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) -splitAfterTrailingAnns [] cs = ([], cs) -splitAfterTrailingAnns tas cs = (before, after) - where - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - (before, after) = case reverse (concatMap trailing_loc tas) of - [] -> ([],cs) - (s:_) -> (b,a) - where - s_pos = ss2pos s - (b,a) = break (\(L ll _) -> (ss2pos $ anchor ll) > s_pos) - cs - - --- --------------------------------------------------------------------- - -addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () -addCommentsA csNew = addComments False (concatMap tokComment csNew) - -{- -TODO: When we addComments, some may have an anchor that is no longer -valid, as it has been moved and has an anchor_op. - -Does an Anchor even make sense for a comment, perhaps it should be an -EpaLocation? - -How do we sort them? do we assign a location based on when we add them -to the list, based on the current output pos? Except the offset is a -delta compared to a reference location. Need to nail the concept of -the reference location. - -By definition it is the current anchor, so work against that. And that -also means that the first entry comment that has moved should not have -a line offset. --} -addComments :: (Monad m, Monoid w) => Bool -> [Comment] -> EP w m () -addComments sortNeeded csNew = do - debugM $ "addComments:csNew" ++ show csNew - cs <- getUnallocatedComments - debugM $ "addComments:cs" ++ show cs - -- We can only sort the comments if we are in the first phase, - -- were all comments have locations. If any have EpaDelta the - -- sort will fail, so we do not try. - if sortNeeded && all noDelta (csNew ++ cs) - then putUnallocatedComments (sort (cs ++ csNew)) - else putUnallocatedComments (cs ++ csNew) - -noDelta :: Comment -> Bool -noDelta c = case commentLoc c of - EpaSpan _ -> True - _ -> False - --- --------------------------------------------------------------------- - --- | Just before we print out the EOF comments, flush the remaining --- ones in the state. -flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () -flushComments !trailing_anns = do - debugM $ "flushComments entered: " ++ showAst trailing_anns - addCommentsA trailing_anns - debugM $ "flushComments after addCommentsA" - cs <- getUnallocatedComments - debugM $ "flushComments: got cs" - debugM $ "flushing comments starting: cs" ++ showAst cs - -- AZ:TODO: is the sort still needed? - -- mapM_ printOneComment (sortComments cs) - mapM_ printOneComment cs - putUnallocatedComments [] - debugM $ "flushing comments done" - --- --------------------------------------------------------------------- - --- |In order to interleave annotations into the stream, we turn them into --- comments. They are removed from the annotation to avoid duplication. -annotationsToComments :: (Monad m, Monoid w) - => a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m a -annotationsToComments a l kws = do - let (newComments, newAnns) = go ([],[]) (view l a) - addComments True newComments - return (set l (reverse newAnns) a) - where - keywords = Set.fromList kws - - go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) - go acc [] = acc - go (cs',ans) ((AddEpAnn k ss) : ls) - | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls - | otherwise = go (cs', (AddEpAnn k ss):ans) ls - --- --------------------------------------------------------------------- - --- Temporary function to simply reproduce the "normal" pretty printer output -withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a -withPpr a = do - ss <- getAnchorU - debugM $ "withPpr: ss=" ++ show ss - printStringAtRs' ss (showPprUnsafe a) - return a - --- --------------------------------------------------------------------- - --- | 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 - setAnnotationAnchor :: a -> Anchor -> [TrailingAnn] -> EpAnnComments -> a - exact :: (Monad m, Monoid w) => a -> EP w m a - --- --------------------------------------------------------------------- --- Start of utility functions --- --------------------------------------------------------------------- - -printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () -printSourceText (NoSourceText) txt = printStringAdvance txt >> return () -printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return () - -printSourceTextAA :: (Monad m, Monoid w) => SourceText -> String -> EP w m () -printSourceTextAA (NoSourceText) txt = printStringAdvanceA txt >> return () -printSourceTextAA (SourceText txt) _ = printStringAdvanceA (unpackFS txt) >> return () - --- --------------------------------------------------------------------- - -printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation -printStringAtRs pa str = printStringAtRsC CaptureComments pa str - -printStringAtRsC :: (Monad m, Monoid w) - => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation -printStringAtRsC capture pa str = do - debugM $ "printStringAtRsC: pa=" ++ showAst pa - printCommentsBefore pa - pe <- getPriorEndD - debugM $ "printStringAtRsC:pe=" ++ show pe - let p = ss2delta pe pa - p' <- adjustDeltaForOffsetM p - debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p') - printStringAtLsDelta p' str - setPriorEndASTD pa - cs' <- case capture of - CaptureComments -> takeAppliedComments - NoCaptureComments -> return [] - debugM $ "printStringAtRsC:cs'=" ++ show cs' - debugM $ "printStringAtRsC:p'=" ++ showAst p' - debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' NoComments) - debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs')) - return (EpaDelta p' (map comment2LEpaComment cs')) - -printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m () -printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return () - --- --------------------------------------------------------------------- - -printStringAtMLoc' :: (Monad m, Monoid w) - => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation) -printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s -printStringAtMLoc' Nothing s = do - printStringAtLsDelta (SameLine 1) s - return (Just (EpaDelta (SameLine 1) [])) - -printStringAtMLocL :: (Monad m, Monoid w) - => EpAnn a -> Lens a (Maybe EpaLocation) -> String -> EP w m (EpAnn a) -printStringAtMLocL (EpAnn anc an cs) l s = do - r <- go (view l an) s - return (EpAnn anc (set l r an) cs) - where - go (Just aa) str = Just <$> printStringAtAA aa str - go Nothing str = do - printStringAtLsDelta (SameLine 1) str - return (Just (EpaDelta (SameLine 1) [])) - -printStringAdvanceA :: (Monad m, Monoid w) => String -> EP w m () -printStringAdvanceA str = printStringAtAA (EpaDelta (SameLine 0) []) str >> return () - -printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation -printStringAtAA el str = printStringAtAAC CaptureComments el str - -printStringAtNC :: (Monad m, Monoid w) => NoCommentsLocation -> String -> EP w m NoCommentsLocation -printStringAtNC el str = do - el' <- printStringAtAAC NoCaptureComments (noCommentsToEpaLocation el) str - return (epaToNoCommentsLocation el') - -printStringAtAAL :: (Monad m, Monoid w) - => a -> Lens a EpaLocation -> String -> EP w m a -printStringAtAAL an l str = do - r <- printStringAtAAC CaptureComments (view l an) str - return (set l r an) - -printStringAtAAC :: (Monad m, Monoid w) - => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation -printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s -printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss -printStringAtAAC capture (EpaDelta d cs) s = do - mapM_ printOneComment $ concatMap tokComment cs - pe1 <- getPriorEndD - p1 <- getPosP - printStringAtLsDelta d s - p2 <- getPosP - pe2 <- getPriorEndD - debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2) - setPriorEndASTPD (pe1,pe2) - cs' <- case capture of - CaptureComments -> takeAppliedComments - NoCaptureComments -> return [] - debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs') - return (EpaDelta d (map comment2LEpaComment cs')) - --- --------------------------------------------------------------------- - -markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation -markExternalSourceTextE l NoSourceText txt = printStringAtAA l txt -markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt) - --- --------------------------------------------------------------------- - -markLensMAA :: (Monad m, Monoid w) - => EpAnn a -> Lens a (Maybe AddEpAnn) -> EP w m (EpAnn a) -markLensMAA epann l = markLensMAA' epann (lepa . l) - -markLensMAA' :: (Monad m, Monoid w) - => a -> Lens a (Maybe AddEpAnn) -> EP w m a -markLensMAA' a l = - case view l a of - Nothing -> return a - Just aa -> do - aa' <- markAddEpAnn aa - return (set l (Just aa') a) - --- ------------------------------------- - -markLensAA :: (Monad m, Monoid w) - => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a) -markLensAA epann l = markLensAA' epann (lepa . l) - -markLensAA' :: (Monad m, Monoid w) - => a -> Lens a AddEpAnn -> EP w m a -markLensAA' a l = do - a' <- markKw (view l a) - return (set l a' a) - --- ------------------------------------- - -markEpAnnLMS :: (Monad m, Monoid w) - => EpAnn a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) -markEpAnnLMS epann l kw ms = markEpAnnLMS'' epann (lepa . l) kw ms - -markEpAnnLMS'' :: (Monad m, Monoid w) - => a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m a -markEpAnnLMS'' an l kw Nothing = markEpAnnL an l kw -markEpAnnLMS'' a l kw (Just str) = do - anns <- mapM go (view l a) - return (set l anns a) - where - go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn - go (AddEpAnn kw' r) - | kw' == kw = do - r' <- printStringAtAA r str - return (AddEpAnn kw' r') - | otherwise = return (AddEpAnn kw' r) - --- ------------------------------------- - -markEpAnnMS' :: (Monad m, Monoid w) - => [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m [AddEpAnn] -markEpAnnMS' anns kw Nothing = mark anns kw -markEpAnnMS' anns kw (Just str) = do - mapM go anns - where - go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn - go (AddEpAnn kw' r) - | kw' == kw = do - r' <- printStringAtAA r str - return (AddEpAnn kw' r') - | otherwise = return (AddEpAnn kw' r) - --- ------------------------------------- - -markEpAnnLMS' :: (Monad m, Monoid w) - => EpAnn a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) -markEpAnnLMS' an l kw ms = markEpAnnLMS0 an (lepa . l) kw ms - -markEpAnnLMS0 :: (Monad m, Monoid w) - => a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m a -markEpAnnLMS0 an l _kw Nothing = markLensKwA an l -markEpAnnLMS0 a l kw (Just str) = do - anns <- go (view l a) - return (set l anns a) - where - go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn - go (AddEpAnn kw' r) - | kw' == kw = do - r' <- printStringAtAA r str - return (AddEpAnn kw' r') - | otherwise = return (AddEpAnn kw' r) - --- --------------------------------------------------------------------- - -markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) - => EpToken tok -> EP w m (EpToken tok) -markEpToken NoEpTok = return NoEpTok -markEpToken (EpTok aa) = do - aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) - return (EpTok aa') - -markEpUniToken :: forall m w tok utok . (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok) - => EpUniToken tok utok -> EP w m (EpUniToken tok utok) -markEpUniToken NoEpUniTok = return NoEpUniTok -markEpUniToken (EpUniTok aa isUnicode) = do - aa' <- case isUnicode of - NormalSyntax -> printStringAtAA aa (symbolVal (Proxy @tok)) - UnicodeSyntax -> printStringAtAA aa (symbolVal (Proxy @utok)) - return (EpUniTok aa' isUnicode) - --- --------------------------------------------------------------------- - -markArrow :: (Monad m, Monoid w) => HsArrow GhcPs -> EP w m (HsArrow GhcPs) -markArrow (HsUnrestrictedArrow arr) = do - arr' <- markEpUniToken arr - return (HsUnrestrictedArrow arr') -markArrow (HsLinearArrow (EpPct1 pct1 arr)) = do - pct1' <- markEpToken pct1 - arr' <- markEpUniToken arr - return (HsLinearArrow (EpPct1 pct1' arr')) -markArrow (HsLinearArrow (EpLolly arr)) = do - arr' <- markEpToken arr - return (HsLinearArrow (EpLolly arr')) -markArrow (HsExplicitMult (pct, arr) t) = do - pct' <- markEpToken pct - t' <- markAnnotated t - arr' <- markEpUniToken arr - return (HsExplicitMult (pct', arr') t') - - --- --------------------------------------------------------------------- - -markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma) -markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}") - -markAnnCloseP' :: (Monad m, Monoid w) => AnnPragma -> EP w m AnnPragma -markAnnCloseP' an = markEpAnnLMS0 an lapr_close AnnClose (Just "#-}") - -markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma) -markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt) -markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt) - -markAnnOpenP' :: (Monad m, Monoid w) => AnnPragma -> SourceText -> String -> EP w m AnnPragma -markAnnOpenP' an NoSourceText txt = markEpAnnLMS0 an lapr_open AnnOpen (Just txt) -markAnnOpenP' an (SourceText txt) _ = markEpAnnLMS0 an lapr_open AnnOpen (Just $ unpackFS txt) - -markAnnOpen :: (Monad m, Monoid w) => [AddEpAnn] -> SourceText -> String -> EP w m [AddEpAnn] -markAnnOpen an NoSourceText txt = markEpAnnLMS'' an lidl AnnOpen (Just txt) -markAnnOpen an (SourceText txt) _ = markEpAnnLMS'' an lidl AnnOpen (Just $ unpackFS txt) - -markAnnOpen' :: (Monad m, Monoid w) - => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) -markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt -markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt - -markAnnOpen'' :: (Monad m, Monoid w) - => EpaLocation -> SourceText -> String -> EP w m EpaLocation -markAnnOpen'' el NoSourceText txt = printStringAtAA el txt -markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt - --- --------------------------------------------------------------------- -{- -data AnnParen - = AnnParen { - ap_adornment :: ParenType, - ap_open :: EpaLocation, - ap_close :: EpaLocation - } deriving (Data) --} -markOpeningParen, markClosingParen :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen -markOpeningParen an = markParen an lfst -markClosingParen an = markParen an lsnd - -markParen :: (Monad m, Monoid w) => AnnParen -> (forall a. Lens (a,a) a) -> EP w m AnnParen -markParen (AnnParen pt o c) l = do - loc' <- markKwA (view l $ kw pt) (view l (o, c)) - let (o',c') = set l loc' (o,c) - return (AnnParen pt o' c') - where - kw AnnParens = (AnnOpenP, AnnCloseP) - kw AnnParensHash = (AnnOpenPH, AnnClosePH) - kw AnnParensSquare = (AnnOpenS, AnnCloseS) - --- --------------------------------------------------------------------- --- Bare bones Optics --- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html - -type Lens a b = forall f . Functor f => (b -> f b) -> (a -> f a) -type Getting a b = (b -> Const b b) -> (a -> Const b a) -type ASetter a b = (b -> Identity b) -> (a -> Identity a) - -view :: MonadReader s m => Getting s a -> m a -view l = Reader.asks (getConst . l Const) -{-# INLINE view #-} - -over :: ASetter a b -> (b -> b) -> (a -> a) -over l f = runIdentity . l (Identity . f) -{-# INLINE over #-} - -set :: Lens a b -> b -> a -> a -set lens b = over lens (\_ -> b) -{-# INLINE set #-} - -{- -Question: How do I combine lenses? - -Answer: You compose them, using function composition (Yes, really!) - -You can think of the function composition operator as having this type: - -(.) :: Lens' a b -> Lens' b c -> Lens' a c --} - --- --------------------------------------------------------------------- --- Lenses - --- data EpAnn ann --- = EpAnn { entry :: !Anchor --- , anns :: !ann --- , comments :: !EpAnnComments --- } - -lepa :: Lens (EpAnn a) a -lepa k epAnn = fmap (\newAnns -> epAnn { anns = newAnns }) - (k (anns epAnn)) - --- data AnnsModule --- = AnnsModule { --- am_main :: [AddEpAnn], --- am_decls :: AnnList --- } deriving (Data, Eq) - -lam_main :: Lens AnnsModule [AddEpAnn] -lam_main k annsModule = fmap (\newAnns -> annsModule { am_main = newAnns }) - (k (am_main annsModule)) - --- lam_decls :: Lens AnnsModule AnnList --- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns }) --- (k (am_decls annsModule)) - - --- data EpAnnImportDecl = EpAnnImportDecl --- { importDeclAnnImport :: EpaLocation --- , importDeclAnnPragma :: Maybe (EpaLocation, EpaLocation) --- , importDeclAnnSafe :: Maybe EpaLocation --- , importDeclAnnQualified :: Maybe EpaLocation --- , importDeclAnnPackage :: Maybe EpaLocation --- , importDeclAnnAs :: Maybe EpaLocation --- } deriving (Data) - -limportDeclAnnImport :: Lens EpAnnImportDecl EpaLocation -limportDeclAnnImport k annImp = fmap (\new -> annImp { importDeclAnnImport = new }) - (k (importDeclAnnImport annImp)) - --- limportDeclAnnPragma :: Lens EpAnnImportDecl (Maybe (EpaLocation, EpaLocation)) --- limportDeclAnnPragma k annImp = fmap (\new -> annImp { importDeclAnnPragma = new }) --- (k (importDeclAnnPragma annImp)) - -limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe EpaLocation) -limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) - (k (importDeclAnnSafe annImp)) - -limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe EpaLocation) -limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) - (k (importDeclAnnQualified annImp)) - -limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation) -limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new }) - (k (importDeclAnnPackage annImp)) - --- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation) --- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new }) --- (k (importDeclAnnAs annImp)) - --- ------------------------------------- - --- data AnnList --- = AnnList { --- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout --- al_open :: Maybe AddEpAnn, --- al_close :: Maybe AddEpAnn, --- al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword --- al_trailing :: [TrailingAnn] -- ^ items appearing after the --- -- list, such as '=>' for a --- -- context --- } deriving (Data,Eq) - -lal_open :: Lens AnnList (Maybe AddEpAnn) -lal_open k parent = fmap (\new -> parent { al_open = new }) - (k (al_open parent)) - -lal_close :: Lens AnnList (Maybe AddEpAnn) -lal_close k parent = fmap (\new -> parent { al_close = new }) - (k (al_close parent)) - -lal_rest :: Lens AnnList [AddEpAnn] -lal_rest k parent = fmap (\new -> parent { al_rest = new }) - (k (al_rest parent)) - --- lal_trailing :: Lens AnnList [TrailingAnn] --- lal_trailing k parent = fmap (\new -> parent { al_trailing = new }) --- (k (al_trailing parent)) - --- ------------------------------------- - -lapr_rest :: Lens AnnPragma [AddEpAnn] -lapr_rest k parent = fmap (\newAnns -> parent { apr_rest = newAnns }) - (k (apr_rest parent)) - -lapr_open :: Lens AnnPragma AddEpAnn -lapr_open k parent = fmap (\new -> parent { apr_open = new }) - (k (apr_open parent)) - -lapr_close :: Lens AnnPragma AddEpAnn -lapr_close k parent = fmap (\new -> parent { apr_close = new }) - (k (apr_close parent)) - -lidl :: Lens [AddEpAnn] [AddEpAnn] -lidl k parent = fmap (\new -> new) - (k parent) - -lid :: Lens a a -lid k parent = fmap (\new -> new) - (k parent) - -lfst :: Lens (a,a) a -lfst k parent = fmap (\new -> (new, snd parent)) - (k (fst parent)) - -lsnd :: Lens (a,a) a -lsnd k parent = fmap (\new -> (fst parent, new)) - (k (snd parent)) - --- ------------------------------------- --- data AnnExplicitSum --- = AnnExplicitSum { --- aesOpen :: EpaLocation, --- aesBarsBefore :: [EpaLocation], --- aesBarsAfter :: [EpaLocation], --- aesClose :: EpaLocation --- } deriving Data - -laesOpen :: Lens AnnExplicitSum EpaLocation -laesOpen k parent = fmap (\new -> parent { aesOpen = new }) - (k (aesOpen parent)) - -laesBarsBefore :: Lens AnnExplicitSum [EpaLocation] -laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new }) - (k (aesBarsBefore parent)) - -laesBarsAfter :: Lens AnnExplicitSum [EpaLocation] -laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new }) - (k (aesBarsAfter parent)) - -laesClose :: Lens AnnExplicitSum EpaLocation -laesClose k parent = fmap (\new -> parent { aesClose = new }) - (k (aesClose parent)) - --- ------------------------------------- --- data AnnFieldLabel --- = AnnFieldLabel { --- afDot :: Maybe EpaLocation --- } deriving Data - -lafDot :: Lens AnnFieldLabel (Maybe EpaLocation) -lafDot k parent = fmap (\new -> parent { afDot = new }) - (k (afDot parent)) - --- ------------------------------------- --- data AnnProjection --- = AnnProjection { --- apOpen :: EpaLocation, -- ^ '(' --- apClose :: EpaLocation -- ^ ')' --- } deriving Data - -lapOpen :: Lens AnnProjection EpaLocation -lapOpen k parent = fmap (\new -> parent { apOpen = new }) - (k (apOpen parent)) - -lapClose :: Lens AnnProjection EpaLocation -lapClose k parent = fmap (\new -> parent { apClose = new }) - (k (apClose parent)) - --- ------------------------------------- --- data AnnsIf --- = AnnsIf { --- aiIf :: EpaLocation, --- aiThen :: EpaLocation, --- aiElse :: EpaLocation, --- aiThenSemi :: Maybe EpaLocation, --- aiElseSemi :: Maybe EpaLocation --- } deriving Data - -laiIf :: Lens AnnsIf EpaLocation -laiIf k parent = fmap (\new -> parent { aiIf = new }) - (k (aiIf parent)) - -laiThen :: Lens AnnsIf EpaLocation -laiThen k parent = fmap (\new -> parent { aiThen = new }) - (k (aiThen parent)) - -laiElse :: Lens AnnsIf EpaLocation -laiElse k parent = fmap (\new -> parent { aiElse = new }) - (k (aiElse parent)) - -laiThenSemi :: Lens AnnsIf (Maybe EpaLocation) -laiThenSemi k parent = fmap (\new -> parent { aiThenSemi = new }) - (k (aiThenSemi parent)) - -laiElseSemi :: Lens AnnsIf (Maybe EpaLocation) -laiElseSemi k parent = fmap (\new -> parent { aiElseSemi = new }) - (k (aiElseSemi parent)) - --- ------------------------------------- - --- data AnnParen --- = AnnParen { --- ap_adornment :: ParenType, --- ap_open :: EpaLocation, --- ap_close :: EpaLocation --- } deriving (Data) - --- lap_open :: Lens AnnParen EpaLocation --- lap_open k parent = fmap (\new -> parent { ap_open = new }) --- (k (ap_open parent)) - --- lap_close :: Lens AnnParen EpaLocation --- lap_close k parent = fmap (\new -> parent { ap_close = new }) --- (k (ap_close parent)) - --- ------------------------------------- --- data EpAnnHsCase = EpAnnHsCase --- { hsCaseAnnCase :: EpaLocation --- , hsCaseAnnOf :: EpaLocation --- , hsCaseAnnsRest :: [AddEpAnn] --- } deriving Data - -lhsCaseAnnCase :: Lens EpAnnHsCase EpaLocation -lhsCaseAnnCase k parent = fmap (\new -> parent { hsCaseAnnCase = new }) - (k (hsCaseAnnCase parent)) - -lhsCaseAnnOf :: Lens EpAnnHsCase EpaLocation -lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new }) - (k (hsCaseAnnOf parent)) - -lhsCaseAnnsRest :: Lens EpAnnHsCase [AddEpAnn] -lhsCaseAnnsRest k parent = fmap (\new -> parent { hsCaseAnnsRest = new }) - (k (hsCaseAnnsRest parent)) - --- --------------------------------------------------------------------- - --- data HsRuleAnn --- = HsRuleAnn --- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn) --- -- ^ The locations of 'forall' and '.' for forall'd type vars --- -- Using AddEpAnn to capture possible unicode variants --- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn) --- -- ^ The locations of 'forall' and '.' for forall'd term vars --- -- Using AddEpAnn to capture possible unicode variants --- , ra_rest :: [AddEpAnn] --- } deriving (Data, Eq) - -lra_tyanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn)) -lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new }) - (k (ra_tyanns parent)) - -ff :: Maybe (a,b) -> (Maybe a,Maybe b) -ff Nothing = (Nothing, Nothing) -ff (Just (a,b)) = (Just a, Just b) - - -gg :: (Maybe a,Maybe b) -> Maybe (a,b) -gg (Nothing, Nothing) = Nothing -gg (Just a, Just b) = Just (a,b) -gg _ = error "gg:expecting two Nothing or two Just" - -lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b) -lff k parent = fmap (\new -> gg new) - (k (ff parent)) - --- (.) :: Lens' a b -> Lens' b c -> Lens' a c -lra_tyanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tyanns_fst = lra_tyanns . lff . lfst - -lra_tyanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tyanns_snd = lra_tyanns . lff . lsnd - -lra_tmanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn)) -lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new }) - (k (ra_tmanns parent)) - -lra_tmanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tmanns_fst = lra_tmanns . lff . lfst - -lra_tmanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tmanns_snd = lra_tmanns . lff . lsnd - -lra_rest :: Lens HsRuleAnn [AddEpAnn] -lra_rest k parent = fmap (\new -> parent { ra_rest = new }) - (k (ra_rest parent)) - - --- --------------------------------------------------------------------- --- data GrhsAnn --- = GrhsAnn { --- ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this? --- ga_sep :: AddEpAnn -- ^ Match separator location --- } deriving (Data) - -lga_vbar :: Lens GrhsAnn (Maybe EpaLocation) -lga_vbar k parent = fmap (\new -> parent { ga_vbar = new }) - (k (ga_vbar parent)) - -lga_sep :: Lens GrhsAnn AddEpAnn -lga_sep k parent = fmap (\new -> parent { ga_sep = new }) - (k (ga_sep parent)) - --- --------------------------------------------------------------------- --- data AnnSig --- = AnnSig { --- asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option --- asRest :: [AddEpAnn] --- } deriving Data - -lasDcolon :: Lens AnnSig AddEpAnn -lasDcolon k parent = fmap (\new -> parent { asDcolon = new }) - (k (asDcolon parent)) - -lasRest :: Lens AnnSig [AddEpAnn] -lasRest k parent = fmap (\new -> parent { asRest = new }) - (k (asRest parent)) - --- --------------------------------------------------------------------- --- data EpAnnSumPat = EpAnnSumPat --- { sumPatParens :: [AddEpAnn] --- , sumPatVbarsBefore :: [EpaLocation] --- , sumPatVbarsAfter :: [EpaLocation] --- } deriving Data - -lsumPatParens :: Lens EpAnnSumPat [AddEpAnn] -lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new }) - (k (sumPatParens parent)) - -lsumPatVbarsBefore :: Lens EpAnnSumPat [EpaLocation] -lsumPatVbarsBefore k parent = fmap (\new -> parent { sumPatVbarsBefore = new }) - (k (sumPatVbarsBefore parent)) - -lsumPatVbarsAfter :: Lens EpAnnSumPat [EpaLocation] -lsumPatVbarsAfter k parent = fmap (\new -> parent { sumPatVbarsAfter = new }) - (k (sumPatVbarsAfter parent)) - --- End of lenses --- --------------------------------------------------------------------- - -markLensKwA :: (Monad m, Monoid w) - => a -> Lens a AddEpAnn -> EP w m a -markLensKwA a l = do - loc <- markKw (view l a) - return (set l loc a) - -markLensKw' :: (Monad m, Monoid w) - => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) -markLensKw' (EpAnn anc a cs) l kw = do - loc <- markKwA kw (view l a) - return (EpAnn anc (set l loc a) cs) - -markLensKw :: (Monad m, Monoid w) - => a -> Lens a EpaLocation -> AnnKeywordId -> EP w m a -markLensKw a l kw = do - loc <- markKwA kw (view l a) - return (set l loc a) - -markAnnKwAllL :: (Monad m, Monoid w) - => a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m a -markAnnKwAllL a l kw = do - anns <- mapM (markKwA kw) (view l a) - return (set l anns a) - -markLensKwM :: (Monad m, Monoid w) - => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a) -markLensKwM (EpAnn anc a cs) l kw = do - new <- go (view l a) - return (EpAnn anc (set l new a) cs) - where - go Nothing = return Nothing - go (Just s) = Just <$> markKwA kw s - -markLensKwM' :: (Monad m, Monoid w) - => a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m a -markLensKwM' a l kw = do - new <- go (view l a) - return (set l new a) - where - go Nothing = return Nothing - go (Just s) = Just <$> markKwA kw s - --- --------------------------------------------------------------------- - -markEpAnnL' :: (Monad m, Monoid w) - => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) -markEpAnnL' epann l kw = markEpAnnL epann (lepa . l) kw - -markEpAnnL :: (Monad m, Monoid w) - => ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m ann -markEpAnnL a l kw = do - anns <- mark (view l a) kw - return (set l anns a) - --- ------------------------------------- - -markEpAnnAllL :: (Monad m, Monoid w) - => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) -markEpAnnAllL (EpAnn anc a cs) l kw = do - anns <- mapM doit (view l a) - return (EpAnn anc (set l anns a) cs) - where - doit an@(AddEpAnn ka _) - = if ka == kw - then markKw an - else return an - -markEpAnnAllL' :: (Monad m, Monoid w) - => ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m ann -markEpAnnAllL' a l kw = do - anns <- mapM doit (view l a) - return (set l anns a) - where - doit an@(AddEpAnn ka _) - = if ka == kw - then markKw an - else return an - -markAddEpAnn :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn -markAddEpAnn a@(AddEpAnn kw _) = do - r <- mark [a] kw - case r of - [a'] -> return a' - _ -> error "Should not happen: markAddEpAnn" - -mark :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m [AddEpAnn] -mark anns kw = do - case find' kw anns of - (lead, Just aa, end) -> do - aa' <- markKw aa - return (lead ++ [aa'] ++ end) - (_lead, Nothing, _end) -> case find' (unicodeAnn kw) anns of - (leadu, Just aau, endu) -> do - aau' <- markKw aau - return (leadu ++ [aau'] ++ endu) - (_,Nothing,_) -> return anns - --- | Find for update, returning lead section of the list, item if --- found, and tail of the list -find' :: AnnKeywordId -> [AddEpAnn] -> ([AddEpAnn], Maybe AddEpAnn, [AddEpAnn]) -find' kw anns = (lead, middle, end) - where - (lead, rest) = break (\(AddEpAnn k _) -> k == kw) anns - (middle,end) = case rest of - [] -> (Nothing, []) - (x:xs) -> (Just x, xs) - -markKw :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn -markKw an = markKwC CaptureComments an - -markKwC :: (Monad m, Monoid w) => CaptureComments -> AddEpAnn -> EP w m AddEpAnn -markKwC capture (AddEpAnn kw ss) = do - ss' <- markKwAC capture kw ss - return (AddEpAnn kw ss') - --- | This should be the main driver of the process, managing printing keywords. --- It returns the 'EpaDelta' variant of the passed in 'EpaLocation' -markKwA :: (Monad m, Monoid w) => AnnKeywordId -> EpaLocation -> EP w m EpaLocation -markKwA kw aa = markKwAC CaptureComments kw aa - -markKwAC :: (Monad m, Monoid w) - => CaptureComments -> AnnKeywordId -> EpaLocation -> EP w m EpaLocation -markKwAC capture kw aa = printStringAtAAC capture aa (keywordToString kw) - --- | Print a keyword encoded in a 'TrailingAnn' -markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn -markKwT (AddSemiAnn ss) = AddSemiAnn <$> markKwA AnnSemi ss -markKwT (AddCommaAnn ss) = AddCommaAnn <$> markKwA AnnComma ss -markKwT (AddVbarAnn ss) = AddVbarAnn <$> markKwA AnnVbar ss -markKwT (AddDarrowAnn ss) = AddDarrowAnn <$> markKwA AnnDarrow ss -markKwT (AddDarrowUAnn ss) = AddDarrowUAnn <$> markKwA AnnDarrowU ss - --- --------------------------------------------------------------------- - -markAnnList :: (Monad m, Monoid w) - => EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) -markAnnList ann action = do - markAnnListA ann $ \a -> do - r <- action - return (a,r) - -markAnnList' :: (Monad m, Monoid w) - => AnnList -> EP w m a -> EP w m (AnnList, a) -markAnnList' ann action = do - markAnnListA' ann $ \a -> do - r <- action - return (a,r) - -markAnnListA :: (Monad m, Monoid w) - => EpAnn AnnList - -> (EpAnn AnnList -> EP w m (EpAnn AnnList, a)) - -> EP w m (EpAnn AnnList, a) -markAnnListA an action = do - an0 <- markLensMAA an lal_open - an1 <- markEpAnnAllL an0 lal_rest AnnSemi - (an2, r) <- action an1 - an3 <- markLensMAA an2 lal_close - return (an3, r) - -markAnnListA' :: (Monad m, Monoid w) - => AnnList - -> (AnnList -> EP w m (AnnList, a)) - -> EP w m (AnnList, a) -markAnnListA' an action = do - an0 <- markLensMAA' an lal_open - an1 <- markEpAnnAllL' an0 lal_rest AnnSemi - (an2, r) <- action an1 - an3 <- markLensMAA' an2 lal_close - return (an3, r) - --- --------------------------------------------------------------------- - -printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () -printCommentsBefore ss = do - cs <- commentAllocationBefore ss - debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) - mapM_ printOneComment cs - -printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () -printCommentsIn ss = do - cs <- commentAllocationIn ss - debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) - mapM_ printOneComment cs - debugM $ "printCommentsIn:done" - --- --------------------------------------------------------------------- - -printOneComment :: (Monad m, Monoid w) => Comment -> EP w m () -printOneComment c@(Comment _str loc _r _mo) = do - debugM $ "printOneComment:c=" ++ showGhc c - dp <-case loc of - EpaDelta dp _ -> return dp - EpaSpan (RealSrcSpan r _) -> do - pe <- getPriorEndD - debugM $ "printOneComment:pe=" ++ showGhc pe - let dp = ss2delta pe r - debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc) - adjustDeltaForOffsetM dp - EpaSpan (UnhelpfulSpan _) -> return (SameLine 0) - mep <- getExtraDP - dp' <- case mep of - Just (EpaDelta edp _) -> do - debugM $ "printOneComment:edp=" ++ show edp - adjustDeltaForOffsetM edp - _ -> return dp - -- Start of debug printing - LayoutStartCol dOff <- getLayoutOffsetD - debugM $ "printOneComment:(dp,dp',dOff,loc)=" ++ showGhc (dp,dp',dOff,loc) - -- End of debug printing - updateAndApplyComment c dp' - printQueuedComment c dp' - -updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () -updateAndApplyComment (Comment str anc pp mo) dp = do - applyComment (Comment str anc' pp mo) - where - (r,c) = ss2posEnd pp - dp'' = case anc of - EpaDelta dp1 _ -> dp1 - EpaSpan (RealSrcSpan la _) -> - if r == 0 - then (ss2delta (r,c+0) la) - else (ss2delta (r,c) la) - EpaSpan (UnhelpfulSpan _) -> SameLine 0 - dp' = case anc of - EpaSpan (RealSrcSpan r1 _) -> - if pp == r1 - then dp - else dp'' - _ -> dp'' - op' = case dp' of - SameLine n -> if n >= 0 - then EpaDelta dp' NoComments - else EpaDelta dp NoComments - _ -> EpaDelta dp' NoComments - anc' = if str == "" && op' == EpaDelta (SameLine 0) NoComments -- EOF comment - then EpaDelta dp NoComments - else EpaDelta dp NoComments - --- --------------------------------------------------------------------- - -commentAllocationBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] -commentAllocationBefore 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 _r _mo) -> - case loc of - EpaSpan (RealSrcSpan r _) -> (ss2pos r) <= (ss2pos ss) - _ -> True -- Choose one - ) cs - putUnallocatedComments later - -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) - return earlier - -commentAllocationIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] -commentAllocationIn 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 _r _mo) -> - case loc of - EpaSpan (RealSrcSpan r _) -> (ss2posEnd r) <= (ss2posEnd ss) - _ -> True -- Choose one - ) cs - putUnallocatedComments later - -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) - return earlier --- --------------------------------------------------------------------- - -markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast -markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a - --- --------------------------------------------------------------------- - -markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast] -markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls - --- --------------------------------------------------------------------- --- End of utility functions --- --------------------------------------------------------------------- --- Start of ExactPrint instances --- --------------------------------------------------------------------- - --- | Bare Located elements are simply stripped off without further --- processing. -instance (ExactPrint a) => ExactPrint (Located a) where - getAnnotationEntry (L l _) = case l of - UnhelpfulSpan _ -> NoEntryVal - _ -> Entry (EpaSpan l) [] emptyComments NoFlushComments CanUpdateAnchorOnly - - setAnnotationAnchor (L l a) _anc _ts _cs = L l a - - exact (L l a) = L l <$> markAnnotated a - -instance (ExactPrint a) => ExactPrint (LocatedE a) where - getAnnotationEntry (L l _) = Entry l [] emptyComments NoFlushComments CanUpdateAnchorOnly - setAnnotationAnchor (L _ a) anc _ts _cs = L anc a - - exact (L la a) = do - debugM $ "LocatedE a:la loc=" ++ show (ss2range $ locA la) - a' <- markAnnotated a - return (L la a') - -instance (ExactPrint a) => ExactPrint (LocatedA a) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs - exact (L la a) = do - debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) - a' <- markAnnotated a - return (L la a') - -instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs - exact (L la a) = do - a' <- markAnnotated a - return (L la a') - -instance (ExactPrint a) => ExactPrint [a] where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor ls _ _ _ = ls - exact ls = mapM markAnnotated ls - -instance (ExactPrint a) => ExactPrint (Maybe a) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor ma _ _ _ = ma - exact ma = mapM markAnnotated ma - --- --------------------------------------------------------------------- - --- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' -instance ExactPrint (HsModule GhcPs) where - getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod) - -- A bit pointless actually changing anything here - setAnnotationAnchor hsmod anc _ts cs = setAnchorHsModule hsmod anc cs - `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs)) - - exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do - - let mbDoc' = mbDoc - - (an0, mmn' , mdeprec', mexports') <- - case mmn of - Nothing -> return (an, mmn, mdeprec, mexports) - Just m -> do - an0 <- markEpAnnL' an lam_main AnnModule - m' <- markAnnotated m - - mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec - - mexports' <- setLayoutTopLevelP $ markAnnotated mexports - - an1 <- setLayoutTopLevelP $ markEpAnnL' an0 lam_main AnnWhere - - return (an1, Just m', mdeprec', mexports') - - lo0 <- case lo of - EpExplicitBraces open close -> do - open' <- markEpToken open - return (EpExplicitBraces open' close) - _ -> return lo - - am_decls' <- markTrailing (am_decls $ anns an0) - - mid <- markAnnotated (HsModuleImpDecls (am_cs $ anns an0) imports decls) - let imports' = id_imps mid - let decls' = id_decls mid - - lo1 <- case lo0 of - EpExplicitBraces open close -> do - close' <- markEpToken close - return (EpExplicitBraces open close') - _ -> return lo - - -- Print EOF - case am_eof $ anns an of - Nothing -> return () - Just (pos, prior) -> do - debugM $ "am_eof:" ++ showGhc (pos, prior) - setEofPos (Just (pos, prior)) - - let anf = an0 { anns = (anns an0) { am_decls = am_decls', am_cs = [] }} - debugM $ "HsModule, anf=" ++ showAst anf - - return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls') - --- --------------------------------------------------------------------- - --- | This is used to ensure the comments are updated into the right --- place for makeDeltaAst. -data HsModuleImpDecls - = HsModuleImpDecls { - id_cs :: [LEpaComment], - id_imps :: [LImportDecl GhcPs], - id_decls :: [LHsDecl GhcPs] - } deriving Data - -instance ExactPrint HsModuleImpDecls where - -- Use an UnHelpfulSpan for the anchor, we are only interested in the comments - getAnnotationEntry mid = mkEntry (EpaSpan (UnhelpfulSpan UnhelpfulNoLocationInfo)) [] (EpaComments (id_cs mid)) - setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs } - `debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs) - exact (HsModuleImpDecls cs imports decls) = do - imports' <- markTopLevelList imports - decls' <- markTopLevelList (filter notDocDecl decls) - return (HsModuleImpDecls cs imports' decls') - - --- --------------------------------------------------------------------- - -instance ExactPrint ModuleName where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor n _anc _ cs = n - `debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs) - exact n = do - debugM $ "ModuleName: " ++ showPprUnsafe n - withPpr n - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - - exact (L an (WarningTxt mb_cat src ws)) = do - an0 <- markAnnOpenP an src "{-# WARNING" - mb_cat' <- markAnnotated mb_cat - an1 <- markEpAnnL' an0 lapr_rest AnnOpenS - ws' <- markAnnotated ws - an2 <- markEpAnnL' an1 lapr_rest AnnCloseS - an3 <- markAnnCloseP an2 - return (L an3 (WarningTxt mb_cat' src ws')) - - exact (L an (DeprecatedTxt src ws)) = do - an0 <- markAnnOpenP an src "{-# DEPRECATED" - an1 <- markEpAnnL' an0 lapr_rest AnnOpenS - ws' <- markAnnotated ws - an2 <- markEpAnnL' an1 lapr_rest AnnCloseS - an3 <- markAnnCloseP an2 - return (L an3 (DeprecatedTxt src ws')) - -instance ExactPrint InWarningCategory where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (InWarningCategory tkIn source (L l wc)) = do - tkIn' <- markEpToken tkIn - L l' (_,wc') <- markAnnotated (L l (source, wc)) - return (InWarningCategory tkIn' source (L l' wc')) - -instance ExactPrint (SourceText, WarningCategory) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (st, WarningCategory wc) = do - case st of - NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\"" - SourceText src -> printStringAdvance $ (unpackFS src) - return (st, WarningCategory wc) - --- --------------------------------------------------------------------- - -instance ExactPrint (ImportDecl GhcPs) where - getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl) - setAnnotationAnchor idecl anc ts cs = idecl { ideclExt - = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} } - - exact (ImportDecl (XImportDeclPass ann msrc impl) - modname mpkg src safeflag qualFlag mAs hiding) = do - - ann0 <- markLensKw' ann limportDeclAnnImport AnnImport - let (EpAnn _anc an _cs) = ann0 - - -- "{-# SOURCE" and "#-}" - importDeclAnnPragma' <- - case msrc of - SourceText _txt -> do - debugM $ "ImportDecl sourcetext" - case importDeclAnnPragma an of - Just (mo, mc) -> do - mo' <- markAnnOpen'' mo msrc "{-# SOURCE" - mc' <- printStringAtAA mc "#-}" - return $ Just (mo', mc') - Nothing -> do - _ <- markAnnOpen' Nothing msrc "{-# SOURCE" - printStringAtLsDelta (SameLine 1) "#-}" - return Nothing - NoSourceText -> return (importDeclAnnPragma an) - ann1 <- if safeflag - then (markLensKwM ann0 limportDeclAnnSafe AnnSafe) - else return ann0 - ann2 <- - case qualFlag of - QualifiedPre -- 'qualified' appears in prepositive position. - -> printStringAtMLocL ann1 limportDeclAnnQualified "qualified" - _ -> return ann1 - ann3 <- - case mpkg of - RawPkgQual (StringLiteral src' v _) -> - printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) - _ -> return ann2 - modname' <- markAnnotated modname - - ann4 <- - case qualFlag of - QualifiedPost -- 'qualified' appears in postpositive position. - -> printStringAtMLocL ann3 limportDeclAnnQualified "qualified" - _ -> return ann3 - - (importDeclAnnAs', mAs') <- - case mAs of - Nothing -> return (importDeclAnnAs an, Nothing) - Just m0 -> do - a <- printStringAtMLoc' (importDeclAnnAs an) "as" - m'' <- markAnnotated m0 - return (a, Just m'') - - hiding' <- - case hiding of - Nothing -> return hiding - Just (isHiding,lie) -> do - lie' <- markAnnotated lie - return (Just (isHiding, lie')) - - let (EpAnn anc' an' cs') = ann4 - let an2 = an' { importDeclAnnAs = importDeclAnnAs' - , importDeclAnnPragma = importDeclAnnPragma' - } - - return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) - modname' mpkg src safeflag qualFlag mAs' hiding') - - --- --------------------------------------------------------------------- - -instance ExactPrint HsDocString where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (MultiLineDocString decorator (x :| xs)) = do - printStringAdvance ("-- " ++ printDecorator decorator) - pe <- getPriorEndD - debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x) - x' <- markAnnotated x - xs' <- markAnnotated (map dedentDocChunk xs) - return (MultiLineDocString decorator (x' :| xs')) - exact x = do - -- TODO: can this happen? - debugM $ "Not exact printing:" ++ showAst x - return x - - -instance ExactPrint HsDocStringChunk where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact chunk = do - printStringAdvance ("--" ++ unpackHDSC chunk) - return chunk - - -instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (WithHsDocIdentifiers ds ids) = do - ds' <- exact ds - return (WithHsDocIdentifiers ds' ids) - --- --------------------------------------------------------------------- - -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 - - -- We do not recurse, the generic traversal using this feature - -- should do that for us. - setAnnotationAnchor d _ _ _ = d - - exact (TyClD x d) = TyClD x <$> markAnnotated d - exact (InstD x d) = InstD x <$> markAnnotated d - exact (DerivD x d) = DerivD x <$> markAnnotated d - exact (ValD x d) = ValD x <$> markAnnotated d - exact (SigD x d) = SigD x <$> markAnnotated d - exact (KindSigD x d) = KindSigD x <$> markAnnotated d - exact (DefD x d) = DefD x <$> markAnnotated d - exact (ForD x d) = ForD x <$> markAnnotated d - exact (WarningD x d) = WarningD x <$> markAnnotated d - exact (AnnD x d) = AnnD x <$> markAnnotated d - exact (RuleD x d) = RuleD x <$> markAnnotated d - exact (SpliceD x d) = SpliceD x <$> markAnnotated d - exact (DocD x d) = DocD x <$> markAnnotated d - exact (RoleAnnotD x d) = RoleAnnotD x <$> markAnnotated d - --- --------------------------------------------------------------------- - -instance ExactPrint (InstDecl GhcPs) where - getAnnotationEntry (ClsInstD _ _) = NoEntryVal - getAnnotationEntry (DataFamInstD _ _) = NoEntryVal - getAnnotationEntry (TyFamInstD _ _) = NoEntryVal - - setAnnotationAnchor d _ _ _ = d - - - exact (ClsInstD a cid) = do - cid' <- markAnnotated cid - return (ClsInstD a cid') - exact (DataFamInstD a decl) = do - d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl) - return (DataFamInstD a (dc_d d')) - exact (TyFamInstD a eqn) = do - eqn' <- markAnnotated eqn - return (TyFamInstD a eqn') - --- --------------------------------------------------------------------- - -data DataFamInstDeclWithContext - = DataFamInstDeclWithContext - { _dc_a :: [AddEpAnn] - , _dc_f :: TopLevelFlag - , dc_d :: DataFamInstDecl GhcPs - } - -instance ExactPrint DataFamInstDeclWithContext where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (DataFamInstDeclWithContext an c d) = do - debugM $ "starting DataFamInstDeclWithContext:an=" ++ showAst an - (an', d') <- exactDataFamInstDecl an c d - return (DataFamInstDeclWithContext an' c d') - --- --------------------------------------------------------------------- - -exactDataFamInstDecl :: (Monad m, Monoid w) - => [AddEpAnn] -> TopLevelFlag -> DataFamInstDecl GhcPs - -> EP w m ([AddEpAnn], DataFamInstDecl GhcPs) -exactDataFamInstDecl an top_lvl - (DataFamInstDecl (FamEqn { feqn_ext = an2 - , feqn_tycon = tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = defn })) = do - (an', an2', tycon', bndrs', pats', defn') <- exactDataDefn an2 pp_hdr defn - -- See Note [an and an2 in exactDataFamInstDecl] - return - (an', - DataFamInstDecl ( FamEqn { feqn_ext = an2' - , feqn_tycon = tycon' - , feqn_bndrs = bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = defn' })) - `debug` ("exactDataFamInstDecl: defn' derivs:" ++ showAst (dd_derivs defn')) - where - pp_hdr :: (Monad m, Monoid w) - => Maybe (LHsContext GhcPs) - -> EP w m ( [AddEpAnn] - , LocatedN RdrName - , HsOuterTyVarBndrs () GhcPs - , HsFamEqnPats GhcPs - , Maybe (LHsContext GhcPs)) - pp_hdr mctxt = do - an0 <- case top_lvl of - TopLevel -> markEpAnnL an lidl AnnInstance -- TODO: maybe in toplevel - NotTopLevel -> return an - exactHsFamInstLHS an0 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 _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (DerivDecl (mw, an) typ ms mov) = do - an0 <- markEpAnnL an lidl AnnDeriving - ms' <- mapM markAnnotated ms - an1 <- markEpAnnL an0 lidl AnnInstance - mw' <- mapM markAnnotated mw - mov' <- mapM markAnnotated mov - typ' <- markAnnotated typ - return (DerivDecl (mw', an1) typ' ms' mov') - --- --------------------------------------------------------------------- - -instance ExactPrint (ForeignDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (ForeignImport an n ty fimport) = do - an0 <- markEpAnnL an lidl AnnForeign - an1 <- markEpAnnL an0 lidl AnnImport - - fimport' <- markAnnotated fimport - - n' <- markAnnotated n - an2 <- markEpAnnL an1 lidl AnnDcolon - ty' <- markAnnotated ty - return (ForeignImport an2 n' ty' fimport') - - exact (ForeignExport an n ty fexport) = do - an0 <- markEpAnnL an lidl AnnForeign - an1 <- markEpAnnL an0 lidl AnnExport - fexport' <- markAnnotated fexport - n' <- markAnnotated n - an2 <- markEpAnnL an1 lidl AnnDcolon - ty' <- markAnnotated ty - return (ForeignExport an2 n' ty' fexport') - --- --------------------------------------------------------------------- - -instance ExactPrint (ForeignImport GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do - cconv' <- markAnnotated cconv - safety' <- if notDodgyE l - then markAnnotated safety - else return safety - ls' <- if notDodgyE ls - then markExternalSourceTextE ls src "" - else return ls - return (CImport (L ls' src) cconv' safety' mh imp) - --- --------------------------------------------------------------------- - -instance ExactPrint (ForeignExport GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (CExport (L ls src) spec) = do - debugM $ "CExport starting" - spec' <- markAnnotated spec - ls' <- if notDodgyE ls - then markExternalSourceTextE ls src "" - else return ls - return (CExport (L ls' src) spec') - --- --------------------------------------------------------------------- - -instance ExactPrint CExportSpec where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (CExportStatic st lbl cconv) = do - debugM $ "CExportStatic starting" - cconv' <- markAnnotated cconv - return (CExportStatic st lbl cconv') - --- --------------------------------------------------------------------- - -instance ExactPrint Safety where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint CCallConv where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint (WarnDecls GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (Warnings (an,src) warns) = do - an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED - warns' <- markAnnotated warns - an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") - return (Warnings (an1,src) warns') - --- --------------------------------------------------------------------- - -instance ExactPrint (WarnDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (Warning (ns_spec, an) lns (WarningTxt mb_cat src ls )) = do - mb_cat' <- markAnnotated mb_cat - ns_spec' <- exactNsSpec ns_spec - lns' <- markAnnotated lns - an0 <- markEpAnnL an lidl AnnOpenS -- "[" - ls' <- markAnnotated ls - an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" - return (Warning (ns_spec', an1) lns' (WarningTxt mb_cat' src ls')) - -- return (Warning an1 lns' (WarningTxt mb_cat' src ls')) - - exact (Warning (ns_spec, an) lns (DeprecatedTxt src ls)) = do - ns_spec' <- exactNsSpec ns_spec - lns' <- markAnnotated lns - an0 <- markEpAnnL an lidl AnnOpenS -- "[" - ls' <- markAnnotated ls - an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" - return (Warning (ns_spec', an1) lns' (DeprecatedTxt src ls')) - -- return (Warning an1 lns' (DeprecatedTxt src ls')) - -exactNsSpec :: (Monad m, Monoid w) => NamespaceSpecifier -> EP w m NamespaceSpecifier -exactNsSpec NoNamespaceSpecifier = pure NoNamespaceSpecifier -exactNsSpec (TypeNamespaceSpecifier type_) = do - type_' <- markEpToken type_ - pure (TypeNamespaceSpecifier type_') -exactNsSpec (DataNamespaceSpecifier data_) = do - data_' <- markEpToken data_ - pure (DataNamespaceSpecifier data_') - --- --------------------------------------------------------------------- - -instance ExactPrint StringLiteral where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (StringLiteral src fs mcomma) = do - printSourceTextAA src (show (unpackFS fs)) - mcomma' <- mapM (\r -> printStringAtNC r ",") mcomma - return (StringLiteral src fs mcomma') - - --- --------------------------------------------------------------------- - -instance ExactPrint FastString where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - -- exact fs = printStringAdvance (show (unpackFS fs)) - exact fs = printStringAdvance (unpackFS fs) >> return fs - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleDecls GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (HsRules (an, src) rules) = do - an0 <- - case src of - NoSourceText -> markEpAnnLMS'' an lidl AnnOpen (Just "{-# RULES") - SourceText srcTxt -> markEpAnnLMS'' an lidl AnnOpen (Just $ unpackFS srcTxt) - rules' <- markAnnotated rules - an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") - return (HsRules (an1,src) rules') - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do - (L ln' _) <- markAnnotated (L ln (nsrc, n)) - an0 <- markActivation an lra_rest act - (an1, mtybndrs') <- - case mtybndrs of - Nothing -> return (an0, Nothing) - Just bndrs -> do - an1 <- markLensMAA' an0 lra_tyanns_fst -- AnnForall - bndrs' <- mapM markAnnotated bndrs - an2 <- markLensMAA' an1 lra_tyanns_snd -- AnnDot - return (an2, Just bndrs') - - an2 <- markLensMAA' an1 lra_tmanns_fst -- AnnForall - termbndrs' <- mapM markAnnotated termbndrs - an3 <- markLensMAA' an2 lra_tmanns_snd -- AnnDot - - lhs' <- markAnnotated lhs - an4 <- markEpAnnL an3 lra_rest AnnEqual - rhs' <- markAnnotated rhs - return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') - -markActivation :: (Monad m, Monoid w) - => a -> Lens a [AddEpAnn] -> Activation -> EP w m a -markActivation an l act = do - case act of - ActiveBefore src phase -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnL an0 l AnnTilde -- ~ - an2 <- markEpAnnLMS'' an1 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - an3 <- markEpAnnL an2 l AnnCloseS -- ']' - return an3 - ActiveAfter src phase -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnLMS'' an0 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - an2 <- markEpAnnL an1 l AnnCloseS -- ']' - return an2 - NeverActive -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnL an0 l AnnTilde -- ~ - an2 <- markEpAnnL an1 l AnnCloseS -- ']' - return an2 - _ -> return an - --- --------------------------------------------------------------------- - -instance ExactPrint (SpliceDecl GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (SpliceDecl x splice flag) = do - splice' <- markAnnotated splice - return (SpliceDecl x splice' flag) - --- --------------------------------------------------------------------- - -instance ExactPrint (DocDecl GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - -- We print these as plain comments instead, do a NOP here. - exact v = return v - --- --------------------------------------------------------------------- - -instance ExactPrint (RoleAnnotDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (RoleAnnotDecl an ltycon roles) = do - an0 <- markEpAnnL an lidl AnnType - an1 <- markEpAnnL an0 lidl AnnRole - ltycon' <- markAnnotated ltycon - let markRole (L l (Just r)) = do - (L l' r') <- markAnnotated (L l r) - return (L l' (Just r')) - markRole (L l Nothing) = do - e' <- printStringAtAA (entry l) "_" - return (L (l { entry = e'}) Nothing) - roles' <- mapM markRole roles - return (RoleAnnotDecl an1 ltycon' roles') - --- --------------------------------------------------------------------- - -instance ExactPrint Role where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleBndr GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (RuleBndr x ln) = do - ln' <- markAnnotated ln - return (RuleBndr x ln') - exact (RuleBndrSig an ln (HsPS x ty)) = do - an0 <- markEpAnnL an lidl AnnOpenP -- "(" - ln' <- markAnnotated ln - an1 <- markEpAnnL an0 lidl AnnDcolon - ty' <- markAnnotated ty - an2 <- markEpAnnL an1 lidl AnnCloseP -- ")" - return (RuleBndrSig an2 ln' (HsPS x ty')) - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor fe _ _ _s = fe - exact (FamEqn { feqn_ext = an - , feqn_tycon = tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = rhs }) = do - (an0, tycon', bndrs', pats', _) <- exactHsFamInstLHS an tycon bndrs pats fixity Nothing - an1 <- markEpAnnL an0 lidl AnnEqual - rhs' <- markAnnotated rhs - return (FamEqn { feqn_ext = an1 - , feqn_tycon = tycon' - , feqn_bndrs = bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = rhs' }) - --- --------------------------------------------------------------------- - -exactHsFamInstLHS :: - (Monad m, Monoid w) - => [AddEpAnn] - -> LocatedN RdrName - -> HsOuterTyVarBndrs () GhcPs - -> HsFamEqnPats GhcPs - -> LexicalFixity - -> Maybe (LHsContext GhcPs) - -> EP w m ( [AddEpAnn] - , LocatedN RdrName - , HsOuterTyVarBndrs () GhcPs - , HsFamEqnPats GhcPs, Maybe (LHsContext GhcPs)) -exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do - an0 <- markEpAnnL an lidl AnnForall - bndrs' <- markAnnotated bndrs - an1 <- markEpAnnL an0 lidl AnnDot - mb_ctxt' <- mapM markAnnotated mb_ctxt - (an2, thing', typats') <- exact_pats an1 typats - return (an2, thing', bndrs', typats', mb_ctxt') - where - exact_pats :: (Monad m, Monoid w) - => [AddEpAnn] -> HsFamEqnPats GhcPs -> EP w m ([AddEpAnn], LocatedN RdrName, HsFamEqnPats GhcPs) - exact_pats an' (patl:patr:pats) - | Infix <- fixity - = let exact_op_app = do - an0 <- markEpAnnAllL' an' lidl AnnOpenP - patl' <- markAnnotated patl - thing' <- markAnnotated thing - patr' <- markAnnotated patr - an1 <- markEpAnnAllL' an0 lidl AnnCloseP - return (an1, thing', [patl',patr']) - in case pats of - [] -> exact_op_app - _ -> do - (an0, thing', p) <- exact_op_app - pats' <- mapM markAnnotated pats - return (an0, thing', p++pats') - - exact_pats an' pats = do - an0 <- markEpAnnAllL' an' lidl AnnOpenP - thing' <- markAnnotated thing - pats' <- markAnnotated pats - an1 <- markEpAnnAllL' an0 lidl AnnCloseP - return (an1, thing', pats') - --- --------------------------------------------------------------------- - -instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) - => ExactPrint (HsArg GhcPs tm ty) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsValArg x tm) = do - tm' <- markAnnotated tm - return (HsValArg x tm') - exact (HsTypeArg at ty) = do - at' <- markEpToken at - ty' <- markAnnotated ty - return (HsTypeArg at' ty') - exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source - --- --------------------------------------------------------------------- - -instance ExactPrint (ClsInstDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (ClsInstDecl { cid_ext = (mbWarn, 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 }) - = do - (mbWarn', an0, mbOverlap', inst_ty') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnAllL' an1 lid AnnSemi - (sortKey', ds) <- withSortKey sortKey - [(ClsAtTag, prepareListAnnotationA ats), - (ClsAtdTag, prepareListAnnotationF adts), - (ClsMethodTag, prepareListAnnotationA (bagToList binds)), - (ClsSigTag, prepareListAnnotationA sigs) - ] - an3 <- markEpAnnL an2 lidl AnnCloseC -- '}' - let - ats' = undynamic ds - adts' = undynamic ds - binds' = listToBag $ undynamic ds - sigs' = undynamic ds - return (ClsInstDecl { cid_ext = (mbWarn', an3, sortKey') - , cid_poly_ty = inst_ty', cid_binds = binds' - , cid_sigs = sigs', cid_tyfam_insts = ats' - , cid_overlap_mode = mbOverlap' - , cid_datafam_insts = adts' }) - - where - top_matter = do - an0 <- markEpAnnL an lidl AnnInstance - mw <- mapM markAnnotated mbWarn - mo <- mapM markAnnotated mbOverlap - it <- markAnnotated inst_ty - an1 <- markEpAnnL an0 lidl AnnWhere -- Optional - return (mw, an1, mo,it) - --- --------------------------------------------------------------------- - -instance ExactPrint (TyFamInstDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact d@(TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do - an0 <- markEpAnnL an lidl AnnType - an1 <- markEpAnnL an0 lidl AnnInstance - eqn' <- markAnnotated eqn - return (d { tfid_xtn = an1, tfid_eqn = eqn' }) - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP OverlapMode) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - - -- NOTE: NoOverlap is only used in the typechecker - exact (L an (NoOverlap src)) = do - an0 <- markAnnOpenP an src "{-# NO_OVERLAP" - an1 <- markAnnCloseP an0 - return (L an1 (NoOverlap src)) - - exact (L an (Overlappable src)) = do - an0 <- markAnnOpenP an src "{-# OVERLAPPABLE" - an1 <- markAnnCloseP an0 - return (L an1 (Overlappable src)) - - exact (L an (Overlapping src)) = do - an0 <- markAnnOpenP an src "{-# OVERLAPPING" - an1 <- markAnnCloseP an0 - return (L an1 (Overlapping src)) - - exact (L an (Overlaps src)) = do - an0 <- markAnnOpenP an src "{-# OVERLAPS" - an1 <- markAnnCloseP an0 - return (L an1 (Overlaps src)) - - exact (L an (Incoherent src)) = do - an0 <- markAnnOpenP an src "{-# INCOHERENT" - an1 <- markAnnCloseP an0 - return (L an1 (Incoherent src)) - - exact (L an (NonCanonical src)) = do - an0 <- markAnnOpenP an src "{-# INCOHERENT" - an1 <- markAnnCloseP an0 - return (L an1 (Incoherent src)) - --- --------------------------------------------------------------------- - -instance ExactPrint (HsBind GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (FunBind x fid matches) = do - matches' <- markAnnotated matches - let - fun_id' = case unLoc (mg_alts matches') of - [] -> fid - (L _ m:_) -> case m_ctxt m of - FunRhs f _ _ -> f - _ -> fid - return (FunBind x fun_id' matches') - - exact (PatBind x pat q grhss) = do - q' <- markAnnotated q - pat' <- markAnnotated pat - grhss' <- markAnnotated grhss - return (PatBind x pat' q' grhss') - exact (PatSynBind x bind) = do - bind' <- markAnnotated bind - return (PatSynBind x bind') - - exact x = error $ "HsBind: exact for " ++ showAst x - -instance ExactPrint (HsMultAnn GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsNoMultAnn x) = return (HsNoMultAnn x) - exact (HsPct1Ann tok) = do - tok' <- markEpToken tok - return (HsPct1Ann tok') - exact (HsMultAnn tok ty) = do - tok' <- markEpToken tok - ty' <- markAnnotated ty - return (HsMultAnn tok' ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (PatSynBind GhcPs GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (PSB{ psb_ext = an - , psb_id = psyn, psb_args = details - , psb_def = pat - , psb_dir = dir }) = do - an0 <- markEpAnnL an lidl AnnPattern - (an1, psyn', details') <- - case details of - InfixCon v1 v2 -> do - v1' <- markAnnotated v1 - psyn' <- markAnnotated psyn - v2' <- markAnnotated v2 - return (an0, psyn',InfixCon v1' v2') - PrefixCon tvs vs -> do - psyn' <- markAnnotated psyn - tvs' <- markAnnotated tvs - vs' <- markAnnotated vs - return (an0, psyn', PrefixCon tvs' vs') - RecCon vs -> do - psyn' <- markAnnotated psyn - an1 <- markEpAnnL an0 lidl AnnOpenC -- '{' - vs' <- markAnnotated vs - an2 <- markEpAnnL an1 lidl AnnCloseC -- '}' - return (an2, psyn', RecCon vs') - - (an2, pat', dir') <- - case dir of - Unidirectional -> do - an2 <- markEpAnnL an1 lidl AnnLarrow - pat' <- markAnnotated pat - return (an2, pat', dir) - ImplicitBidirectional -> do - an2 <- markEpAnnL an1 lidl AnnEqual - pat' <- markAnnotated pat - return (an2, pat', dir) - ExplicitBidirectional mg -> do - an2 <- markEpAnnL an1 lidl AnnLarrow - pat' <- markAnnotated pat - an3 <- markEpAnnL an2 lidl AnnWhere - mg' <- markAnnotated mg - return (an3, pat', ExplicitBidirectional mg') - - return (PSB{ psb_ext = an2 - , psb_id = psyn', psb_args = details' - , psb_def = pat' - , psb_dir = dir' }) - - --- --------------------------------------------------------------------- - -instance ExactPrint (RecordPatSynField GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (RecordPatSynField f v) = do - f' <- markAnnotated f - return (RecordPatSynField f' v) - --- --------------------------------------------------------------------- - -instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (Match an mctxt pats grhss) = - exactMatch (Match an mctxt pats grhss) - --- ------------------------------------- - -instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (Match an mctxt pats grhss) = - exactMatch (Match an mctxt pats grhss) - --- --------------------------------------------------------------------- - -exactMatch :: (Monad m, Monoid w, ExactPrint (GRHSs GhcPs body)) - => (Match GhcPs body) -> EP w m (Match GhcPs body) -exactMatch (Match an mctxt pats grhss) = do - - debugM $ "exact Match entered" - - (an0, mctxt', pats') <- - case mctxt of - FunRhs fun fixity strictness -> do - debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun - an0' <- - case strictness of - SrcStrict -> markEpAnnL an lidl AnnBang - _ -> pure an - case fixity of - Prefix -> do - an' <- annotationsToComments an0' lidl [AnnOpenP,AnnCloseP] - fun' <- markAnnotated fun - pats' <- markAnnotated pats - return (an', FunRhs fun' fixity strictness, pats') - Infix -> - case pats of - (p1:p2:rest) - | null rest -> do - p1' <- markAnnotated p1 - fun' <- markAnnotated fun - p2' <- markAnnotated p2 - return (an0', FunRhs fun' fixity strictness, [p1',p2']) - | otherwise -> do - an0 <- markEpAnnL an0' lidl AnnOpenP - p1' <- markAnnotated p1 - fun' <- markAnnotated fun - p2' <- markAnnotated p2 - an1 <- markEpAnnL an0 lidl AnnCloseP - rest' <- mapM markAnnotated rest - return (an1, FunRhs fun' fixity strictness, p1':p2':rest') - _ -> panic "FunRhs" - - -- ToDo: why is LamSingle treated differently? - LamAlt LamSingle -> do - an0' <- markEpAnnL an lidl AnnLam - pats' <- markAnnotated pats - return (an0', LamAlt LamSingle, pats') - LamAlt v -> do - pats' <- markAnnotated pats - return (an, LamAlt v, pats') - - CaseAlt -> do - pats' <- markAnnotated pats - return (an, CaseAlt, pats') - _ -> do - mctxt' <- withPpr mctxt - return (an, mctxt', pats) - - grhss' <- markAnnotated grhss - - return (Match an0 mctxt' pats' grhss') - --- --------------------------------------------------------------------- - -instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (GRHSs _ _ _) = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (GRHSs cs grhss binds) = do - addCommentsA $ priorComments cs - addCommentsA $ getFollowingComments cs - grhss' <- markAnnotated grhss - binds' <- markAnnotated binds - -- The comments will be added back as they are printed - return (GRHSs emptyComments grhss' binds') - - -instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (GRHSs _ _ _) = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (GRHSs cs grhss binds) = do - addCommentsA $ priorComments cs - addCommentsA $ getFollowingComments cs - grhss' <- markAnnotated grhss - binds' <- markAnnotated binds - -- The comments will be added back as they are printed - return (GRHSs emptyComments grhss' binds') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsLocalBinds GhcPs) where - getAnnotationEntry (HsValBinds an _) = fromAnn an - getAnnotationEntry (HsIPBinds{}) = NoEntryVal - getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal - - setAnnotationAnchor (HsValBinds an a) anc ts cs = HsValBinds (setAnchorEpaL an anc ts cs) a - setAnnotationAnchor a _ _ _ = a - - exact (HsValBinds an valbinds) = do - debugM $ "exact HsValBinds: an=" ++ showAst an - an0 <- markEpAnnL' an lal_rest AnnWhere - - case al_anchor $ anns an of - Just anc -> do - when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) - _ -> return () - - (an1, valbinds') <- markAnnList an0 $ markAnnotatedWithLayout valbinds - debugM $ "exact HsValBinds: an1=" ++ showAst an1 - medr <- getExtraDPReturn - an2 <- case medr of - Nothing -> return an1 - Just dp -> do - setExtraDPReturn Nothing - return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta dp []) }} - return (HsValBinds an2 valbinds') - - exact (HsIPBinds an bs) = do - (an2,bs') <- markAnnListA an $ \an0 -> do - an1 <- markEpAnnL' an0 lal_rest AnnWhere - bs' <- markAnnotated bs - return (an1, bs') - return (HsIPBinds an2 bs') - exact b@(EmptyLocalBinds _) = return b - - --- --------------------------------------------------------------------- -instance ExactPrint (HsValBindsLR GhcPs GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (ValBinds sortKey binds sigs) = do - decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs) - let - binds' = listToBag $ concatMap decl2Bind decls - sigs' = concatMap decl2Sig decls - sortKey' = captureOrderBinds decls - return (ValBinds sortKey' binds' sigs') - exact (XValBindsLR _) = panic "XValBindsLR" - -undynamic :: Typeable a => [Dynamic] -> [a] -undynamic ds = mapMaybe fromDynamic ds - --- --------------------------------------------------------------------- - -instance ExactPrint (HsIPBinds GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (IPBinds x binds) = setLayoutBoth $ do - binds' <- markAnnotated binds - return (IPBinds x binds') - --- --------------------------------------------------------------------- - -instance ExactPrint (IPBind GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (IPBind an lr rhs) = do - lr' <- markAnnotated lr - an0 <- markEpAnnL an lidl AnnEqual - rhs' <- markAnnotated rhs - return (IPBind an0 lr' rhs') - - --- --------------------------------------------------------------------- - -instance ExactPrint HsIPName where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact i@(HsIPName fs) = printStringAdvanceA ("?" ++ (unpackFS fs)) >> return i - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotationF :: (Monad m, Monoid w) => - [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)] -prepareListAnnotationF ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls - where - go (L l a) = do - (L l' d') <- markAnnotated (L l (DataFamInstDeclWithContext noAnn NotTopLevel a)) - return (toDyn (L l' (dc_d d'))) - -prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)] -prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls - where - go b = do - b' <- markAnnotated b - return (toDyn b') - -withSortKey :: (Monad m, Monoid w) - => AnnSortKey DeclTag -> [(DeclTag, [(RealSrcSpan, EP w m Dynamic)])] - -> EP w m (AnnSortKey DeclTag, [Dynamic]) -withSortKey annSortKey xs = do - debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey - let (sk, ordered) = case annSortKey of - NoAnnSortKey -> (annSortKey', map snd os) - where - doOne (tag, ds) = map (\d -> (tag, d)) ds - xsExpanded = concatMap doOne xs - os = sortBy orderByFst $ xsExpanded - annSortKey' = AnnSortKey (map fst os) - AnnSortKey _keys -> (annSortKey, orderedDecls annSortKey (Map.fromList xs)) - ordered' <- mapM snd ordered - return (sk, ordered') - -orderByFst :: Ord a => (t, (a,b1)) -> (t, (a, b2)) -> Ordering -orderByFst (_,(a,_)) (_,(b,_)) = compare a b - --- --------------------------------------------------------------------- - -instance ExactPrint (Sig GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (TypeSig an vars ty) = do - (an', vars', ty') <- exactVarSig an vars ty - return (TypeSig an' vars' ty') - - exact (PatSynSig an lns typ) = do - an0 <- markEpAnnL an lasRest AnnPattern - lns' <- markAnnotated lns - an1 <- markLensAA' an0 lasDcolon - typ' <- markAnnotated typ - return (PatSynSig an1 lns' typ') - - exact (ClassOpSig an is_deflt vars ty) - | is_deflt = do - an0 <- markEpAnnL an lasRest AnnDefault - (an1, vars',ty') <- exactVarSig an0 vars ty - return (ClassOpSig an1 is_deflt vars' ty') - | otherwise = do - (an0, vars',ty') <- exactVarSig an vars ty - return (ClassOpSig an0 is_deflt vars' ty') - - exact (FixSig an (FixitySig ns names (Fixity src v fdir))) = do - let fixstr = case fdir of - InfixL -> "infixl" - InfixR -> "infixr" - InfixN -> "infix" - an0 <- markEpAnnLMS'' an lidl AnnInfix (Just fixstr) - an1 <- markEpAnnLMS'' an0 lidl AnnVal (Just (sourceTextToString src (show v))) - ns' <- markAnnotated ns - names' <- markAnnotated names - return (FixSig an1 (FixitySig ns' names' (Fixity src v fdir))) - - exact (InlineSig an ln inl) = do - an0 <- markAnnOpen an (inl_src inl) "{-# INLINE" - an1 <- markActivation an0 id (inl_act inl) - ln' <- markAnnotated ln - an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "#-}") - return (InlineSig an2 ln' inl) - - exact (SpecSig an ln typs inl) = do - an0 <- markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE - an1 <- markActivation an0 lidl (inl_act inl) - ln' <- markAnnotated ln - an2 <- markEpAnnL an1 lidl AnnDcolon - typs' <- markAnnotated typs - an3 <- markEpAnnLMS'' an2 lidl AnnClose (Just "#-}") - return (SpecSig an3 ln' typs' inl) - - exact (SpecInstSig (an,src) typ) = do - an0 <- markAnnOpen an src "{-# SPECIALISE" - an1 <- markEpAnnL an0 lidl AnnInstance - typ' <- markAnnotated typ - an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "#-}") - return (SpecInstSig (an2,src) typ') - - exact (MinimalSig (an,src) formula) = do - an0 <- markAnnOpen an src "{-# MINIMAL" - formula' <- markAnnotated formula - an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") - return (MinimalSig (an1,src) formula') - - exact (SCCFunSig (an,src) ln ml) = do - an0 <- markAnnOpen an src "{-# SCC" - ln' <- markAnnotated ln - ml' <- markAnnotated ml - an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") - return (SCCFunSig (an1,src) ln' ml') - - exact (CompleteMatchSig (an,src) cs mty) = do - an0 <- markAnnOpen an src "{-# COMPLETE" - cs' <- mapM markAnnotated cs - (an1, mty') <- - case mty of - Nothing -> return (an0, mty) - Just ty -> do - an1 <- markEpAnnL an0 lidl AnnDcolon - ty' <- markAnnotated ty - return (an1, Just ty') - an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "#-}") - return (CompleteMatchSig (an2,src) cs' mty') - --- --------------------------------------------------------------------- - -instance ExactPrint NamespaceSpecifier where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact NoNamespaceSpecifier = return NoNamespaceSpecifier - exact (TypeNamespaceSpecifier typeTok) = do - typeTok' <- markEpToken typeTok - return (TypeNamespaceSpecifier typeTok') - exact (DataNamespaceSpecifier dataTok) = do - dataTok' <- markEpToken dataTok - return (DataNamespaceSpecifier dataTok') - --- --------------------------------------------------------------------- - -exactVarSig :: (Monad m, Monoid w, ExactPrint a) - => AnnSig -> [LocatedN RdrName] -> a -> EP w m (AnnSig, [LocatedN RdrName], a) -exactVarSig an vars ty = do - vars' <- mapM markAnnotated vars - an0 <- markLensAA' an lasDcolon - ty' <- markAnnotated ty - return (an0, vars', ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (StandaloneKindSig GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (StandaloneKindSig an vars sig) = do - an0 <- markEpAnnL an lidl AnnType - vars' <- markAnnotated vars - an1 <- markEpAnnL an0 lidl AnnDcolon - sig' <- markAnnotated sig - return (StandaloneKindSig an1 vars' sig') - --- --------------------------------------------------------------------- - -instance ExactPrint (DefaultDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (DefaultDecl an tys) = do - an0 <- markEpAnnL an lidl AnnDefault - an1 <- markEpAnnL an0 lidl AnnOpenP - tys' <- markAnnotated tys - an2 <- markEpAnnL an1 lidl AnnCloseP - return (DefaultDecl an2 tys') - --- --------------------------------------------------------------------- - -instance ExactPrint (AnnDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsAnnotation (an, src) prov e) = do - an0 <- markAnnOpenP' an src "{-# ANN" - (an1, prov') <- - case prov of - (ValueAnnProvenance n) -> do - n' <- markAnnotated n - return (an0, ValueAnnProvenance n') - (TypeAnnProvenance n) -> do - an1 <- markEpAnnL an0 lapr_rest AnnType - n' <- markAnnotated n - return (an1, TypeAnnProvenance n') - ModuleAnnProvenance -> do - an1 <- markEpAnnL an0 lapr_rest AnnModule - return (an1, prov) - - e' <- markAnnotated e - an2 <- markAnnCloseP' an1 - return (HsAnnotation (an2,src) prov' e') - --- --------------------------------------------------------------------- - -instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (BF.Var x) = do - x' <- markAnnotated x - return (BF.Var x') - exact (BF.Or ls) = do - ls' <- markAnnotated ls - return (BF.Or ls') - exact (BF.And ls) = do - ls' <- markAnnotated ls - return (BF.And ls') - exact (BF.Parens x) = do - x' <- markAnnotated x - return (BF.Parens x') - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _= a - exact (HsWC x ty) = do - ty' <- markAnnotated ty - return (HsWC x ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (GRHS an _ _) = fromAnn an - setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b - - exact (GRHS an guards expr) = do - an0 <- if null guards - then return an - else markLensKwM an lga_vbar AnnVbar - guards' <- markAnnotated guards - an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs - expr' <- markAnnotated expr - return (GRHS an1 guards' expr') - -instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (GRHS ann _ _) = fromAnn ann - setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b - - exact (GRHS an guards expr) = do - an0 <- markLensKwM an lga_vbar AnnVbar - guards' <- markAnnotated guards - an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs - expr' <- markAnnotated expr - return (GRHS an1 guards' expr') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsExpr GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _s = a - - exact (HsVar x n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered. - let pun_RDR = "pun-right-hand-side" - n' <- if (showPprUnsafe n /= pun_RDR) - then markAnnotated n - else return n - return (HsVar x n') - exact (HsUnboundVar an n) = do - case an of - Just (EpAnnUnboundVar (ob,cb) l) -> do - ob' <- printStringAtAA ob "`" - l' <- printStringAtAA l "_" - cb' <- printStringAtAA cb "`" - return (HsUnboundVar (Just (EpAnnUnboundVar (ob',cb') l')) n) - _ -> do - printStringAdvanceA "_" >> return () - return (HsUnboundVar an n) - exact x@(HsOverLabel _ src l) = do - printStringAdvanceA "#" >> return () - case src of - NoSourceText -> printStringAdvanceA (unpackFS l) >> return () - SourceText txt -> printStringAdvanceA (unpackFS txt) >> return () - return x - - exact x@(HsIPVar _ (HsIPName n)) - = printStringAdvance ("?" ++ unpackFS n) >> return x - - 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 - case str of - SourceText s -> printStringAdvance (unpackFS s) >> return () - NoSourceText -> withPpr x >> return () - return x - - exact (HsLit an lit) = do - lit' <- withPpr lit - return (HsLit an lit') - - exact (HsLam an lam_variant mg) = do - an0 <- mark an AnnLam - an1 <- case lam_variant of - LamSingle -> return an0 - LamCase -> mark an0 AnnCase - LamCases -> mark an0 AnnCases - mg' <- markAnnotated mg - return (HsLam an1 lam_variant mg') - - exact (HsApp an e1 e2) = do - p <- getPosP - debugM $ "HsApp entered. p=" ++ show p - e1' <- markAnnotated e1 - e2' <- markAnnotated e2 - return (HsApp an e1' e2') - exact (HsAppType at fun arg) = do - fun' <- markAnnotated fun - at' <- markEpToken at - arg' <- markAnnotated arg - return (HsAppType at' fun' arg') - exact (OpApp an e1 e2 e3) = do - e1' <- markAnnotated e1 - e2' <- markAnnotated e2 - e3' <- markAnnotated e3 - return (OpApp an e1' e2' e3') - - exact (NegApp an e s) = do - an0 <- markEpAnnL an lidl AnnMinus - e' <- markAnnotated e - return (NegApp an0 e' s) - - exact (HsPar (lpar, rpar) e) = do - lpar' <- markEpToken lpar - e' <- markAnnotated e - debugM $ "HsPar closing paren" - rpar' <- markEpToken rpar - debugM $ "HsPar done" - return (HsPar (lpar', rpar') e') - - exact (SectionL an expr op) = do - expr' <- markAnnotated expr - op' <- markAnnotated op - return (SectionL an expr' op') - - exact (SectionR an op expr) = do - op' <- markAnnotated op - expr' <- markAnnotated expr - return (SectionR an op' expr') - - exact (ExplicitTuple an args b) = do - an0 <- if b == Boxed then markEpAnnL an lidl AnnOpenP - else markEpAnnL an lidl AnnOpenPH - - args' <- mapM markAnnotated args - - an1 <- if b == Boxed then markEpAnnL an0 lidl AnnCloseP - else markEpAnnL an0 lidl AnnClosePH - debugM $ "ExplicitTuple done" - return (ExplicitTuple an1 args' b) - - exact (ExplicitSum an alt arity expr) = do - an0 <- markLensKw an laesOpen AnnOpenPH - an1 <- markAnnKwAllL an0 laesBarsBefore AnnVbar - expr' <- markAnnotated expr - an2 <- markAnnKwAllL an1 laesBarsAfter AnnVbar - an3 <- markLensKw an2 laesClose AnnClosePH - return (ExplicitSum an3 alt arity expr') - - exact (HsCase an e alts) = do - an0 <- markLensKw an lhsCaseAnnCase AnnCase - e' <- markAnnotated e - an1 <- markLensKw an0 lhsCaseAnnOf AnnOf - an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC - an3 <- markEpAnnAllL' an2 lhsCaseAnnsRest AnnSemi - alts' <- setLayoutBoth $ markAnnotated alts - an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC - return (HsCase an4 e' alts') - - exact (HsIf an e1 e2 e3) = do - an0 <- markLensKw an laiIf AnnIf - e1' <- markAnnotated e1 - an1 <- markLensKwM' an0 laiThenSemi AnnSemi - an2 <- markLensKw an1 laiThen AnnThen - e2' <- markAnnotated e2 - an3 <- markLensKwM' an2 laiElseSemi AnnSemi - an4 <- markLensKw an3 laiElse AnnElse - e3' <- markAnnotated e3 - return (HsIf an4 e1' e2' e3') - - exact (HsMultiIf an mg) = do - an0 <- markEpAnnL an lidl AnnIf - an1 <- markEpAnnL an0 lidl AnnOpenC -- optional - mg' <- markAnnotated mg - an2 <- markEpAnnL an1 lidl AnnCloseC -- optional - return (HsMultiIf an2 mg') - - exact (HsLet (tkLet, tkIn) binds e) = do - setLayoutBoth $ do -- Make sure the 'in' gets indented too - tkLet' <- markEpToken tkLet - binds' <- setLayoutBoth $ markAnnotated binds - tkIn' <- markEpToken tkIn - e' <- markAnnotated e - return (HsLet (tkLet',tkIn') binds' e') - - exact (HsDo an do_or_list_comp stmts) = do - debugM $ "HsDo" - (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts - return (HsDo an' do_or_list_comp stmts') - - exact (ExplicitList an es) = do - debugM $ "ExplicitList start" - an0 <- markLensMAA' an lal_open - es' <- markAnnotated es - an1 <- markLensMAA' an0 lal_close - debugM $ "ExplicitList end" - return (ExplicitList an1 es') - exact (RecordCon an con_id binds) = do - con_id' <- markAnnotated con_id - an0 <- markEpAnnL an lidl AnnOpenC - binds' <- markAnnotated binds - an1 <- markEpAnnL an0 lidl AnnCloseC - return (RecordCon an1 con_id' binds') - exact (RecordUpd an expr fields) = do - expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnOpenC - fields' <- markAnnotated fields - an1 <- markEpAnnL an0 lidl AnnCloseC - return (RecordUpd an1 expr' fields') - exact (HsGetField an expr field) = do - expr' <- markAnnotated expr - field' <- markAnnotated field - return (HsGetField an expr' field') - exact (HsProjection an flds) = do - an0 <- markLensKw an lapOpen AnnOpenP - flds' <- mapM markAnnotated flds - an1 <- markLensKw an0 lapClose AnnCloseP - return (HsProjection an1 flds') - exact (ExprWithTySig an expr sig) = do - expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnDcolon - sig' <- markAnnotated sig - return (ExprWithTySig an0 expr' sig') - exact (ArithSeq an s seqInfo) = do - an0 <- markEpAnnL an lidl AnnOpenS -- '[' - (an1, seqInfo') <- - case seqInfo of - From e -> do - e' <- markAnnotated e - an' <- markEpAnnL an0 lidl AnnDotdot - return (an', From e') - FromTo e1 e2 -> do - e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnDotdot - e2' <- markAnnotated e2 - return (an', FromTo e1' e2') - FromThen e1 e2 -> do - e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnComma - e2' <- markAnnotated e2 - an'' <- markEpAnnL an' lidl AnnDotdot - return (an'', FromThen e1' e2') - FromThenTo e1 e2 e3 -> do - e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnComma - e2' <- markAnnotated e2 - an'' <- markEpAnnL an' lidl AnnDotdot - e3' <- markAnnotated e3 - return (an'', FromThenTo e1' e2' e3') - an2 <- markEpAnnL an1 lidl AnnCloseS -- ']' - return (ArithSeq an2 s seqInfo') - - - exact (HsTypedBracket an e) = do - an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[||") - an1 <- markEpAnnLMS'' an0 lidl AnnOpenE (Just "[e||") - e' <- markAnnotated e - an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "||]") - return (HsTypedBracket an2 e') - - exact (HsUntypedBracket an (ExpBr a e)) = do - an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|" - an1 <- markEpAnnL an0 lidl AnnOpenE -- "[e|" -- optional - e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an2 (ExpBr a e')) - - exact (HsUntypedBracket an (PatBr a e)) = do - an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[p|") - e' <- markAnnotated e - an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an1 (PatBr a e')) - - exact (HsUntypedBracket an (DecBrL a e)) = do - an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[d|") - an1 <- markEpAnnL an0 lidl AnnOpenC - e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseC - an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an3 (DecBrL a e')) - - exact (HsUntypedBracket an (TypBr a e)) = do - an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[t|") - e' <- markAnnotated e - an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an1 (TypBr a e')) - - exact (HsUntypedBracket an (VarBr a b e)) = do - (an0, e') <- if b - then do - an' <- markEpAnnL an lidl AnnSimpleQuote - e' <- markAnnotated e - return (an', e') - else do - an' <- markEpAnnL an lidl AnnThTyQuote - e' <- markAnnotated e - return (an', e') - return (HsUntypedBracket an0 (VarBr a b e')) - - exact (HsTypedSplice an s) = do - an0 <- markEpAnnL an lidl AnnDollarDollar - s' <- markAnnotated s - return (HsTypedSplice an0 s') - - exact (HsUntypedSplice an s) = do - s' <- markAnnotated s - return (HsUntypedSplice an s') - - exact (HsProc an p c) = do - debugM $ "HsProc start" - an0 <- markEpAnnL an lidl AnnProc - p' <- markAnnotated p - an1 <- markEpAnnL an0 lidl AnnRarrow - debugM $ "HsProc after AnnRarrow" - c' <- markAnnotated c - return (HsProc an1 p' c') - - exact (HsStatic an e) = do - an0 <- markEpAnnL an lidl AnnStatic - e' <- markAnnotated e - return (HsStatic an0 e') - - exact (HsPragE a prag e) = do - prag' <- markAnnotated prag - e' <- markAnnotated e - return (HsPragE a prag' e') - - exact (HsEmbTy toktype t) = do - toktype' <- markEpToken toktype - t' <- markAnnotated t - return (HsEmbTy toktype' t') - - exact x = error $ "exact HsExpr for:" ++ showAst x - --- --------------------------------------------------------------------- - -exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => AnnList -> HsDoFlavour -> LocatedAn an a - -> EP w m (AnnList, LocatedAn an a) -exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an GhciStmtCtxt stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an ListComp stmts = markMaybeDodgyStmts an stmts -exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts - -exactMdo :: (Monad m, Monoid w) - => AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m AnnList -exactMdo an Nothing kw = markEpAnnL an lal_rest kw -exactMdo an (Just module_name) kw = markEpAnnLMS'' an lal_rest kw (Just n) - where - n = (moduleNameString module_name) ++ "." ++ (keywordToString kw) - -markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => AnnList -> LocatedAn an a -> EP w m (AnnList, LocatedAn an a) -markMaybeDodgyStmts an stmts = - if notDodgy stmts - then do - r <- markAnnotatedWithLayout stmts - return (an, r) - else return (an, stmts) - -notDodgy :: GenLocated (EpAnn ann) a -> Bool -notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc - -notDodgyE :: EpaLocation -> Bool -notDodgyE anc = - case anc of - EpaSpan s -> isGoodSrcSpan s - EpaDelta{} -> True - --- --------------------------------------------------------------------- -instance ExactPrint (HsPragE GhcPs) where - getAnnotationEntry HsPragSCC{} = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsPragSCC (an,st) sl) = do - an0 <- markAnnOpenP' an st "{-# SCC" - let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) - an1 <- markEpAnnLMS'' an0 lapr_rest AnnVal (Just txt) -- optional - an2 <- markEpAnnLMS'' an1 lapr_rest AnnValStr (Just txt) -- optional - an3 <- markAnnCloseP' an2 - return (HsPragSCC (an3,st) sl) - - --- --------------------------------------------------------------------- - -instance ExactPrint (HsUntypedSplice GhcPs) where - getAnnotationEntry _ = NoEntryVal - - setAnnotationAnchor a _ _ _= a - - exact (HsUntypedSpliceExpr an e) = do - an0 <- markEpAnnL an lidl AnnDollar - e' <- markAnnotated e - return (HsUntypedSpliceExpr an0 e') - - exact (HsQuasiQuote an q (L l 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 - return (HsQuasiQuote an q (L l fs)) - --- --------------------------------------------------------------------- - --- TODO:AZ: combine these instances -instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (MG x matches) = do - -- TODO:AZ use SortKey, in MG ann. - matches' <- markAnnotated matches - return (MG x matches') - -instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (MG x matches) = do - -- TODO:AZ use SortKey, in MG ann. - matches' <- if notDodgy matches - then markAnnotated matches - else return matches - return (MG x matches') - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (HsRecFields fields mdot) = do - fields' <- markAnnotated fields - mdot' <- case mdot of - Nothing -> return Nothing - Just (L ss d) -> do - ss' <- printStringAtAA ss ".." - return $ Just (L ss' d) - -- Note: mdot contains the SrcSpan where the ".." appears, if present - return (HsRecFields fields' mdot') - --- --------------------------------------------------------------------- - -instance (ExactPrint body) - => ExactPrint (HsFieldBind (LocatedA (FieldOcc GhcPs)) body) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsFieldBind an f arg isPun) = do - debugM $ "HsFieldBind" - f' <- markAnnotated f - (an0, arg') <- if isPun then return (an, arg) - else do - an0 <- markEpAnnL an lidl AnnEqual - arg' <- markAnnotated arg - return (an0, arg') - return (HsFieldBind an0 f' arg' isPun) - --- --------------------------------------------------------------------- - -instance (ExactPrint body) - => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsFieldBind an f arg isPun) = do - debugM $ "HsFieldBind FieldLabelStrings" - f' <- markAnnotated f - (an0, arg') <- if isPun then return (an, arg) - else do - an0 <- markEpAnnL an lidl AnnEqual - arg' <- markAnnotated arg - return (an0, arg') - return (HsFieldBind an0 f' arg' isPun) - --- --------------------------------------------------------------------- - -instance (ExactPrint (LocatedA body)) - => ExactPrint (HsFieldBind (LocatedA (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsFieldBind an f arg isPun) = do - debugM $ "HsRecUpdField" - f' <- markAnnotated f - an0 <- if isPun then return an - else markEpAnnL an lidl AnnEqual - arg' <- if isPun - then return arg - else markAnnotated arg - return (HsFieldBind an0 f' arg' isPun) - --- --------------------------------------------------------------------- -instance ExactPrint (LHsRecUpdFields GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do - debugM $ "RegularRecUpdFields" - rbinds' <- markAnnotated rbinds - return $ flds { recUpdFields = rbinds' } - exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do - debugM $ "OverloadedRecUpdFields" - pbinds' <- markAnnotated pbinds - return $ flds { olRecUpdFields = pbinds' } - --- --------------------------------------------------------------------- - -instance ExactPrint (FieldLabelStrings GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs - --- --------------------------------------------------------------------- - -instance ExactPrint (DotFieldOcc GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do - an0 <- markLensKwM' an lafDot AnnDot - -- The field name has a SrcSpanAnnN, print it as a - -- LocatedN RdrName - L loc' _ <- markAnnotated (L loc (mkVarUnqual fs)) - return (DotFieldOcc an0 (L loc' (FieldLabelString fs))) - --- --------------------------------------------------------------------- - -instance ExactPrint (HsTupArg GhcPs) where - getAnnotationEntry (Present _ _) = NoEntryVal - getAnnotationEntry (Missing (EpAnn _ False _)) = NoEntryVal - getAnnotationEntry (Missing an) = fromAnn an - - setAnnotationAnchor (Present a b) _ _ _ = Present a b - setAnnotationAnchor (Missing an) anc ts cs = Missing (setAnchorEpa an anc ts cs) - - exact (Present a e) = Present a <$> markAnnotated e - - exact a@(Missing (EpAnn _ False _)) = return a - exact a@(Missing _) = printStringAdvance "," >> return a - --- --------------------------------------------------------------------- - -instance ExactPrint (HsCmdTop GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd - --- --------------------------------------------------------------------- - -instance ExactPrint (HsCmd GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsCmdArrApp an arr arg o isRightToLeft) = do - if isRightToLeft - then do - arr' <- markAnnotated arr - an0 <- markKw an - arg' <- markAnnotated arg - return (HsCmdArrApp an0 arr' arg' o isRightToLeft) - else do - arg' <- markAnnotated arg - an0 <- markKw an - arr' <- markAnnotated arr - return (HsCmdArrApp an0 arr' arg' o isRightToLeft) - - exact (HsCmdArrForm an e fixity mf cs) = do - an0 <- markLensMAA' an lal_open - (e',cs') <- case (fixity, cs) of - (Infix, (arg1:argrest)) -> do - arg1' <- markAnnotated arg1 - e' <- markAnnotated e - argrest' <- markAnnotated argrest - return (e', arg1':argrest') - (Prefix, _) -> do - e' <- markAnnotated e - cs' <- markAnnotated cs - return (e', cs') - (Infix, []) -> error "Not possible" - an1 <- markLensMAA' an0 lal_close - return (HsCmdArrForm an1 e' fixity mf cs') - - exact (HsCmdApp an e1 e2) = do - e1' <- markAnnotated e1 - e2' <- markAnnotated e2 - return (HsCmdApp an e1' e2') - - exact (HsCmdLam an lam_variant matches) = do - an0 <- markEpAnnL an lidl AnnLam - an1 <- case lam_variant of - LamSingle -> return an0 - LamCase -> markEpAnnL an0 lidl AnnCase - LamCases -> markEpAnnL an0 lidl AnnCases - matches' <- markAnnotated matches - return (HsCmdLam an1 lam_variant matches') - - exact (HsCmdPar (lpar, rpar) e) = do - lpar' <- markEpToken lpar - e' <- markAnnotated e - rpar' <- markEpToken rpar - return (HsCmdPar (lpar', rpar') e') - - exact (HsCmdCase an e alts) = do - an0 <- markLensKw an lhsCaseAnnCase AnnCase - e' <- markAnnotated e - an1 <- markLensKw an0 lhsCaseAnnOf AnnOf - an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC - an3 <- markEpAnnAllL' an2 lhsCaseAnnsRest AnnSemi - alts' <- markAnnotated alts - an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC - return (HsCmdCase an4 e' alts') - - exact (HsCmdIf an a e1 e2 e3) = do - an0 <- markLensKw an laiIf AnnIf - e1' <- markAnnotated e1 - an1 <- markLensKwM' an0 laiThenSemi AnnSemi - an2 <- markLensKw an1 laiThen AnnThen - e2' <- markAnnotated e2 - an3 <- markLensKwM' an2 laiElseSemi AnnSemi - an4 <- markLensKw an3 laiElse AnnElse - e3' <- markAnnotated e3 - return (HsCmdIf an4 a e1' e2' e3') - - exact (HsCmdLet (tkLet, tkIn) binds e) = do - setLayoutBoth $ do -- Make sure the 'in' gets indented too - tkLet' <- markEpToken tkLet - binds' <- setLayoutBoth $ markAnnotated binds - tkIn' <- markEpToken tkIn - e' <- markAnnotated e - return (HsCmdLet (tkLet', tkIn') binds' e') - - exact (HsCmdDo an es) = do - debugM $ "HsCmdDo" - an0 <- markEpAnnL an lal_rest AnnDo - es' <- markAnnotated es - return (HsCmdDo an0 es') - --- --------------------------------------------------------------------- - -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 _ = NoEntryVal - setAnnotationAnchor a _ _ _s = a - - exact (LastStmt a body b c) = do - debugM $ "LastStmt" - body' <- markAnnotated body - return (LastStmt a body' b c) - - exact (BindStmt an pat body) = do - debugM $ "BindStmt" - pat' <- markAnnotated pat - an0 <- markEpAnnL an lidl AnnLarrow - body' <- markAnnotated body - return (BindStmt an0 pat' body') - - exact (ApplicativeStmt _ _body _) = do - error $ "ApplicativeStmt is introduced in the renamer" - - exact (BodyStmt a body b c) = do - debugM $ "BodyStmt" - body' <- markAnnotated body - return (BodyStmt a body' b c) - - exact (LetStmt an binds) = do - debugM $ "LetStmt" - an0 <- markEpAnnL an lidl AnnLet - binds' <- markAnnotated binds - return (LetStmt an0 binds') - - exact (ParStmt a pbs b c) = do - debugM $ "ParStmt" - pbs' <- markAnnotated pbs - return (ParStmt a pbs' b c) - - exact (TransStmt an form stmts b using by c d e) = do - debugM $ "TransStmt" - stmts' <- markAnnotated stmts - (an', by', using') <- exactTransStmt an by using form - return (TransStmt an' form stmts' b using' by' c d e) - - exact (RecStmt an stmts a b c d e) = do - debugM $ "RecStmt" - an0 <- markEpAnnL an lal_rest AnnRec - (an1, stmts') <- markAnnList' an0 (markAnnotated stmts) - return (RecStmt an1 stmts' a b c d e) - --- --------------------------------------------------------------------- - -instance ExactPrint (ParStmtBlock GhcPs GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (ParStmtBlock a stmts b c) = do - stmts' <- markAnnotated stmts - return (ParStmtBlock a stmts' b c) - -exactTransStmt :: (Monad m, Monoid w) - => [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm - -> EP w m ([AddEpAnn], Maybe (LHsExpr GhcPs), (LHsExpr GhcPs)) -exactTransStmt an by using ThenForm = do - debugM $ "exactTransStmt:ThenForm" - an0 <- markEpAnnL an lidl AnnThen - using' <- markAnnotated using - case by of - Nothing -> return (an0, by, using') - Just b -> do - an1 <- markEpAnnL an0 lidl AnnBy - b' <- markAnnotated b - return (an1, Just b', using') -exactTransStmt an by using GroupForm = do - debugM $ "exactTransStmt:GroupForm" - an0 <- markEpAnnL an lidl AnnThen - an1 <- markEpAnnL an0 lidl AnnGroup - (an2, by') <- case by of - Nothing -> return (an1, by) - Just b -> do - an2 <- markEpAnnL an1 lidl AnnBy - b' <- markAnnotated b - return (an2, Just b') - an3 <- markEpAnnL an2 lidl AnnUsing - using' <- markAnnotated using - return (an3, by', using') - --- --------------------------------------------------------------------- - -instance ExactPrint (TyClDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _s = a - - exact (FamDecl a decl) = do - decl' <- markAnnotated decl - return (FamDecl a 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 - -- TODO: no longer sorting on insert. What now? - an0 <- annotationsToComments an lidl [AnnOpenP,AnnCloseP] - an1 <- markEpAnnL an0 lidl AnnType - - (_anx, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing - an2 <- markEpAnnL an1 lidl AnnEqual - rhs' <- markAnnotated rhs - return (SynDecl { tcdSExt = an2 - , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity - , tcdRhs = rhs' }) - - -- TODO: add a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/20452 - exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars - , tcdFixity = fixity, tcdDataDefn = defn }) = do - (_, an', ltycon', tyvars', _, defn') <- - exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn - return (DataDecl { tcdDExt = an', tcdLName = ltycon', tcdTyVars = tyvars' - , tcdFixity = fixity, tcdDataDefn = defn' }) - - -- ----------------------------------- - - exact (ClassDecl {tcdCExt = (an, lo, 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 - (an0, fds', lclas', tyvars',context') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnL an1 lidl AnnCloseC - return (ClassDecl {tcdCExt = (an2, lo, sortKey), - tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', - tcdFixity = fixity, - tcdFDs = fds', - tcdSigs = sigs, tcdMeths = methods, - tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = _docs}) - - | otherwise -- Laid out - = do - (an0, fds', lclas', tyvars',context') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnAllL' an1 lidl AnnSemi - (sortKey', ds) <- withSortKey sortKey - [(ClsSigTag, prepareListAnnotationA sigs), - (ClsMethodTag, prepareListAnnotationA (bagToList methods)), - (ClsAtTag, prepareListAnnotationA ats), - (ClsAtdTag, prepareListAnnotationA at_defs) - -- ++ prepareListAnnotation docs - ] - an3 <- markEpAnnL an2 lidl AnnCloseC - let - sigs' = undynamic ds - methods' = listToBag $ undynamic ds - ats' = undynamic ds - at_defs' = undynamic ds - return (ClassDecl {tcdCExt = (an3, lo, sortKey'), - tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', - tcdFixity = fixity, - tcdFDs = fds', - tcdSigs = sigs', tcdMeths = methods', - tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = _docs}) - where - top_matter = do - an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - an0 <- markEpAnnL an' lidl AnnClass - (_, lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context - (an1, fds') <- if (null fds) - then return (an0, fds) - else do - an1 <- markEpAnnL an0 lidl AnnVbar - fds' <- markAnnotated fds - return (an1, fds') - an2 <- markEpAnnL an1 lidl AnnWhere - return (an2, fds', lclas', tyvars',context') - - --- --------------------------------------------------------------------- - -instance ExactPrint (FunDep GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (FunDep an ls rs') = do - ls' <- markAnnotated ls - an0 <- markEpAnnL an lidl AnnRarrow - rs'' <- markAnnotated rs' - return (FunDep an0 ls' rs'') - --- --------------------------------------------------------------------- - -instance ExactPrint (FamilyDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (FamilyDecl { fdExt = an - , fdInfo = info - , fdTopLevel = top_level - , fdLName = ltycon - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = L lr result - , fdInjectivityAnn = mb_inj }) = do - an0 <- exactFlavour an info - an1 <- exact_top_level an0 - an2 <- annotationsToComments an1 lidl [AnnOpenP,AnnCloseP] - (_, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing - (an3, result') <- exact_kind an2 - (an4, mb_inj') <- - case mb_inj of - Nothing -> return (an3, mb_inj) - Just inj -> do - an4 <- markEpAnnL an3 lidl AnnVbar - inj' <- markAnnotated inj - return (an4, Just inj') - (an5, info') <- - case info of - ClosedTypeFamily mb_eqns -> do - an5 <- markEpAnnL an4 lidl AnnWhere - an6 <- markEpAnnL an5 lidl AnnOpenC - (an7, mb_eqns') <- - case mb_eqns of - Nothing -> do - an7 <- markEpAnnL an6 lidl AnnDotdot - return (an7, mb_eqns) - Just eqns -> do - eqns' <- markAnnotated eqns - return (an6, Just eqns') - an8 <- markEpAnnL an7 lidl AnnCloseC - return (an8, ClosedTypeFamily mb_eqns') - _ -> return (an4, info) - return (FamilyDecl { fdExt = an5 - , fdInfo = info' - , fdTopLevel = top_level - , fdLName = ltycon' - , fdTyVars = tyvars' - , fdFixity = fixity - , fdResultSig = L lr result' - , fdInjectivityAnn = mb_inj' }) - where - exact_top_level an' = - case top_level of - TopLevel -> markEpAnnL an' lidl AnnFamily - NotTopLevel -> do - -- It seems that in some kind of legacy - -- mode the 'family' keyword is still - -- accepted. - markEpAnnL an' lidl AnnFamily - - exact_kind an' = - case result of - NoSig _ -> return (an', result) - KindSig x kind -> do - an0 <- markEpAnnL an' lidl AnnDcolon - kind' <- markAnnotated kind - return (an0, KindSig x kind') - TyVarSig x tv_bndr -> do - an0 <- markEpAnnL an' lidl AnnEqual - tv_bndr' <- markAnnotated tv_bndr - return (an0, TyVarSig x tv_bndr') - - -exactFlavour :: (Monad m, Monoid w) => [AddEpAnn] -> FamilyInfo GhcPs -> EP w m [AddEpAnn] -exactFlavour an DataFamily = markEpAnnL an lidl AnnData -exactFlavour an OpenTypeFamily = markEpAnnL an lidl AnnType -exactFlavour an (ClosedTypeFamily {}) = markEpAnnL an lidl AnnType - --- --------------------------------------------------------------------- - -exactDataDefn - :: (Monad m, Monoid w) - => [AddEpAnn] - -> (Maybe (LHsContext GhcPs) -> EP w m ([AddEpAnn] - , LocatedN RdrName - , a - , b - , Maybe (LHsContext GhcPs))) -- Printing the header - -> HsDataDefn GhcPs - -> EP w m ( [AddEpAnn] -- ^ from exactHdr - , [AddEpAnn] -- ^ updated one passed in - , LocatedN RdrName, a, b, HsDataDefn GhcPs) -exactDataDefn an exactHdr - (HsDataDefn { dd_ext = x, dd_ctxt = context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) = do - - an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - - an0 <- case condecls of - DataTypeCons is_type_data _ -> do - an0' <- if is_type_data - then markEpAnnL an' lidl AnnType - else return an' - markEpAnnL an0' lidl AnnData - NewTypeCon _ -> markEpAnnL an' lidl AnnNewtype - - an1 <- markEpAnnL an0 lidl AnnInstance -- optional - mb_ct' <- mapM markAnnotated mb_ct - (anx, ln', tvs', b, context') <- exactHdr context - (an2, mb_sig') <- case mb_sig of - Nothing -> return (an1, Nothing) - Just kind -> do - an2 <- markEpAnnL an1 lidl AnnDcolon - kind' <- markAnnotated kind - return (an2, Just kind') - an3 <- if (needsWhere condecls) - then markEpAnnL an2 lidl AnnWhere - else return an2 - an4 <- markEpAnnL an3 lidl AnnOpenC - (an5, condecls') <- exact_condecls an4 (toList condecls) - let condecls'' = case condecls of - DataTypeCons d _ -> DataTypeCons d condecls' - NewTypeCon _ -> case condecls' of - [decl] -> NewTypeCon decl - _ -> panic "exacprint NewTypeCon" - an6 <- markEpAnnL an5 lidl AnnCloseC - derivings' <- mapM markAnnotated derivings - return (anx, an6, ln', tvs', b, - (HsDataDefn { dd_ext = x, dd_ctxt = context' - , dd_cType = mb_ct' - , dd_kindSig = mb_sig' - , dd_cons = condecls'', dd_derivs = derivings' })) - - -exactVanillaDeclHead :: (Monad m, Monoid w) - => LocatedN RdrName - -> LHsQTyVars GhcPs - -> LexicalFixity - -> Maybe (LHsContext GhcPs) - -> EP w m ( [AddEpAnn] - , LocatedN RdrName - , LHsQTyVars GhcPs - , (), Maybe (LHsContext GhcPs)) -exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do - let - exact_tyvars (varl:varsr) - | hvarsr : tvarsr@(_ : _) <- varsr - , fixity == Infix = do - varl' <- markAnnotated varl - thing' <- markAnnotated thing - hvarsr' <- markAnnotated hvarsr - tvarsr' <- markAnnotated tvarsr - return (thing', varl':hvarsr':tvarsr') - | fixity == Infix = do - varl' <- markAnnotated varl - thing' <- markAnnotated thing - varsr' <- markAnnotated varsr - return (thing', varl':varsr') - | otherwise = do - thing' <- markAnnotated thing - vs <- mapM markAnnotated (varl:varsr) - return (thing', vs) - exact_tyvars [] = do - thing' <- markAnnotated thing - return (thing', []) - context' <- mapM markAnnotated context - (thing', tyvars') <- exact_tyvars tyvars - return (noAnn, thing', tvs { hsq_explicit = tyvars' }, (), context') - --- --------------------------------------------------------------------- - -instance ExactPrint (InjectivityAnn GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (InjectivityAnn an lhs rhs) = do - an0 <- markEpAnnL an lidl AnnVbar - lhs' <- markAnnotated lhs - an1 <- markEpAnnL an0 lidl AnnRarrow - rhs' <- mapM markAnnotated rhs - return (InjectivityAnn an1 lhs' rhs') - --- --------------------------------------------------------------------- - -class Typeable flag => ExactPrintTVFlag flag where - exactTVDelimiters :: (Monad m, Monoid w) - => [AddEpAnn] -> flag - -> ([AddEpAnn] -> EP w m ([AddEpAnn], HsTyVarBndr flag GhcPs)) - -> EP w m ([AddEpAnn], flag, (HsTyVarBndr flag GhcPs)) - -instance ExactPrintTVFlag () where - exactTVDelimiters an flag thing_inside = do - an0 <- markEpAnnAllL' an lid AnnOpenP - (an1, r) <- thing_inside an0 - an2 <- markEpAnnAllL' an1 lid AnnCloseP - return (an2, flag, r) - -instance ExactPrintTVFlag Specificity where - exactTVDelimiters an s thing_inside = do - an0 <- markEpAnnAllL' an lid open - (an1, r) <- thing_inside an0 - an2 <- markEpAnnAllL' an1 lid close - return (an2, s, r) - where - (open, close) = case s of - SpecifiedSpec -> (AnnOpenP, AnnCloseP) - InferredSpec -> (AnnOpenC, AnnCloseC) - -instance ExactPrintTVFlag (HsBndrVis GhcPs) where - exactTVDelimiters an0 bvis thing_inside = do - bvis' <- case bvis of - HsBndrRequired _ -> return bvis - HsBndrInvisible at -> HsBndrInvisible <$> markEpToken at - an1 <- markEpAnnAllL' an0 lid AnnOpenP - (an2, r) <- thing_inside an1 - an3 <- markEpAnnAllL' an2 lid AnnCloseP - return (an3, bvis', r) - -instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (UserTyVar an flag n) = do - r <- exactTVDelimiters an flag $ \ani -> do - n' <- markAnnotated n - return (ani, UserTyVar an flag n') - case r of - (an', flag', UserTyVar _ _ n'') -> return (UserTyVar an' flag' n'') - _ -> error "KindedTyVar should never happen here" - exact (KindedTyVar an flag n k) = do - r <- exactTVDelimiters an flag $ \ani -> do - n' <- markAnnotated n - an0 <- markEpAnnL ani lidl AnnDcolon - k' <- markAnnotated k - return (an0, KindedTyVar an0 flag n' k') - case r of - (an',flag', KindedTyVar _ _ n'' k'') -> return (KindedTyVar an' flag' n'' k'') - _ -> error "UserTyVar should never happen here" - --- --------------------------------------------------------------------- - -instance ExactPrint (HsType GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _s = a - - exact (HsForAllTy { hst_xforall = an - , hst_tele = tele, hst_body = ty }) = do - tele' <- markAnnotated tele - ty' <- markAnnotated ty - return (HsForAllTy { hst_xforall = an - , hst_tele = tele', hst_body = ty' }) - - exact (HsQualTy an ctxt ty) = do - ctxt' <- markAnnotated ctxt - ty' <- markAnnotated ty - return (HsQualTy an ctxt' ty') - exact (HsTyVar an promoted name) = do - an0 <- if (promoted == IsPromoted) - then markEpAnnL an lidl AnnSimpleQuote - else return an - name' <- markAnnotated name - return (HsTyVar an0 promoted name') - exact (HsAppTy an t1 t2) = do - t1' <- markAnnotated t1 - t2' <- markAnnotated t2 - return (HsAppTy an t1' t2') - exact (HsAppKindTy at ty ki) = do - ty' <- markAnnotated ty - at' <- markEpToken at - ki' <- markAnnotated ki - return (HsAppKindTy at' ty' ki') - exact (HsFunTy an mult ty1 ty2) = do - ty1' <- markAnnotated ty1 - mult' <- markArrow mult - ty2' <- markAnnotated ty2 - return (HsFunTy an mult' ty1' ty2') - exact (HsListTy an tys) = do - an0 <- markOpeningParen an - tys' <- markAnnotated tys - an1 <- markClosingParen an0 - return (HsListTy an1 tys') - exact (HsTupleTy an con tys) = do - an0 <- markOpeningParen an - tys' <- markAnnotated tys - an1 <- markClosingParen an0 - return (HsTupleTy an1 con tys') - exact (HsSumTy an tys) = do - an0 <- markOpeningParen an - tys' <- markAnnotated tys - an1 <- markClosingParen an0 - return (HsSumTy an1 tys') - exact (HsOpTy an promoted t1 lo t2) = do - an0 <- if (isPromoted promoted) - then markEpAnnL an lidl AnnSimpleQuote - else return an - t1' <- markAnnotated t1 - lo' <- markAnnotated lo - t2' <- markAnnotated t2 - return (HsOpTy an0 promoted t1' lo' t2') - exact (HsParTy an ty) = do - an0 <- markOpeningParen an - ty' <- markAnnotated ty - an1 <- markClosingParen an0 - return (HsParTy an1 ty') - exact (HsIParamTy an n t) = do - n' <- markAnnotated n - an0 <- markEpAnnL an lidl AnnDcolon - t' <- markAnnotated t - return (HsIParamTy an0 n' t') - exact (HsStarTy an isUnicode) = do - if isUnicode - then printStringAdvance "\x2605" -- Unicode star - else printStringAdvance "*" - return (HsStarTy an isUnicode) - exact (HsKindSig an ty k) = do - ty' <- markAnnotated ty - an0 <- markEpAnnL an lidl AnnDcolon - k' <- markAnnotated k - return (HsKindSig an0 ty' k') - exact (HsSpliceTy a splice) = do - splice' <- markAnnotated splice - return (HsSpliceTy a splice') - exact (HsDocTy an ty doc) = do - ty' <- markAnnotated ty - return (HsDocTy an ty' doc) - exact (HsBangTy an (HsSrcBang mt up str) ty) = do - an0 <- - case mt of - NoSourceText -> return an - SourceText src -> do - debugM $ "HsBangTy: src=" ++ showAst src - an0 <- markEpAnnMS' an AnnOpen (Just $ unpackFS src) - an1 <- markEpAnnMS' an0 AnnClose (Just "#-}") - debugM $ "HsBangTy: done unpackedness" - return an1 - an1 <- - case str of - SrcLazy -> mark an0 AnnTilde - SrcStrict -> mark an0 AnnBang - NoSrcStrict -> return an0 - ty' <- markAnnotated ty - return (HsBangTy an1 (HsSrcBang mt up str) ty') - exact (HsExplicitListTy an prom tys) = do - an0 <- if (isPromoted prom) - then mark an AnnSimpleQuote - else return an - an1 <- mark an0 AnnOpenS - tys' <- markAnnotated tys - an2 <- mark an1 AnnCloseS - return (HsExplicitListTy an2 prom tys') - exact (HsExplicitTupleTy an tys) = do - an0 <- mark an AnnSimpleQuote - an1 <- mark an0 AnnOpenP - tys' <- markAnnotated tys - an2 <- mark an1 AnnCloseP - return (HsExplicitTupleTy an2 tys') - exact (HsTyLit a 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) - return (HsTyLit a lit) - exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t - exact x = error $ "missing match for HsType:" ++ showAst x - --- --------------------------------------------------------------------- - -instance ExactPrint (HsForAllTelescope GhcPs) where - getAnnotationEntry (HsForAllVis an _) = fromAnn an - getAnnotationEntry (HsForAllInvis an _) = fromAnn an - - setAnnotationAnchor (HsForAllVis an a) anc ts cs = HsForAllVis (setAnchorEpa an anc ts cs) a - setAnnotationAnchor (HsForAllInvis an a) anc ts cs = HsForAllInvis (setAnchorEpa an anc ts cs) a - - exact (HsForAllVis an bndrs) = do - an0 <- markLensAA an lfst -- AnnForall - bndrs' <- markAnnotated bndrs - an1 <- markLensAA an0 lsnd -- AnnRarrow - return (HsForAllVis an1 bndrs') - - exact (HsForAllInvis an bndrs) = do - an0 <- markLensAA an lfst -- AnnForall - bndrs' <- markAnnotated bndrs - an1 <- markLensAA an0 lsnd -- AnnDot - return (HsForAllInvis an1 bndrs') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsDerivingClause GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsDerivingClause { deriv_clause_ext = an - , deriv_clause_strategy = dcs - , deriv_clause_tys = dct }) = do - an0 <- markEpAnnL an lidl AnnDeriving - dcs0 <- case dcs of - Just (L _ ViaStrategy{}) -> return dcs - _ -> mapM markAnnotated dcs - dct' <- markAnnotated dct - dcs1 <- case dcs0 of - Just (L _ ViaStrategy{}) -> mapM markAnnotated dcs0 - _ -> return dcs0 - return (HsDerivingClause { deriv_clause_ext = an0 - , deriv_clause_strategy = dcs1 - , deriv_clause_tys = dct' }) - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivStrategy GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (StockStrategy an) = do - an0 <- markEpAnnL an lid AnnStock - return (StockStrategy an0) - exact (AnyclassStrategy an) = do - an0 <- markEpAnnL an lid AnnAnyclass - return (AnyclassStrategy an0) - exact (NewtypeStrategy an) = do - an0 <- markEpAnnL an lid AnnNewtype - return (NewtypeStrategy an0) - exact (ViaStrategy (XViaStrategyPs an ty)) = do - an0 <- markEpAnnL an lid AnnVia - ty' <- markAnnotated ty - return (ViaStrategy (XViaStrategyPs an0 ty')) - --- --------------------------------------------------------------------- - -instance (ExactPrint a) => ExactPrint (LocatedC a) where - getAnnotationEntry (L sann _) = fromAnn sann - setAnnotationAnchor = setAnchorAn - - exact (L (EpAnn anc (AnnContext ma opens closes) cs) a) = do - opens' <- mapM (markKwA AnnOpenP) opens - a' <- markAnnotated a - closes' <- mapM (markKwA AnnCloseP) closes - return (L (EpAnn anc (AnnContext ma opens' closes') cs) a') - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivClauseTys GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (DctSingle x ty) = do - ty' <- markAnnotated ty - return (DctSingle x ty') - exact (DctMulti x tys) = do - tys' <- markAnnotated tys - return (DctMulti x tys') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsSigType GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsSig a bndrs ty) = do - bndrs' <- markAnnotated bndrs - ty' <- markAnnotated ty - return (HsSig a bndrs' ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedN RdrName) where - getAnnotationEntry (L sann _) = fromAnn sann - setAnnotationAnchor = setAnchorAn - - exact (L (EpAnn anc ann cs) n) = do - ann' <- - case ann of - NameAnn a o l c t -> do - mn <- markName a o (Just (l,n)) c - case mn of - (o', (Just (l',_n)), c') -> do - return (NameAnn a o' l' c' t) - _ -> error "ExactPrint (LocatedN RdrName)" - NameAnnCommas a o commas c t -> do - let (kwo,kwc) = adornments a - (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o) - commas' <- forM commas (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnComma loc)) - (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) - return (NameAnnCommas a o' commas' c' t) - NameAnnBars a o bars c t -> do - let (kwo,kwc) = adornments a - (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o) - bars' <- forM bars (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnVbar loc)) - (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) - return (NameAnnBars a o' bars' c' t) - NameAnnOnly a o c t -> do - (o',_,c') <- markName a o Nothing c - return (NameAnnOnly a o' c' t) - NameAnnRArrow unicode o nl c t -> do - o' <- case o of - Just o0 -> do - (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0) - return (Just o') - Nothing -> return Nothing - (AddEpAnn _ nl') <- - if unicode - then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl) - else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl) - c' <- case c of - Just c0 -> do - (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0) - return (Just c') - Nothing -> return Nothing - return (NameAnnRArrow unicode o' nl' c' t) - NameAnnQuote q name t -> do - debugM $ "NameAnnQuote" - (AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q) - (L name' _) <- markAnnotated (L name n) - return (NameAnnQuote q' name' t) - NameAnnTrailing t -> do - _anc' <- printUnicode anc n - return (NameAnnTrailing t) - return (L (EpAnn anc ann' cs) n) - -locFromAdd :: AddEpAnn -> EpaLocation -locFromAdd (AddEpAnn _ loc) = loc - -printUnicode :: (Monad m, Monoid w) => Anchor -> RdrName -> EP w m Anchor -printUnicode anc n = do - let str = case (showPprUnsafe n) of - -- TODO: unicode support? - "forall" -> if spanLength (anchor anc) == 1 then "∀" else "forall" - s -> s - loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str - case loc of - EpaSpan _ -> return anc - EpaDelta dp [] -> return $ EpaDelta dp [] - EpaDelta _ _cs -> error "printUnicode should not capture comments" - - -markName :: (Monad m, Monoid w) - => NameAdornment -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation - -> EP w m (EpaLocation, Maybe (EpaLocation,RdrName), EpaLocation) -markName adorn open mname close = do - let (kwo,kwc) = adornments adorn - (AddEpAnn _ open') <- markKwC CaptureComments (AddEpAnn kwo open) - mname' <- - case mname of - Nothing -> return Nothing - Just (name, a) -> do - name' <- printStringAtAAC CaptureComments name (showPprUnsafe a) - return (Just (name',a)) - (AddEpAnn _ close') <- markKwC CaptureComments (AddEpAnn kwc close) - return (open', mname', close') - -adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId) -adornments NameParens = (AnnOpenP, AnnCloseP) -adornments NameParensHash = (AnnOpenPH, AnnClosePH) -adornments NameBackquotes = (AnnBackquote, AnnBackquote) -adornments NameSquare = (AnnOpenS, AnnCloseS) - -markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn] -markTrailing ts = do - p <- getPosP - debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) - mapM markKwT ts - --- --------------------------------------------------------------------- - --- based on pp_condecls in Decls.hs -exact_condecls :: (Monad m, Monoid w) - => [AddEpAnn] -> [LConDecl GhcPs] -> EP w m ([AddEpAnn],[LConDecl GhcPs]) -exact_condecls an cs - | gadt_syntax -- In GADT syntax - = do - cs' <- mapM markAnnotated cs - return (an, cs') - | otherwise -- In H98 syntax - = do - an0 <- markEpAnnL an lidl AnnEqual - cs' <- mapM markAnnotated cs - return (an0, cs') - where - gadt_syntax = case cs of - [] -> False - (L _ ConDeclH98{} : _) -> False - (L _ ConDeclGADT{} : _) -> True - --- --------------------------------------------------------------------- - -instance ExactPrint (ConDecl GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - --- 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 - an0 <- if has_forall - then markEpAnnL an lidl AnnForall - else return an - ex_tvs' <- mapM markAnnotated ex_tvs - an1 <- if has_forall - then markEpAnnL an0 lidl AnnDot - else return an0 - mcxt' <- mapM markAnnotated mcxt - an2 <- if (isJust mcxt) - then markEpAnnL an1 lidl AnnDarrow - else return an1 - - (con', args') <- exact_details args - return (ConDeclH98 { con_ext = an2 - , con_name = con' - , con_forall = has_forall - , con_ex_tvs = ex_tvs' - , con_mb_cxt = mcxt' - , con_args = args' - , con_doc = doc }) - - 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 - t1' <- markAnnotated t1 - con' <- markAnnotated con - t2' <- markAnnotated t2 - return (con', InfixCon t1' t2') - exact_details (PrefixCon tyargs tys) = do - con' <- markAnnotated con - tyargs' <- markAnnotated tyargs - tys' <- markAnnotated tys - return (con', PrefixCon tyargs' tys') - exact_details (RecCon fields) = do - con' <- markAnnotated con - fields' <- markAnnotated fields - return (con', RecCon fields') - - -- ----------------------------------- - - exact (ConDeclGADT { con_g_ext = (dcol, an) - , con_names = cons - , con_bndrs = bndrs - , con_mb_cxt = mcxt, con_g_args = args - , con_res_ty = res_ty, con_doc = doc }) = do - cons' <- mapM markAnnotated cons - dcol' <- markEpUniToken dcol - an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - - -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 - bndrs' <- case bndrs of - L _ (HsOuterImplicit _) -> return bndrs - _ -> markAnnotated bndrs - - mcxt' <- mapM markAnnotated mcxt - an2 <- if (isJust mcxt) - then markEpAnnL an1 lidl AnnDarrow - else return an1 - args' <- - case args of - (PrefixConGADT x args0) -> do - args0' <- mapM markAnnotated args0 - return (PrefixConGADT x args0') - (RecConGADT rarr fields) -> do - fields' <- markAnnotated fields - rarr' <- markEpUniToken rarr - return (RecConGADT rarr' fields') - res_ty' <- markAnnotated res_ty - return (ConDeclGADT { con_g_ext = (dcol', an2) - , con_names = cons' - , con_bndrs = bndrs' - , con_mb_cxt = mcxt', con_g_args = args' - , con_res_ty = res_ty', con_doc = doc }) - --- --------------------------------------------------------------------- - -instance ExactPrint Void where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact x = return x - --- --------------------------------------------------------------------- - -instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where - getAnnotationEntry (HsOuterImplicit _) = NoEntryVal - getAnnotationEntry (HsOuterExplicit an _) = fromAnn an - - setAnnotationAnchor (HsOuterImplicit a) _ _ _ = HsOuterImplicit a - setAnnotationAnchor (HsOuterExplicit an a) anc ts cs = HsOuterExplicit (setAnchorEpa an anc ts cs) a - - exact b@(HsOuterImplicit _) = pure b - exact (HsOuterExplicit an bndrs) = do - an0 <- markLensAA an lfst -- "forall" - bndrs' <- markAnnotated bndrs - an1 <- markLensAA an0 lsnd -- "." - return (HsOuterExplicit an1 bndrs') - --- --------------------------------------------------------------------- - -instance ExactPrint (ConDeclField GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (ConDeclField an names ftype mdoc) = do - names' <- markAnnotated names - an0 <- markEpAnnL an lidl AnnDcolon - ftype' <- markAnnotated ftype - return (ConDeclField an0 names' ftype' mdoc) - --- --------------------------------------------------------------------- - -instance ExactPrint (FieldOcc GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (FieldOcc x n) = do - n' <- markAnnotated n - return (FieldOcc x n') - --- --------------------------------------------------------------------- - -instance ExactPrint (AmbiguousFieldOcc GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact f@(Unambiguous _ n) = markAnnotated n >> return f - exact f@(Ambiguous _ n) = markAnnotated n >> return f - --- --------------------------------------------------------------------- - -instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (HsScaled arr t) = do - t' <- markAnnotated t - arr' <- markArrow arr - return (HsScaled arr' t') - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP CType) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - - exact (L an (CType stp mh (stct,ct))) = do - an0 <- markAnnOpenP an stp "{-# CTYPE" - an1 <- case mh of - Nothing -> return an0 - Just (Header srcH _h) -> - markEpAnnLMS an0 lapr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" "")) - an2 <- markEpAnnLMS an1 lapr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) "")) - an3 <- markAnnCloseP an2 - return (L an3 (CType stp mh (stct,ct))) - --- --------------------------------------------------------------------- - -instance ExactPrint (SourceText, RuleName) where - -- We end up at the right place from the Located wrapper - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (st, rn) - = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") - >> return (st, 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 - setAnnotationAnchor = setAnchorAn - - exact (L an ies) = do - debugM $ "LocatedL [LIE" - an0 <- markEpAnnL' an lal_rest AnnHiding - p <- getPosP - debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p - (an1, ies') <- markAnnList an0 (markAnnotated (filter notIEDoc ies)) - return (L an1 ies') - -instance (ExactPrint (Match GhcPs (LocatedA body))) - => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an a) = do - debugM $ "LocatedL [LMatch" - -- TODO: markAnnList? - an0 <- markEpAnnAllL an lal_rest AnnWhere - an1 <- markLensMAA an0 lal_open - an2 <- markEpAnnAllL an1 lal_rest AnnSemi - a' <- markAnnotated a - an3 <- markLensMAA an2 lal_close - return (L an3 a') - -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an stmts) = do - debugM $ "LocatedL [ExprLStmt" - (an'', stmts') <- markAnnList an $ do - case snocView stmts of - Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do - debugM $ "LocatedL [ExprLStmt: snocView" - ls' <- markAnnotated ls - initStmts' <- markAnnotated initStmts - return (initStmts' ++ [ls']) - _ -> do - markAnnotated stmts - return (L an'' stmts') - -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L ann es) = do - debugM $ "LocatedL [CmdLStmt" - an0 <- markLensMAA ann lal_open - es' <- mapM markAnnotated es - an1 <- markLensMAA an0 lal_close - return (L an1 es') - -instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an fs) = do - debugM $ "LocatedL [LConDeclField" - (an', fs') <- markAnnList an (markAnnotated fs) - return (L an' fs') - -instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an bf) = do - debugM $ "LocatedL [LBooleanFormula" - (an', bf') <- markAnnList an (markAnnotated bf) - return (L an' bf') - --- --------------------------------------------------------------------- --- LocatedL instances end -- --- ===================================================================== - -instance ExactPrint (IE GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (IEVar depr ln doc) = do - depr' <- markAnnotated depr - ln' <- markAnnotated ln - doc' <- markAnnotated doc - return (IEVar depr' ln' doc') - exact (IEThingAbs (depr, an) thing doc) = do - depr' <- markAnnotated depr - thing' <- markAnnotated thing - doc' <- markAnnotated doc - return (IEThingAbs (depr', an) thing' doc') - exact (IEThingAll (depr, an) thing doc) = do - depr' <- markAnnotated depr - thing' <- markAnnotated thing - an0 <- markEpAnnL an lidl AnnOpenP - an1 <- markEpAnnL an0 lidl AnnDotdot - an2 <- markEpAnnL an1 lidl AnnCloseP - doc' <- markAnnotated doc - return (IEThingAll (depr', an2) thing' doc') - - exact (IEThingWith (depr, an) thing wc withs doc) = do - depr' <- markAnnotated depr - thing' <- markAnnotated thing - an0 <- markEpAnnL an lidl AnnOpenP - (an1, wc', withs') <- - case wc of - NoIEWildcard -> do - withs'' <- markAnnotated withs - return (an0, wc, withs'') - IEWildcard pos -> do - let (bs, as) = splitAt pos withs - bs' <- markAnnotated bs - an1 <- markEpAnnL an0 lidl AnnDotdot - an2 <- markEpAnnL an1 lidl AnnComma - as' <- markAnnotated as - return (an2, wc, bs'++as') - an2 <- markEpAnnL an1 lidl AnnCloseP - doc' <- markAnnotated doc - return (IEThingWith (depr', an2) thing' wc' withs' doc') - - exact (IEModuleContents (depr, an) m) = do - depr' <- markAnnotated depr - an0 <- markEpAnnL an lidl AnnModule - m' <- markAnnotated m - return (IEModuleContents (depr', an0) m') - - -- These three exist to not error out, but are no-ops The contents - -- appear as "normal" comments too, which we process instead. - exact (IEGroup x lev doc) = do - return (IEGroup x lev doc) - exact (IEDoc x doc) = do - return (IEDoc x doc) - exact (IEDocNamed x str) = do - return (IEDocNamed x str) - --- --------------------------------------------------------------------- - -instance ExactPrint (IEWrappedName GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (IEName x n) = do - n' <- markAnnotated n - return (IEName x n') - exact (IEPattern r n) = do - r' <- printStringAtAA r "pattern" - n' <- markAnnotated n - return (IEPattern r' n') - exact (IEType r n) = do - r' <- printStringAtAA r "type" - n' <- markAnnotated n - return (IEType r' n') - --- --------------------------------------------------------------------- - -instance ExactPrint (Pat GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (WildPat w) = do - anchor' <- getAnchorU - debugM $ "WildPat:anchor'=" ++ show anchor' - _ <- printStringAtRs anchor' "_" - return (WildPat w) - exact (VarPat x n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered. - let pun_RDR = "pun-right-hand-side" - n' <- if (showPprUnsafe n /= pun_RDR) - then markAnnotated n - else return n - return (VarPat x n') - exact (LazyPat an pat) = do - an0 <- markEpAnnL an lidl AnnTilde - pat' <- markAnnotated pat - return (LazyPat an0 pat') - exact (AsPat at n pat) = do - n' <- markAnnotated n - at' <- markEpToken at - pat' <- markAnnotated pat - return (AsPat at' n' pat') - exact (ParPat (lpar, rpar) pat) = do - lpar' <- markEpToken lpar - pat' <- markAnnotated pat - rpar' <- markEpToken rpar - return (ParPat (lpar', rpar') pat') - - exact (BangPat an pat) = do - an0 <- markEpAnnL an lidl AnnBang - pat' <- markAnnotated pat - return (BangPat an0 pat') - - exact (ListPat an pats) = do - (an', pats') <- markAnnList' an (markAnnotated pats) - return (ListPat an' pats') - - exact (TuplePat an pats boxity) = do - an0 <- case boxity of - Boxed -> markEpAnnL an lidl AnnOpenP - Unboxed -> markEpAnnL an lidl AnnOpenPH - pats' <- markAnnotated pats - an1 <- case boxity of - Boxed -> markEpAnnL an0 lidl AnnCloseP - Unboxed -> markEpAnnL an0 lidl AnnClosePH - return (TuplePat an1 pats' boxity) - - exact (SumPat an pat alt arity) = do - an0 <- markEpAnnL an lsumPatParens AnnOpenPH - an1 <- markAnnKwAllL an0 lsumPatVbarsBefore AnnVbar - pat' <- markAnnotated pat - an2 <- markAnnKwAllL an1 lsumPatVbarsAfter AnnVbar - an3 <- markEpAnnL an2 lsumPatParens AnnClosePH - return (SumPat an3 pat' alt arity) - - exact (ConPat an con details) = do - (an', con', details') <- exactUserCon an con details - return (ConPat an' con' details') - exact (ViewPat an expr pat) = do - expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnRarrow - pat' <- markAnnotated pat - return (ViewPat an0 expr' pat') - exact (SplicePat x splice) = do - splice' <- markAnnotated splice - return (SplicePat x splice') - exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p - exact (NPat an ol mn z) = do - an0 <- if (isJust mn) - then markEpAnnL an lidl AnnMinus - else return an - ol' <- markAnnotated ol - return (NPat an0 ol' mn z) - - exact (NPlusKPat an n k lit2 a b) = do - n' <- markAnnotated n - an' <- printStringAtAAL an lid "+" - k' <- markAnnotated k - return (NPlusKPat an' n' k' lit2 a b) - - exact (SigPat an pat sig) = do - pat' <- markAnnotated pat - an0 <- markEpAnnL an lidl AnnDcolon - sig' <- markAnnotated sig - return (SigPat an0 pat' sig') - - exact (EmbTyPat toktype tp) = do - toktype' <- markEpToken toktype - tp' <- markAnnotated tp - return (EmbTyPat toktype' tp') - - exact (InvisPat tokat tp) = do - tokat' <- markEpToken tokat - tp' <- markAnnotated tp - pure (InvisPat tokat' tp') - --- --------------------------------------------------------------------- - --- Note: Keep this section, for backport to GHC 9.10 - --- instance ExactPrint (ArgPat GhcPs) where --- getAnnotationEntry (VisPat _ pat) = getAnnotationEntry pat --- getAnnotationEntry InvisPat{} = NoEntryVal - --- setAnnotationAnchor (VisPat x pat) anc ts cs = VisPat x (setAnnotationAnchor pat anc ts cs) --- setAnnotationAnchor a@(InvisPat _ _) _ _ _ = a - --- exact (VisPat x pat) = do --- pat' <- markAnnotated pat --- pure (VisPat x pat') - --- exact (InvisPat tokat tp) = do --- tokat' <- markEpToken tokat --- tp' <- markAnnotated tp --- pure (InvisPat tokat' tp') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsPatSigType GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsPS an ty) = do - ty' <- markAnnotated ty - return (HsPS an ty') - -instance ExactPrint (HsTyPat GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsTP an ty) = do - ty' <- markAnnotated ty - return (HsTP an ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsOverLit GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ _ = a - - 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 (unpackFS s) >> return ol - NoSourceText -> return ol - --- --------------------------------------------------------------------- - -hsLit2String :: HsLit GhcPs -> String -hsLit2String lit = - case lit of - HsChar src v -> toSourceTextWithSuffix src v "" - 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 "" - HsInt8Prim src v -> toSourceTextWithSuffix src v "" - HsInt16Prim src v -> toSourceTextWithSuffix src v "" - HsInt32Prim src v -> toSourceTextWithSuffix src v "" - HsInt64Prim src v -> toSourceTextWithSuffix src v "" - HsWord8Prim src v -> toSourceTextWithSuffix src v "" - HsWord16Prim src v -> toSourceTextWithSuffix src v "" - HsWord32Prim 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 "##" - -toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String -toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix - -sourceTextToString :: SourceText -> String -> String -sourceTextToString NoSourceText alt = alt -sourceTextToString (SourceText txt) _ = unpackFS txt - --- --------------------------------------------------------------------- - -exactUserCon :: (Monad m, Monoid w, ExactPrint con) - => [AddEpAnn] -> con -> HsConPatDetails GhcPs - -> EP w m ([AddEpAnn], con, HsConPatDetails GhcPs) -exactUserCon an c (InfixCon p1 p2) = do - p1' <- markAnnotated p1 - c' <- markAnnotated c - p2' <- markAnnotated p2 - return (an, c', InfixCon p1' p2') -exactUserCon an c details = do - c' <- markAnnotated c - an0 <- markEpAnnL an lidl AnnOpenC - details' <- exactConArgs details - an1 <- markEpAnnL an0 lidl AnnCloseC - return (an1, c', details') - -instance ExactPrint (HsConPatTyArg GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (HsConPatTyArg at tyarg) = do - at' <- markEpToken at - tyarg' <- markAnnotated tyarg - return (HsConPatTyArg at' tyarg') - -exactConArgs :: (Monad m, Monoid w) - => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) -exactConArgs (PrefixCon tyargs pats) = do - tyargs' <- markAnnotated tyargs - pats' <- markAnnotated pats - return (PrefixCon tyargs' pats') -exactConArgs (InfixCon p1 p2) = do - p1' <- markAnnotated p1 - p2' <- markAnnotated p2 - return (InfixCon p1' p2') -exactConArgs (RecCon rpats) = do - rpats' <- markAnnotated rpats - return (RecCon rpats') - --- --------------------------------------------------------------------- - -entryFromLocatedA :: (HasTrailing ann) => LocatedAn ann a -> Entry -entryFromLocatedA (L la _) = fromAnn 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 - p' <- getPosP - d <- getPriorEndD - debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',d,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 - --- | Print a comment, using the current layout offset to convert the --- @DeltaPos@ to an absolute position. -printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () -printQueuedComment Comment{commentContents} dp = do - p <- getPosP - d <- getPriorEndD - 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 - p' <- getPosP - d' <- getPriorEndD - debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d') - debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) - ------------------------------------------------------------------------- - -setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a -setLayoutBoth k = do - oldLHS <- getLayoutOffsetD - 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 a -> EP w m a -setLayoutTopLevelP k = do - debugM $ "setLayoutTopLevelP entered" - oldAnchorOffset <- getLayoutOffsetP - modify (\a -> a { pMarkLayout = False - , pLHS = 0} ) - r <- k - debugM $ "setLayoutTopLevelP:resetting" - setLayoutOffsetP oldAnchorOffset - return r - ------------------------------------------------------------------------- - -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}) - -getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe DeltaPos) -getExtraDPReturn = gets uExtraDPReturn - -setExtraDPReturn :: (Monad m, Monoid w) => Maybe DeltaPos -> EP w m () +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-} + +module Language.Haskell.GHC.ExactPrint.ExactPrint + ( + ExactPrint(..) + , exactPrint + , exactPrintWithOptions + , makeDeltaAst + + -- * Configuration + , EPOptions(epTokenPrint, epWhitespacePrint) + , stringOptions + , epOptions + , deltaOptions + + -- * Utility + , setAnchorAn + ) where + +import GHC +import GHC.Base (NonEmpty(..)) +import GHC.Core.Coercion.Axiom (Role(..)) +import qualified GHC.Data.BooleanFormula as BF +import GHC.Data.FastString +import qualified GHC.Data.Strict as Strict +import GHC.TypeLits +import GHC.Types.Basic hiding (EP) +import GHC.Types.Fixity +import GHC.Types.ForeignCall +import GHC.Types.Name.Reader +import GHC.Types.PkgQual +import GHC.Types.SourceText +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Unit.Module.Warnings +import GHC.Utils.Misc +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Utils.Panic + + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad (forM, when, unless) +import Control.Monad.Identity (Identity(..)) +import qualified Control.Monad.Reader as Reader +import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask) +import Control.Monad.Trans (lift) +import Data.Data ( Data ) +import Data.Dynamic +import Data.Foldable +import Data.Functor.Const +import Data.Typeable +import Data.List ( partition, sort, sortBy) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe ( isJust, mapMaybe ) +import Data.Void + +import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types + +-- --------------------------------------------------------------------- + +exactPrint :: ExactPrint ast => ast -> String +exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) + +-- | The additional option to specify the printing configuration. +exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m) + => EPOptions m b + -> ast + -> m (ast, b) +exactPrintWithOptions r ast = + runEP r (markAnnotated ast) + +-- | Transform concrete annotations into relative annotations. +-- This should be unnecessary from GHC 9.10 +makeDeltaAst :: ExactPrint ast => ast -> ast +makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) + +------------------------------------------------------ + +type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a + +runEP :: (Monad m) + => EPOptions m w + -> EP w m a -> m (a, w) +runEP epReader action = do + (ast, w) <- evalRWST action epReader defaultEPState + return (ast, output w) + +-- --------------------------------------------------------------------- + +defaultEPState :: EPState +defaultEPState = EPState + { epPos = (1,1) + , dLHS = 0 + , pMarkLayout = False + , pLHS = 0 + , dMarkLayout = False + , dPriorEndPosition = (1,1) + , uAnchorSpan = badRealSrcSpan + , uExtraDP = Nothing + , uExtraDPReturn = Nothing + , pAcceptSpan = False + , epComments = [] + , epCommentsApplied = [] + , epEof = Nothing + } + + +-- --------------------------------------------------------------------- +-- 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 EPOptions m a = EPOptions + { epTokenPrint :: String -> m a + , epWhitespacePrint :: String -> m a + } + +-- | Helper to create a 'EPOptions' +epOptions :: (String -> m a) + -> (String -> m a) + -> EPOptions m a +epOptions tokenPrint wsPrint = EPOptions + { epWhitespacePrint = wsPrint + , epTokenPrint = tokenPrint + } + +-- | Options which can be used to print as a normal String. +stringOptions :: EPOptions Identity String +stringOptions = epOptions return return + +-- | Options which can be used to simply update the AST to be in delta +-- form, without generating output +deltaOptions :: EPOptions Identity () +deltaOptions = epOptions (\_ -> return ()) (\_ -> return ()) + +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 EpaLocation) -- ^ Used to anchor a + -- list + , uExtraDPReturn :: !(Maybe (SrcSpan, DeltaPos)) + -- ^ Used to return Delta version of uExtraDP + , pAcceptSpan :: Bool -- ^ When we have processed an + -- entry of EpaDelta, accept the + -- next `EpaSpan` start as the + -- current output position. i.e. do + -- not advance epPos. Achieved by + -- setting dPriorEndPosition to the + -- end of the span. + + -- 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] + , epCommentsApplied :: ![[Comment]] + , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan)) + } + +-- --------------------------------------------------------------------- + +-- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry +class HasEntry ast where + fromAnn :: ast -> Entry + +class HasTrailing a where + trailing :: a -> [TrailingAnn] + setTrailing :: a -> [TrailingAnn] -> a + +setAnchorEpa :: (HasTrailing an) + => EpAnn an -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn an +setAnchorEpa (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing an ts) cs + +setAnchorHsModule :: HsModule GhcPs -> EpaLocation -> EpAnnComments -> HsModule GhcPs +setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} } + where + anc' = anc + an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' [] cs + +setAnchorAn :: (HasTrailing an) + => LocatedAn an a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> LocatedAn an a +setAnchorAn (L (EpAnn _ an _) a) anc ts cs = (L (EpAnn anc (setTrailing an ts) cs) a) + -- `debug` ("setAnchorAn: anc=" ++ showAst anc) + +setAnchorEpaL :: EpAnn (AnnList l) -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn (AnnList l) +setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = Nothing}) ts) cs + +-- --------------------------------------------------------------------- + +-- | Key entry point. Switches to an independent AST element with its +-- own annotation, calculating new offsets, etc +markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a +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) + +-- | For GenLocated SrcSpan, we construct an entry location but cannot update it. +data CanUpdateAnchor = CanUpdateAnchor + | CanUpdateAnchorOnly + | NoCanUpdateAnchor + deriving (Eq, Show, Data) + +data Entry = Entry EpaLocation [TrailingAnn] EpAnnComments FlushComments CanUpdateAnchor + | NoEntryVal + +-- | For flagging whether to capture comments in an EpaDelta or not +data CaptureComments = CaptureComments + | NoCaptureComments + +mkEntry :: EpaLocation -> [TrailingAnn] -> EpAnnComments -> Entry +mkEntry anc ts cs = Entry anc ts cs NoFlushComments CanUpdateAnchor + +instance (HasTrailing a) => HasEntry (EpAnn a) where + fromAnn (EpAnn anc a cs) = mkEntry anc (trailing a) cs + +-- --------------------------------------------------------------------- + +instance HasTrailing NoEpAnns where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpaLocation where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpAnnSumPat where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing (AnnList a) where + trailing a = al_trailing a + setTrailing a ts = a { al_trailing = ts } + +instance HasTrailing AnnListItem where + trailing a = lann_trailing a + setTrailing a ts = a { lann_trailing = ts } + +instance HasTrailing AnnPragma where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnContext where + trailing (AnnContext ma _opens _closes) + = case ma of + Just r -> [AddDarrowAnn r] + _ -> [] + + setTrailing a [AddDarrowAnn r] = a{ac_darrow = Just r} + setTrailing a [] = a{ac_darrow = Nothing} + setTrailing a ts = error $ "Cannot setTrailing " ++ showAst ts ++ " for " ++ showAst a + + +instance HasTrailing AnnParen where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnsIf where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpAnnHsCase where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnFieldLabel where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnProjection where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnExplicitSum where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing (Maybe EpAnnUnboundVar) where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing GrhsAnn where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnSig where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing HsRuleAnn where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpAnnImportDecl where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnsModule where + -- Report none, as all are used internally + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing NameAnn where + trailing a = nann_trailing a + setTrailing a ts = a { nann_trailing = ts } + +instance HasTrailing Bool where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing (TokForall, TokRarrow) where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing (TokForall, EpToken ".") where + trailing _ = [] + setTrailing a _ = a + +-- --------------------------------------------------------------------- + +fromAnn' :: (HasEntry a) => a -> Entry +fromAnn' an = case fromAnn an of + NoEntryVal -> NoEntryVal + Entry a ts c _ u -> Entry a ts c FlushComments u + +-- --------------------------------------------------------------------- + +astId :: (Typeable a) => a -> String +astId a = show (typeOf a) + +cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a] +cua CanUpdateAnchor f = f +cua CanUpdateAnchorOnly _ = return [] +cua NoCanUpdateAnchor _ = return [] + +-- | "Enter" an annotation, by using the associated 'anchor' field as +-- the new reference point for calculating all DeltaPos positions. +-- This is the heart of the exact printing process. +-- +-- 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 :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn NoEntryVal a = do + p <- getPosP + debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) + r <- exact a + debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) + return r +enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do + acceptSpan <- getAcceptSpan + setAcceptSpan False + case anchor' of + EpaDelta _ _ _ -> setAcceptSpan True + _ -> return () + p <- getPosP + pe0 <- getPriorEndD + debugM $ "enterAnn:starting:(anchor',p,pe,a) =" ++ show (showAst anchor', p, pe0, astId a) + prevAnchor <- getAnchorU + let curAnchor = case anchor' of + EpaSpan (RealSrcSpan r _) -> r + _ -> prevAnchor + debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) + case canUpdateAnchor of + CanUpdateAnchor -> pushAppliedComments + _ -> return () + case anchor' of + EpaDelta _ _ dcs -> do + debugM $ "enterAnn:Delta:Flushing comments" + flushComments [] + debugM $ "enterAnn:Delta:Printing prior comments:" ++ showGhc (priorComments cs) + mapM_ printOneComment (concatMap tokComment $ priorComments cs) + debugM $ "enterAnn:Delta:Printing EpaDelta comments:" ++ showGhc dcs + mapM_ printOneComment (concatMap tokComment dcs) + _ -> do + debugM $ "enterAnn:Adding comments:" ++ showGhc (priorComments cs) + addCommentsA (priorComments cs) + debugM $ "enterAnn:Added comments" + printCommentsBefore curAnchor + priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop + -- ------------------------- + case anchor' of + EpaDelta _ dp _ -> do + debugM $ "enterAnn: EpaDelta:" ++ show dp + -- Set the original anchor as prior end, so the rest of this AST + -- fragment has a reference + setPriorEndNoLayoutD (ss2pos curAnchor) + _ -> do + if acceptSpan + then setPriorEndNoLayoutD (ss2pos curAnchor) + else return () + + -- ------------------------- + if ((fst $ fst $ rs2range curAnchor) >= 0) + then + setAnchorU curAnchor + else + debugM $ "enterAnn: not calling setAnchorU for : " ++ show (rs2range curAnchor) + -- ------------------------------------------------------------------- + -- Make sure the running dPriorEndPosition gets updated according to + -- the change in the current anchor. + + -- Compute the distance from dPriorEndPosition to the start of the new span. + + -- While processing in the context of the prior anchor, we choose to + -- enter a new Anchor, which has a defined position relative to the + -- prior anchor, even if we do not actively output anything at that + -- point. + -- Is this edp? + + -- ------------------------------------------------------------------- + -- 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 <- getLayoutOffsetD + let spanStart = ss2pos curAnchor + priorEndAfterComments <- getPriorEndD + 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 curAnchor) + debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) + let edp'' = case anchor' of + EpaDelta _ dp _ -> dp + _ -> edp' + -- --------------------------------------------- + med <- getExtraDP + setExtraDP Nothing + let (edp, medr) = case med of + Nothing -> (edp'', Nothing) + Just (EpaDelta _ dp _) -> (dp, Nothing) + -- Replace original with desired one. Allows all + -- list entry values to be DP (1,0) + Just (EpaSpan ss@(RealSrcSpan r _)) -> (dp, Just (ss, dp)) + where + dp = adjustDeltaForOffset + off (ss2delta priorEndAfterComments r) + Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r + when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp) + when (isJust medr) $ setExtraDPReturn medr + -- --------------------------------------------- + -- Preparation complete, perform the action + when (priorEndAfterComments < spanStart) (do + debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart + modify (\s -> s { dPriorEndPosition = spanStart } )) + + debugM $ "enterAnn: (anchor', curAnchor):" ++ show (anchor', rs2range curAnchor) + -- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) + p0 <- getPosP + d <- getPriorEndD + debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d) + + -- end of delta phase processing + -- ------------------------------------------------------------------- + -- start of print phase processing + + advance edp + debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') + a' <- exact a + debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') + + -- Core recursive exactprint done, start end of Entry processing + + when (flush == FlushComments) $ do + debugM $ "flushing comments in enterAnn:" ++ showAst (cs, getFollowingComments cs) + flushComments (getFollowingComments cs) + debugM $ "flushing comments in enterAnn done" + + !eof <- getEofPos + case eof of + Nothing -> return () + Just (pos, prior) -> do + let dp = if pos == prior + then (DifferentLine 1 0) + else origDelta pos prior + debugM $ "EOF:(pos,posEnd,prior,dp) =" ++ showGhc (ss2pos pos, ss2posEnd pos, ss2pos prior, dp) + printStringAtLsDelta dp "" + setEofPos Nothing -- Only do this once + + -- Deal with exit from the current anchor + when (flush == NoFlushComments) $ do + printCommentsIn curAnchor -- Make sure all comments in the span are printed + + p1 <- getPosP + pe1 <- getPriorEndD + debugM $ "enterAnn:done:(anchor,p,pe,a) =" ++ show (showAst anchor', p1, pe1, astId a') + + case anchor' of + EpaDelta _ _ _ -> return () + EpaSpan (RealSrcSpan rss _) -> do + setAcceptSpan False + setPriorEndD (snd $ rs2range rss) + EpaSpan _ -> return () + + -- Outside the anchor, mark any trailing + postCs <- cua canUpdateAnchor takeAppliedCommentsPop + following <- if (flush == NoFlushComments) + then do + let (before, after) = splitAfterTrailingAnns trailing_anns + (getFollowingComments cs) + addCommentsA before + return after + else return [] + !trailing' <- markTrailing trailing_anns + -- mapM_ printOneComment (concatMap tokComment $ following) + addCommentsA following + + -- Update original anchor, comments based on the printing process + -- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan + let newAnchor = case anchor' of + EpaSpan s -> EpaDelta s edp [] + _ -> EpaDelta noSrcSpan edp [] + let r = case canUpdateAnchor of + CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) + CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments + NoCanUpdateAnchor -> a' + return r + +-- --------------------------------------------------------------------- + +-- | Split the span following comments into ones that occur prior to +-- the last trailing ann, and ones after. +splitAfterTrailingAnns :: [TrailingAnn] -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) +splitAfterTrailingAnns [] cs = ([], cs) +splitAfterTrailingAnns tas cs = (before, after) + where + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + (before, after) = case reverse (concatMap trailing_loc tas) of + [] -> ([],cs) + (s:_) -> (b,a) + where + s_pos = ss2pos s + (b,a) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > s_pos) + cs + +-- --------------------------------------------------------------------- + +addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () +addCommentsA csNew = addComments False (concatMap tokComment csNew) + +{- +TODO: When we addComments, some may have an anchor that is no longer +valid, as it has been moved and has an anchor_op. + +Does an Anchor even make sense for a comment, perhaps it should be an +EpaLocation? + +How do we sort them? do we assign a location based on when we add them +to the list, based on the current output pos? Except the offset is a +delta compared to a reference location. Need to nail the concept of +the reference location. + +By definition it is the current anchor, so work against that. And that +also means that the first entry comment that has moved should not have +a line offset. +-} +addComments :: (Monad m, Monoid w) => Bool -> [Comment] -> EP w m () +addComments sortNeeded csNew = do + debugM $ "addComments:csNew" ++ show csNew + cs <- getUnallocatedComments + debugM $ "addComments:cs" ++ show cs + -- We can only sort the comments if we are in the first phase, + -- where all comments have locations. If any have EpaDelta the + -- sort will fail, so we do not try. + if sortNeeded && all noDelta (csNew ++ cs) + then putUnallocatedComments (sort (cs ++ csNew)) + else putUnallocatedComments (cs ++ csNew) + +noDelta :: Comment -> Bool +noDelta c = case commentLoc c of + EpaSpan _ -> True + _ -> False + +-- --------------------------------------------------------------------- + +-- | Just before we print out the EOF comments, flush the remaining +-- ones in the state. +flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () +flushComments !trailing_anns = do + debugM $ "flushComments entered: " ++ showAst trailing_anns + addCommentsA trailing_anns + debugM $ "flushComments after addCommentsA" + cs <- getUnallocatedComments + debugM $ "flushComments: got cs" + debugM $ "flushing comments starting: cs" ++ showAst cs + mapM_ printOneComment cs + putUnallocatedComments [] + debugM $ "flushing comments done" + +-- --------------------------------------------------------------------- + +epTokensToComments :: (Monad m, Monoid w) + => String -> [EpToken tok] -> EP w m () +epTokensToComments kw toks + = addComments True (concatMap (\tok -> + case tok of + EpTok ss -> [mkKWComment kw (epaToNoCommentsLocation ss)] + NoEpTok -> []) toks) + +-- --------------------------------------------------------------------- + +-- Temporary function to simply reproduce the "normal" pretty printer output +withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a +withPpr a = do + ss <- getAnchorU + debugM $ "withPpr: ss=" ++ show ss + printStringAtRs' ss (showPprUnsafe a) + return a + +-- --------------------------------------------------------------------- + +-- | 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 + setAnnotationAnchor :: a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> a + exact :: (Monad m, Monoid w) => a -> EP w m a + +-- --------------------------------------------------------------------- +-- Start of utility functions +-- --------------------------------------------------------------------- + +printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () +printSourceText (NoSourceText) txt = printStringAdvance txt >> return () +printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return () + +printSourceTextAA :: (Monad m, Monoid w) => SourceText -> String -> EP w m () +printSourceTextAA (NoSourceText) txt = printStringAdvanceA txt >> return () +printSourceTextAA (SourceText txt) _ = printStringAdvanceA (unpackFS txt) >> return () + +-- --------------------------------------------------------------------- + +printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRs pa str = printStringAtRsC CaptureComments pa str + +printStringAtRsC :: (Monad m, Monoid w) + => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRsC capture pa str = do + debugM $ "printStringAtRsC: pa=" ++ showAst pa + printCommentsBefore pa + pe <- getPriorEndD + debugM $ "printStringAtRsC:pe=" ++ show pe + let p = ss2delta pe pa + p' <- adjustDeltaForOffsetM p + debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p') + printStringAtLsDelta p' str + setPriorEndASTD pa + cs' <- case capture of + CaptureComments -> takeAppliedComments + NoCaptureComments -> return [] + debugM $ "printStringAtRsC:cs'=" ++ show cs' + debugM $ "printStringAtRsC:p'=" ++ showAst p' + debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta noSrcSpan p' NoComments) + debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta noSrcSpan p' (map comment2LEpaComment cs')) + return (EpaDelta (RealSrcSpan pa Strict.Nothing) p' (map comment2LEpaComment cs')) + +printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m () +printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return () + +-- --------------------------------------------------------------------- + +printStringAtMLoc' :: (Monad m, Monoid w) + => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation) +printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s +printStringAtMLoc' Nothing s = do + printStringAtLsDelta (SameLine 1) s + return (Just (EpaDelta noSrcSpan (SameLine 1) [])) + +printStringAtMLocL :: (Monad m, Monoid w) + => EpAnn a -> Lens a (Maybe EpaLocation) -> String -> EP w m (EpAnn a) +printStringAtMLocL (EpAnn anc an cs) l s = do + r <- go (view l an) s + return (EpAnn anc (set l r an) cs) + where + go (Just aa) str = Just <$> printStringAtAA aa str + go Nothing str = do + printStringAtLsDelta (SameLine 1) str + return (Just (EpaDelta noSrcSpan (SameLine 1) [])) + +printStringAdvanceA :: (Monad m, Monoid w) => String -> EP w m () +printStringAdvanceA str = printStringAtAA (EpaDelta noSrcSpan (SameLine 0) []) str >> return () + +printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation +printStringAtAA el str = printStringAtAAC CaptureComments el str + +printStringAtNC :: (Monad m, Monoid w) => NoCommentsLocation -> String -> EP w m NoCommentsLocation +printStringAtNC el str = do + el' <- printStringAtAAC NoCaptureComments (noCommentsToEpaLocation el) str + return (epaToNoCommentsLocation el') + +printStringAtAAC :: (Monad m, Monoid w) + => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation +printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s +printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss +printStringAtAAC capture (EpaDelta ss d cs) s = do + mapM_ printOneComment $ concatMap tokComment cs + pe1 <- getPriorEndD + p1 <- getPosP + printStringAtLsDelta d s + p2 <- getPosP + pe2 <- getPriorEndD + debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2) + setPriorEndASTPD (pe1,pe2) + cs' <- case capture of + CaptureComments -> takeAppliedComments + NoCaptureComments -> return [] + debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs') + return (EpaDelta ss d (map comment2LEpaComment cs')) + +-- --------------------------------------------------------------------- + +markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation +markExternalSourceTextE l NoSourceText txt = printStringAtAA l txt +markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt) + +-- --------------------------------------------------------------------- + +markLensBracketsO :: (Monad m, Monoid w) + => EpAnn a -> Lens a AnnListBrackets -> EP w m (EpAnn a) +markLensBracketsO epann l = markLensBracketsO' epann (lepa . l) + +markLensBracketsO' :: (Monad m, Monoid w) + => a -> Lens a AnnListBrackets -> EP w m a +markLensBracketsO' a l = + case view l a of + ListParens o c -> do + o' <- markEpToken o + return (set l (ListParens o' c) a) + ListBraces o c -> do + o' <- markEpToken o + return (set l (ListBraces o' c) a) + ListSquare o c -> do + o' <- markEpToken o + return (set l (ListSquare o' c) a) + ListBanana o c -> do + o' <- markEpUniToken o + return (set l (ListBanana o' c) a) + ListNone -> return (set l ListNone a) + +markLensBracketsC :: (Monad m, Monoid w) + => EpAnn a -> Lens a AnnListBrackets -> EP w m (EpAnn a) +markLensBracketsC epann l = markLensBracketsC' epann (lepa . l) + +markLensBracketsC' :: (Monad m, Monoid w) + => a -> Lens a AnnListBrackets -> EP w m a +markLensBracketsC' a l = + case view l a of + ListParens o c -> do + c' <- markEpToken c + return (set l (ListParens o c') a) + ListBraces o c -> do + c' <- markEpToken c + return (set l (ListBraces o c') a) + ListSquare o c -> do + c' <- markEpToken c + return (set l (ListSquare o c') a) + ListBanana o c -> do + c' <- markEpUniToken c + return (set l (ListBanana o c') a) + ListNone -> return (set l ListNone a) +-- ------------------------------------- + +-- markEpTokenM :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) +-- => Maybe (EpToken tok) -> EP w m (Maybe (EpToken tok)) + +markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => EpToken tok -> EP w m (EpToken tok) +markEpToken NoEpTok = return NoEpTok +markEpToken (EpTok aa) = do + aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) + return (EpTok aa') + +markEpToken1 :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => [EpToken tok] -> EP w m [EpToken tok] +markEpToken1 [] = return [] +markEpToken1 (h:t) = do + h' <- markEpToken h + return (h':t) + +markEpUniToken :: forall m w tok utok . (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok) + => EpUniToken tok utok -> EP w m (EpUniToken tok utok) +markEpUniToken NoEpUniTok = return NoEpUniTok +markEpUniToken (EpUniTok aa isUnicode) = do + aa' <- case isUnicode of + NormalSyntax -> printStringAtAA aa (symbolVal (Proxy @tok)) + UnicodeSyntax -> printStringAtAA aa (symbolVal (Proxy @utok)) + return (EpUniTok aa' isUnicode) + +-- --------------------------------------------------------------------- + +markArrow :: (Monad m, Monoid w, ExactPrint a) => HsArrowOf a GhcPs -> EP w m (HsArrowOf a GhcPs) +markArrow (HsUnrestrictedArrow arr) = do + arr' <- markEpUniToken arr + return (HsUnrestrictedArrow arr') +markArrow (HsLinearArrow (EpPct1 pct1 arr)) = do + pct1' <- markEpToken pct1 + arr' <- markEpUniToken arr + return (HsLinearArrow (EpPct1 pct1' arr')) +markArrow (HsLinearArrow (EpLolly arr)) = do + arr' <- markEpToken arr + return (HsLinearArrow (EpLolly arr')) +markArrow (HsExplicitMult (pct, arr) t) = do + pct' <- markEpToken pct + t' <- markAnnotated t + arr' <- markEpUniToken arr + return (HsExplicitMult (pct', arr') t') + +-- --------------------------------------------------------------------- + +markAnnOpen' :: (Monad m, Monoid w) + => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) +markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt +markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt + +markAnnOpen'' :: (Monad m, Monoid w) + => EpaLocation -> SourceText -> String -> EP w m EpaLocation +markAnnOpen'' el NoSourceText txt = printStringAtAA el txt +markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt + +-- --------------------------------------------------------------------- + +markOpeningParen, markClosingParen :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen +markOpeningParen an = markParenO an +markClosingParen an = markParenC an + +markParenO :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen +markParenO (AnnParens o c) = do + o' <- markEpToken o + return (AnnParens o' c) +markParenO (AnnParensHash o c) = do + o' <- markEpToken o + return (AnnParensHash o' c) +markParenO (AnnParensSquare o c) = do + o' <- markEpToken o + return (AnnParensSquare o' c) + +markParenC :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen +markParenC (AnnParens o c) = do + c' <- markEpToken c + return (AnnParens o c') +markParenC (AnnParensHash o c) = do + c' <- markEpToken c + return (AnnParensHash o c') +markParenC (AnnParensSquare o c) = do + c' <- markEpToken c + return (AnnParensSquare o c') + +-- --------------------------------------------------------------------- +-- Bare bones Optics +-- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html + +type Lens a b = forall f . Functor f => (b -> f b) -> (a -> f a) +type Getting a b = (b -> Const b b) -> (a -> Const b a) +type ASetter a b = (b -> Identity b) -> (a -> Identity a) + +view :: MonadReader s m => Getting s a -> m a +view l = Reader.asks (getConst . l Const) +{-# INLINE view #-} + +over :: ASetter a b -> (b -> b) -> (a -> a) +over l f = runIdentity . l (Identity . f) +{-# INLINE over #-} + +set :: Lens a b -> b -> a -> a +set lens b = over lens (\_ -> b) +{-# INLINE set #-} + +{- +Question: How do I combine lenses? + +Answer: You compose them, using function composition (Yes, really!) + +You can think of the function composition operator as having this type: + +(.) :: Lens' a b -> Lens' b c -> Lens' a c +-} + +-- --------------------------------------------------------------------- +-- Lenses + +-- data EpAnn ann +-- = EpAnn { entry :: !Anchor +-- , anns :: !ann +-- , comments :: !EpAnnComments +-- } + +lepa :: Lens (EpAnn a) a +lepa k epAnn = fmap (\newAnns -> epAnn { anns = newAnns }) + (k (anns epAnn)) + +-- data AnnsModule +-- = AnnsModule { +-- am_sig :: Maybe (EpToken "signature"), +-- am_mod :: Maybe (EpToken "module"), +-- am_where :: Maybe (EpToken "where"), +-- am_decls :: [TrailingAnn], +-- am_cs :: [LEpaComment], +-- am_eof :: Maybe (RealSrcSpan, RealSrcSpan) +-- } deriving (Data, Eq) + +lam_mod :: Lens AnnsModule (EpToken "module") +lam_mod k annsModule = fmap (\newAnns -> annsModule { am_mod = newAnns }) + (k (am_mod annsModule)) + +lam_where :: Lens AnnsModule (EpToken "where") +lam_where k annsModule = fmap (\newAnns -> annsModule { am_where = newAnns }) + (k (am_where annsModule)) + +-- lam_decls :: Lens AnnsModule AnnList +-- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns }) +-- (k (am_decls annsModule)) + + +-- data EpAnnImportDecl = EpAnnImportDecl +-- { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword +-- , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively +-- , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword +-- , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword +-- , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) +-- , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword +-- } deriving (Data) + +limportDeclAnnImport :: Lens EpAnnImportDecl (EpToken "import") +limportDeclAnnImport k annImp = fmap (\new -> annImp { importDeclAnnImport = new }) + (k (importDeclAnnImport annImp)) + +-- limportDeclAnnPragma :: Lens EpAnnImportDecl (Maybe (EpaLocation, EpaLocation)) +-- limportDeclAnnPragma k annImp = fmap (\new -> annImp { importDeclAnnPragma = new }) +-- (k (importDeclAnnPragma annImp)) + +limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe (EpToken "safe")) +limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) + (k (importDeclAnnSafe annImp)) + +limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified")) +limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) + (k (importDeclAnnQualified annImp)) + +limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new }) + (k (importDeclAnnPackage annImp)) + +-- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation) +-- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new }) +-- (k (importDeclAnnAs annImp)) + +-- ------------------------------------- + +-- data AnnList +-- = AnnList { +-- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout +-- al_brackets :: !AnnListBrackets, +-- al_semis :: [EpToken ";"], -- decls +-- al_rest :: !a, +-- al_trailing :: [TrailingAnn] -- ^ items appearing after the +-- -- list, such as '=>' for a +-- -- context +-- } deriving (Data,Eq) + +lal_brackets :: Lens (AnnList l) AnnListBrackets +lal_brackets k parent = fmap (\new -> parent { al_brackets = new }) + (k (al_brackets parent)) + +lal_semis :: Lens (AnnList l) [EpToken ";"] +lal_semis k parent = fmap (\new -> parent { al_semis = new }) + (k (al_semis parent)) + +lal_rest :: Lens (AnnList l) l +lal_rest k parent = fmap (\new -> parent { al_rest = new }) + (k (al_rest parent)) + +-- ------------------------------------- + +lfst :: Lens (a,b) a +lfst k parent = fmap (\new -> (new, snd parent)) + (k (fst parent)) + +lsnd :: Lens (b,a) a +lsnd k parent = fmap (\new -> (fst parent, new)) + (k (snd parent)) + +-- ------------------------------------- +-- data AnnExplicitSum +-- = AnnExplicitSum { +-- aesOpen :: EpaLocation, +-- aesBarsBefore :: [EpToken "|"], +-- aesBarsAfter :: [EpToken "|"], +-- aesClose :: EpaLocation +-- } deriving Data + +laesOpen :: Lens AnnExplicitSum EpaLocation +laesOpen k parent = fmap (\new -> parent { aesOpen = new }) + (k (aesOpen parent)) + +laesBarsBefore :: Lens AnnExplicitSum [EpToken "|"] +laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new }) + (k (aesBarsBefore parent)) + +laesBarsAfter :: Lens AnnExplicitSum [EpToken "|"] +laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new }) + (k (aesBarsAfter parent)) + +laesClose :: Lens AnnExplicitSum EpaLocation +laesClose k parent = fmap (\new -> parent { aesClose = new }) + (k (aesClose parent)) + +-- ------------------------------------- +-- data AnnFieldLabel +-- = AnnFieldLabel { +-- afDot :: Maybe (EpToken ".") +-- } deriving Data + +lafDot :: Lens AnnFieldLabel (Maybe (EpToken ".")) +lafDot k parent = fmap (\new -> parent { afDot = new }) + (k (afDot parent)) + +-- ------------------------------------- +-- data AnnProjection +-- = AnnProjection { +-- apOpen :: EpToken "(", +-- apClose :: EpToken ")" +-- } deriving Data + +lapOpen :: Lens AnnProjection (EpToken "(") +lapOpen k parent = fmap (\new -> parent { apOpen = new }) + (k (apOpen parent)) + +lapClose :: Lens AnnProjection (EpToken ")") +lapClose k parent = fmap (\new -> parent { apClose = new }) + (k (apClose parent)) + +-- ------------------------------------- +-- data AnnsIf +-- = AnnsIf { +-- aiIf :: EpToken "if", +-- aiThen :: EpToken "then", +-- aiElse :: EpToken "else", +-- aiThenSemi :: Maybe (EpToken ";"), +-- aiElseSemi :: Maybe (EpToken ";") +-- } deriving Data + +laiIf :: Lens AnnsIf (EpToken "if") +laiIf k parent = fmap (\new -> parent { aiIf = new }) + (k (aiIf parent)) + +laiThen :: Lens AnnsIf (EpToken "then") +laiThen k parent = fmap (\new -> parent { aiThen = new }) + (k (aiThen parent)) + +laiElse :: Lens AnnsIf (EpToken "else") +laiElse k parent = fmap (\new -> parent { aiElse = new }) + (k (aiElse parent)) + +laiThenSemi :: Lens AnnsIf (Maybe (EpToken ";")) +laiThenSemi k parent = fmap (\new -> parent { aiThenSemi = new }) + (k (aiThenSemi parent)) + +laiElseSemi :: Lens AnnsIf (Maybe (EpToken ";")) +laiElseSemi k parent = fmap (\new -> parent { aiElseSemi = new }) + (k (aiElseSemi parent)) + +-- ------------------------------------- + +-- data AnnParen +-- = AnnParen { +-- ap_adornment :: ParenType, +-- ap_open :: EpaLocation, +-- ap_close :: EpaLocation +-- } deriving (Data) + +-- lap_open :: Lens AnnParen EpaLocation +-- lap_open k parent = fmap (\new -> parent { ap_open = new }) +-- (k (ap_open parent)) + +-- lap_close :: Lens AnnParen EpaLocation +-- lap_close k parent = fmap (\new -> parent { ap_close = new }) +-- (k (ap_close parent)) + +-- ------------------------------------- +-- data EpAnnHsCase = EpAnnHsCase +-- { hsCaseAnnCase :: EpToken "case" +-- , hsCaseAnnOf :: EpToken "of" +-- } deriving Data + +lhsCaseAnnCase :: Lens EpAnnHsCase (EpToken "case") +lhsCaseAnnCase k parent = fmap (\new -> parent { hsCaseAnnCase = new }) + (k (hsCaseAnnCase parent)) + +lhsCaseAnnOf :: Lens EpAnnHsCase (EpToken "of") +lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new }) + (k (hsCaseAnnOf parent)) + +-- --------------------------------------------------------------------- + +-- data HsRuleAnn +-- = HsRuleAnn +-- { ra_tyanns :: Maybe (TokForall, EpToken ".") +-- , ra_tmanns :: Maybe (TokForall, EpToken ".") +-- , ra_equal :: EpToken "=" +-- , ra_rest :: ActivationAnn +-- } deriving (Data, Eq) + +lra_tyanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken ".")) +lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new }) + (k (ra_tyanns parent)) + +ff :: Maybe (a,b) -> (Maybe a,Maybe b) +ff Nothing = (Nothing, Nothing) +ff (Just (a,b)) = (Just a, Just b) + + +gg :: (Maybe a,Maybe b) -> Maybe (a,b) +gg (Nothing, Nothing) = Nothing +gg (Just a, Just b) = Just (a,b) +gg _ = error "gg:expecting two Nothing or two Just" + +lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b) +lff k parent = fmap (\new -> gg new) + (k (ff parent)) + +-- (.) :: Lens' a b -> Lens' b c -> Lens' a c +lra_tyanns_fst :: Lens HsRuleAnn (Maybe TokForall) +lra_tyanns_fst = lra_tyanns . lff . lfst + +lra_tyanns_snd :: Lens HsRuleAnn (Maybe (EpToken ".")) +lra_tyanns_snd = lra_tyanns . lff . lsnd + +lra_tmanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken ".")) +lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new }) + (k (ra_tmanns parent)) + +lra_tmanns_fst :: Lens HsRuleAnn (Maybe TokForall) +lra_tmanns_fst = lra_tmanns . lff . lfst + +lra_tmanns_snd :: Lens HsRuleAnn (Maybe (EpToken ".")) +lra_tmanns_snd = lra_tmanns . lff . lsnd + +lra_equal :: Lens HsRuleAnn (EpToken "=") +lra_equal k parent = fmap (\new -> parent { ra_equal = new }) + (k (ra_equal parent)) + +lra_rest :: Lens HsRuleAnn ActivationAnn +lra_rest k parent = fmap (\new -> parent { ra_rest = new }) + (k (ra_rest parent)) + + +-- --------------------------------------------------------------------- +-- data GrhsAnn +-- = GrhsAnn { +-- ga_vbar :: Maybe (EpToken "|"), +-- ga_sep :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->` +-- } deriving (Data) + +lga_vbar :: Lens GrhsAnn (Maybe (EpToken "|")) +lga_vbar k parent = fmap (\new -> parent { ga_vbar = new }) + (k (ga_vbar parent)) + +lga_sep :: Lens GrhsAnn (Either (EpToken "=") TokRarrow) +lga_sep k parent = fmap (\new -> parent { ga_sep = new }) + (k (ga_sep parent)) + +-- --------------------------------------------------------------------- +-- data EpAnnSumPat = EpAnnSumPat +-- { sumPatParens :: (EpaLocation, EpaLocation) +-- , sumPatVbarsBefore :: [EpToken "|"] +-- , sumPatVbarsAfter :: [EpToken "|"] +-- } deriving Data + +lsumPatParens :: Lens EpAnnSumPat (EpaLocation, EpaLocation) +lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new }) + (k (sumPatParens parent)) + +lsumPatVbarsBefore :: Lens EpAnnSumPat [EpToken "|"] +lsumPatVbarsBefore k parent = fmap (\new -> parent { sumPatVbarsBefore = new }) + (k (sumPatVbarsBefore parent)) + +lsumPatVbarsAfter :: Lens EpAnnSumPat [EpToken "|"] +lsumPatVbarsAfter k parent = fmap (\new -> parent { sumPatVbarsAfter = new }) + (k (sumPatVbarsAfter parent)) + +-- --------------------------------------------------------------------- +-- data EpAnnLam = EpAnnLam +-- { epl_lambda :: EpToken "\\" -- ^ Location of '\' keyword +-- , epl_case :: Maybe EpaLocation -- ^ Location of 'case' or +-- -- 'cases' keyword, depending +-- -- on related 'HsLamVariant'. +-- } deriving Data + +lepl_lambda :: Lens EpAnnLam (EpToken "\\") +lepl_lambda k parent = fmap (\new -> parent { epl_lambda = new }) + (k (epl_lambda parent)) + +lepl_case :: Lens EpAnnLam (Maybe EpaLocation) +lepl_case k parent = fmap (\new -> parent { epl_case = new }) + (k (epl_case parent)) + + +-- End of lenses +-- --------------------------------------------------------------------- + +-- markLensKw' :: (Monad m, Monoid w) +-- => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) +-- markLensKw' (EpAnn anc a cs) l kw = do +-- loc <- markKwA kw (view l a) +-- return (EpAnn anc (set l loc a) cs) + +-- markLensKw :: (Monad m, Monoid w) +-- => a -> Lens a EpaLocation -> AnnKeywordId -> EP w m a +-- markLensKw a l kw = do +-- loc <- markKwA kw (view l a) +-- return (set l loc a) + + +-- markLensKwM :: (Monad m, Monoid w) +-- => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a) +-- markLensKwM (EpAnn anc a cs) l kw = do +-- new <- go (view l a) +-- return (EpAnn anc (set l new a) cs) +-- where +-- go Nothing = return Nothing +-- go (Just s) = Just <$> markKwA kw s + +-- markLensKwM' :: (Monad m, Monoid w) +-- => a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m a +-- markLensKwM' a l kw = do +-- loc <- mapM (markKwA kw) (view l a) +-- return (set l loc a) + +markLensTok :: (Monad m, Monoid w, KnownSymbol sym) + => EpAnn a -> Lens a (EpToken sym) -> EP w m (EpAnn a) +markLensTok (EpAnn anc a cs) l = do + new <- markEpToken (view l a) + return (EpAnn anc (set l new a) cs) + +-- --------------------------------------------------------------------- + +markLensFun' :: (Monad m, Monoid w) + => EpAnn ann -> Lens ann t -> (t -> EP w m t) -> EP w m (EpAnn ann) +markLensFun' epann l f = markLensFun epann (lepa . l) f + +markLensFun :: (Monad m, Monoid w) + => ann -> Lens ann t -> (t -> EP w m t) -> EP w m ann +markLensFun a l f = do + t' <- f (view l a) + return (set l t' a) + +-- ------------------------------------- + +markEpAnnAllLT :: (Monad m, Monoid w, KnownSymbol tok) + => EpAnn ann -> Lens ann [EpToken tok] -> EP w m (EpAnn ann) +markEpAnnAllLT (EpAnn anc a cs) l = do + anns <- mapM markEpToken (view l a) + return (EpAnn anc (set l anns a) cs) + +markEpAnnAllLT' :: (Monad m, Monoid w, KnownSymbol tok) + => ann -> Lens ann [EpToken tok] -> EP w m ann +markEpAnnAllLT' a l = do + anns <- mapM markEpToken (view l a) + return (set l anns a) + +markEpaLocationAll :: (Monad m, Monoid w) + => [EpaLocation] -> String -> EP w m [EpaLocation] +markEpaLocationAll locs str = mapM (\l -> printStringAtAA l str) locs + +-- | Print a keyword encoded in a 'TrailingAnn' +markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn +markKwT (AddSemiAnn tok) = AddSemiAnn <$> markEpToken tok +markKwT (AddCommaAnn tok) = AddCommaAnn <$> markEpToken tok +markKwT (AddVbarAnn tok) = AddVbarAnn <$> markEpToken tok +markKwT (AddDarrowAnn tok) = AddDarrowAnn <$> markEpUniToken tok + +-- --------------------------------------------------------------------- + +markAnnList :: (Monad m, Monoid w) + => EpAnn (AnnList l) -> EP w m a -> EP w m (EpAnn (AnnList l), a) +markAnnList ann action = do + markAnnListA ann $ \a -> do + r <- action + return (a,r) + +markAnnList' :: (Monad m, Monoid w) + => AnnList l -> EP w m a -> EP w m (AnnList l, a) +markAnnList' ann action = do + markAnnListA' ann $ \a -> do + r <- action + return (a,r) + +markAnnListA :: (Monad m, Monoid w) + => EpAnn (AnnList l) + -> (EpAnn (AnnList l) -> EP w m (EpAnn (AnnList l), a)) + -> EP w m (EpAnn (AnnList l), a) +markAnnListA an action = do + an0 <- markLensBracketsO an lal_brackets + an1 <- markEpAnnAllLT an0 lal_semis + (an2, r) <- action an1 + an3 <- markLensBracketsC an2 lal_brackets + return (an3, r) + +markAnnListA' :: (Monad m, Monoid w) + => AnnList l + -> (AnnList l -> EP w m (AnnList l, a)) + -> EP w m (AnnList l , a) +markAnnListA' an action = do + an0 <- markLensBracketsO' an lal_brackets + an1 <- markEpAnnAllLT' an0 lal_semis + (an2, r) <- action an1 + an3 <- markLensBracketsC' an2 lal_brackets + return (an3, r) + +-- --------------------------------------------------------------------- + +printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +printCommentsBefore ss = do + cs <- commentAllocationBefore ss + debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) + mapM_ printOneComment cs + +printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +printCommentsIn ss = do + cs <- commentAllocationIn ss + debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) + mapM_ printOneComment cs + debugM $ "printCommentsIn:done" + +-- --------------------------------------------------------------------- + +printOneComment :: (Monad m, Monoid w) => Comment -> EP w m () +printOneComment c@(Comment _str loc _r _mo) = do + debugM $ "printOneComment:c=" ++ showGhc c + dp <-case loc of + EpaDelta _ dp _ -> return dp + EpaSpan (RealSrcSpan r _) -> do + pe <- getPriorEndD + debugM $ "printOneComment:pe=" ++ showGhc pe + let dp = ss2delta pe r + debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc) + adjustDeltaForOffsetM dp + EpaSpan (UnhelpfulSpan _) -> return (SameLine 0) + mep <- getExtraDP + dp' <- case mep of + Just (EpaDelta _ edp _) -> do + debugM $ "printOneComment:edp=" ++ show edp + adjustDeltaForOffsetM edp + _ -> return dp + -- Start of debug printing + LayoutStartCol dOff <- getLayoutOffsetD + debugM $ "printOneComment:(dp,dp',dOff,loc)=" ++ showGhc (dp,dp',dOff,loc) + -- End of debug printing + updateAndApplyComment c dp' + printQueuedComment c dp' + +updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +updateAndApplyComment (Comment str anc pp mo) dp = do + applyComment (Comment str anc' pp mo) + where + (r,c) = ss2posEnd pp + dp'' = case anc of + EpaDelta _ dp1 _ -> dp1 + EpaSpan (RealSrcSpan la _) -> + if r == 0 + then (ss2delta (r,c+0) la) + else (ss2delta (r,c) la) + EpaSpan (UnhelpfulSpan _) -> SameLine 0 + dp' = case anc of + EpaSpan (RealSrcSpan r1 _) -> + if pp == r1 + then dp + else dp'' + _ -> dp'' + ss = case anc of + EpaSpan ss' -> ss' + _ -> noSrcSpan + op' = case dp' of + SameLine n -> if n >= 0 + then EpaDelta ss dp' NoComments + else EpaDelta ss dp NoComments + _ -> EpaDelta ss dp' NoComments + anc' = if str == "" && op' == EpaDelta ss (SameLine 0) NoComments -- EOF comment + then EpaDelta ss dp NoComments + else EpaDelta ss dp NoComments + +-- --------------------------------------------------------------------- + +commentAllocationBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] +commentAllocationBefore 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 _r _mo) -> + case loc of + EpaSpan (RealSrcSpan r _) -> (ss2pos r) <= (ss2pos ss) + _ -> True -- Choose one + ) cs + putUnallocatedComments later + -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) + return earlier + +commentAllocationIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] +commentAllocationIn 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 _r _mo) -> + case loc of + EpaSpan (RealSrcSpan r _) -> (ss2posEnd r) <= (ss2posEnd ss) + _ -> True -- Choose one + ) cs + putUnallocatedComments later + -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) + return earlier +-- --------------------------------------------------------------------- + +markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast +markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a + +-- --------------------------------------------------------------------- + +markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast] +markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls + +-- --------------------------------------------------------------------- +-- End of utility functions +-- --------------------------------------------------------------------- +-- Start of ExactPrint instances +-- --------------------------------------------------------------------- + +-- | Bare Located elements are simply stripped off without further +-- processing. +instance (ExactPrint a) => ExactPrint (Located a) where + getAnnotationEntry (L l _) = case l of + UnhelpfulSpan _ -> NoEntryVal + _ -> Entry (EpaSpan l) [] emptyComments NoFlushComments CanUpdateAnchorOnly + + setAnnotationAnchor (L l a) _anc _ts _cs = L l a + + exact (L l a) = L l <$> markAnnotated a + +instance (ExactPrint a) => ExactPrint (LocatedE a) where + getAnnotationEntry (L l _) = Entry l [] emptyComments NoFlushComments CanUpdateAnchorOnly + setAnnotationAnchor (L _ a) anc _ts _cs = L anc a + + exact (L la a) = do + debugM $ "LocatedE a:la loc=" ++ show (ss2range $ locA la) + a' <- markAnnotated a + return (L la a') + +instance (ExactPrint a) => ExactPrint (LocatedA a) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs + exact (L la a) = do + debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) + a' <- markAnnotated a + return (L la a') + +instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs + exact (L la a) = do + a' <- markAnnotated a + return (L la a') + +instance (ExactPrint a) => ExactPrint [a] where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ls _ _ _ = ls + exact ls = mapM markAnnotated ls + +instance (ExactPrint a) => ExactPrint (Maybe a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ma _ _ _ = ma + exact ma = mapM markAnnotated ma + +-- --------------------------------------------------------------------- + +-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' +instance ExactPrint (HsModule GhcPs) where + getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod) + -- A bit pointless actually changing anything here + setAnnotationAnchor hsmod anc _ts cs = setAnchorHsModule hsmod anc cs + `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs)) + + exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do + + let mbDoc' = mbDoc + + (an0, mmn' , mdeprec', mexports') <- + case mmn of + Nothing -> return (an, mmn, mdeprec, mexports) + Just m -> do + an0 <- markLensTok an lam_mod + m' <- markAnnotated m + + mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec + + mexports' <- setLayoutTopLevelP $ markAnnotated mexports + + an1 <- setLayoutTopLevelP $ markLensTok an0 lam_where + + return (an1, Just m', mdeprec', mexports') + + lo0 <- case lo of + EpExplicitBraces open close -> do + open' <- markEpToken open + return (EpExplicitBraces open' close) + _ -> return lo + + am_decls' <- markTrailing (am_decls $ anns an0) + + mid <- markAnnotated (HsModuleImpDecls (am_cs $ anns an0) imports decls) + let imports' = id_imps mid + let decls' = id_decls mid + + lo1 <- case lo0 of + EpExplicitBraces open close -> do + close' <- markEpToken close + return (EpExplicitBraces open close') + _ -> return lo + + -- Print EOF + case am_eof $ anns an of + Nothing -> return () + Just (pos, prior) -> do + debugM $ "am_eof:" ++ showGhc (pos, prior) + setEofPos (Just (pos, prior)) + + let anf = an0 { anns = (anns an0) { am_decls = am_decls', am_cs = [] }} + debugM $ "HsModule, anf=" ++ showAst anf + + return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls') + +-- --------------------------------------------------------------------- + +-- | This is used to ensure the comments are updated into the right +-- place for makeDeltaAst. +data HsModuleImpDecls + = HsModuleImpDecls { + id_cs :: [LEpaComment], + id_imps :: [LImportDecl GhcPs], + id_decls :: [LHsDecl GhcPs] + } deriving Data + +instance ExactPrint HsModuleImpDecls where + -- Use an UnhelpfulSpan for the anchor, we are only interested in the comments + getAnnotationEntry mid = mkEntry (EpaSpan (UnhelpfulSpan UnhelpfulNoLocationInfo)) [] (EpaComments (id_cs mid)) + setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs } + `debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs) + exact (HsModuleImpDecls cs imports decls) = do + imports' <- markTopLevelList imports + decls' <- markTopLevelList (filter notDocDecl decls) + return (HsModuleImpDecls cs imports' decls') + + +-- --------------------------------------------------------------------- + +instance ExactPrint ModuleName where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor n _anc _ cs = n + `debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs) + exact n = do + debugM $ "ModuleName: " ++ showPprUnsafe n + withPpr n + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP (WarningTxt GhcPs)) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt mb_cat src ws)) = do + o' <- markAnnOpen'' o src "{-# WARNING" + mb_cat' <- markAnnotated mb_cat + os' <- markEpToken os + ws' <- markAnnotated ws + cs' <- markEpToken cs + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt mb_cat' src ws')) + + exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + o' <- markAnnOpen'' o src "{-# DEPRECATED" + os' <- markEpToken os + ws' <- markAnnotated ws + cs' <- markEpToken cs + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) + +instance ExactPrint InWarningCategory where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (InWarningCategory tkIn source (L l wc)) = do + tkIn' <- markEpToken tkIn + L l' (_,wc') <- markAnnotated (L l (source, wc)) + return (InWarningCategory tkIn' source (L l' wc')) + +instance ExactPrint (SourceText, WarningCategory) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (st, WarningCategory wc) = do + case st of + NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\"" + SourceText src -> printStringAdvance $ (unpackFS src) + return (st, WarningCategory wc) + +-- --------------------------------------------------------------------- + +instance ExactPrint (ImportDecl GhcPs) where + getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl) + setAnnotationAnchor idecl anc ts cs = idecl { ideclExt + = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} } + + exact (ImportDecl (XImportDeclPass ann msrc impl) + modname mpkg src safeflag qualFlag mAs hiding) = do + + ann0 <- markLensFun' ann limportDeclAnnImport markEpToken + let (EpAnn _anc an _cs) = ann0 + + -- "{-# SOURCE" and "#-}" + importDeclAnnPragma' <- + case msrc of + SourceText _txt -> do + debugM $ "ImportDecl sourcetext" + case importDeclAnnPragma an of + Just (mo, mc) -> do + mo' <- markAnnOpen'' mo msrc "{-# SOURCE" + mc' <- markEpToken mc + return $ Just (mo', mc') + Nothing -> do + _ <- markAnnOpen' Nothing msrc "{-# SOURCE" + printStringAtLsDelta (SameLine 1) "#-}" + return Nothing + NoSourceText -> return (importDeclAnnPragma an) + ann1 <- if safeflag + then markLensFun' ann0 limportDeclAnnSafe (\mt -> mapM markEpToken mt) + else return ann0 + ann2 <- + case qualFlag of + QualifiedPre -- 'qualified' appears in prepositive position. + -> markLensFun' ann1 limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann1 + ann3 <- + case mpkg of + RawPkgQual (StringLiteral src' v _) -> + printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) + _ -> return ann2 + modname' <- markAnnotated modname + + ann4 <- + case qualFlag of + QualifiedPost -- 'qualified' appears in postpositive position. + -> markLensFun' ann3 limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann3 + + (importDeclAnnAs', mAs') <- + case mAs of + Nothing -> return (importDeclAnnAs an, Nothing) + Just m0 -> do + a <- mapM markEpToken (importDeclAnnAs an) + m'' <- markAnnotated m0 + return (a, Just m'') + + hiding' <- + case hiding of + Nothing -> return hiding + Just (isHiding,lie) -> do + lie' <- markAnnotated lie + return (Just (isHiding, lie')) + + let (EpAnn anc' an' cs') = ann4 + let an2 = an' { importDeclAnnAs = importDeclAnnAs' + , importDeclAnnPragma = importDeclAnnPragma' + } + + return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) + modname' mpkg src safeflag qualFlag mAs' hiding') + + +-- --------------------------------------------------------------------- + +instance ExactPrint HsDocString where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (MultiLineDocString decorator (x :| xs)) = do + printStringAdvance ("-- " ++ printDecorator decorator) + pe <- getPriorEndD + debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x) + x' <- markAnnotated x + xs' <- markAnnotated (map dedentDocChunk xs) + return (MultiLineDocString decorator (x' :| xs')) + exact x = do + -- TODO: can this happen? + debugM $ "Not exact printing:" ++ showAst x + return x + + +instance ExactPrint HsDocStringChunk where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact chunk = do + printStringAdvance ("--" ++ unpackHDSC chunk) + return chunk + + +instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (WithHsDocIdentifiers ds ids) = do + ds' <- exact ds + return (WithHsDocIdentifiers ds' ids) + +-- --------------------------------------------------------------------- + +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 + + -- We do not recurse, the generic traversal using this feature + -- should do that for us. + setAnnotationAnchor d _ _ _ = d + + exact (TyClD x d) = TyClD x <$> markAnnotated d + exact (InstD x d) = InstD x <$> markAnnotated d + exact (DerivD x d) = DerivD x <$> markAnnotated d + exact (ValD x d) = ValD x <$> markAnnotated d + exact (SigD x d) = SigD x <$> markAnnotated d + exact (KindSigD x d) = KindSigD x <$> markAnnotated d + exact (DefD x d) = DefD x <$> markAnnotated d + exact (ForD x d) = ForD x <$> markAnnotated d + exact (WarningD x d) = WarningD x <$> markAnnotated d + exact (AnnD x d) = AnnD x <$> markAnnotated d + exact (RuleD x d) = RuleD x <$> markAnnotated d + exact (SpliceD x d) = SpliceD x <$> markAnnotated d + exact (DocD x d) = DocD x <$> markAnnotated d + exact (RoleAnnotD x d) = RoleAnnotD x <$> markAnnotated d + +-- --------------------------------------------------------------------- + +instance ExactPrint (InstDecl GhcPs) where + getAnnotationEntry (ClsInstD _ _) = NoEntryVal + getAnnotationEntry (DataFamInstD _ _) = NoEntryVal + getAnnotationEntry (TyFamInstD _ _) = NoEntryVal + + setAnnotationAnchor d _ _ _ = d + + + exact (ClsInstD a cid) = do + cid' <- markAnnotated cid + return (ClsInstD a cid') + exact (DataFamInstD a decl) = do + decl' <- markAnnotated decl + return (DataFamInstD a decl') + exact (TyFamInstD a eqn) = do + eqn' <- markAnnotated eqn + return (TyFamInstD a eqn') + +-- --------------------------------------------------------------------- + +instance ExactPrint (DataFamInstDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact d = do + d' <- exactDataFamInstDecl d + return d' + +-- --------------------------------------------------------------------- + +exactDataFamInstDecl :: (Monad m, Monoid w) + => DataFamInstDecl GhcPs + -> EP w m (DataFamInstDecl GhcPs) +exactDataFamInstDecl + (DataFamInstDecl (FamEqn { feqn_ext = (ops, cps, eq) + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn })) = do + ((ops', cps'), tycon', bndrs', pats', defn') <- exactDataDefn pp_hdr defn + return + (DataFamInstDecl ( FamEqn { feqn_ext = (ops', cps', eq) + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = defn' })) + `debug` ("exactDataFamInstDecl: defn' derivs:" ++ showAst (dd_derivs defn')) + where + pp_hdr :: (Monad m, Monoid w) + => Maybe (LHsContext GhcPs) + -> EP w m ( ([EpToken "("], [EpToken ")"] ) + , LocatedN RdrName + , HsOuterTyVarBndrs () GhcPs + , HsFamEqnPats GhcPs + , Maybe (LHsContext GhcPs)) + pp_hdr mctxt = exactHsFamInstLHS ops cps tycon bndrs pats fixity mctxt + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DerivDecl (mw, (td,ti)) typ ms mov) = do + td' <- markEpToken td + ms' <- mapM markAnnotated ms + ti' <- markEpToken ti + mw' <- mapM markAnnotated mw + mov' <- mapM markAnnotated mov + typ' <- markAnnotated typ + return (DerivDecl (mw', (td',ti')) typ' ms' mov') + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (ForeignImport (tf,ti,td) n ty fimport) = do + tf' <- markEpToken tf + ti' <- markEpToken ti + + fimport' <- markAnnotated fimport + + n' <- markAnnotated n + td' <- markEpUniToken td + ty' <- markAnnotated ty + return (ForeignImport (tf',ti',td') n' ty' fimport') + + exact (ForeignExport (tf,te,td) n ty fexport) = do + tf' <- markEpToken tf + te' <- markEpToken te + fexport' <- markAnnotated fexport + n' <- markAnnotated n + td' <- markEpUniToken td + ty' <- markAnnotated ty + return (ForeignExport (tf',te',td') n' ty' fexport') + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignImport GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do + cconv' <- markAnnotated cconv + safety' <- if notDodgyE l + then markAnnotated safety + else return safety + ls' <- if notDodgyE ls + then markExternalSourceTextE ls src "" + else return ls + return (CImport (L ls' src) cconv' safety' mh imp) + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignExport GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (CExport (L ls src) spec) = do + debugM $ "CExport starting" + spec' <- markAnnotated spec + ls' <- if notDodgyE ls + then markExternalSourceTextE ls src "" + else return ls + return (CExport (L ls' src) spec') + +-- --------------------------------------------------------------------- + +instance ExactPrint CExportSpec where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (CExportStatic st lbl cconv) = do + debugM $ "CExportStatic starting" + cconv' <- markAnnotated cconv + return (CExportStatic st lbl cconv') + +-- --------------------------------------------------------------------- + +instance ExactPrint Safety where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint CCallConv where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecls GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Warnings ((o,c),src) warns) = do + o' <- markAnnOpen'' o src "{-# WARNING" -- Note: might be {-# DEPRECATED + warns' <- markAnnotated warns + c' <- markEpToken c + return (Warnings ((o',c'),src) warns') + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Warning (ns_spec, (o,c)) lns (WarningTxt mb_cat src ls )) = do + mb_cat' <- markAnnotated mb_cat + ns_spec' <- exactNsSpec ns_spec + lns' <- markAnnotated lns + o' <- markEpToken o + ls' <- markAnnotated ls + c' <- markEpToken c + return (Warning (ns_spec', (o',c')) lns' (WarningTxt mb_cat' src ls')) + + exact (Warning (ns_spec, (o,c)) lns (DeprecatedTxt src ls)) = do + ns_spec' <- exactNsSpec ns_spec + lns' <- markAnnotated lns + o' <- markEpToken o + ls' <- markAnnotated ls + c' <- markEpToken c + return (Warning (ns_spec', (o',c')) lns' (DeprecatedTxt src ls')) + +exactNsSpec :: (Monad m, Monoid w) => NamespaceSpecifier -> EP w m NamespaceSpecifier +exactNsSpec NoNamespaceSpecifier = pure NoNamespaceSpecifier +exactNsSpec (TypeNamespaceSpecifier type_) = do + type_' <- markEpToken type_ + pure (TypeNamespaceSpecifier type_') +exactNsSpec (DataNamespaceSpecifier data_) = do + data_' <- markEpToken data_ + pure (DataNamespaceSpecifier data_') + +-- --------------------------------------------------------------------- + +instance ExactPrint StringLiteral where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (StringLiteral src fs mcomma) = do + printSourceTextAA src (show (unpackFS fs)) + mcomma' <- mapM (\r -> printStringAtNC r ",") mcomma + return (StringLiteral src fs mcomma') + +-- --------------------------------------------------------------------- + +instance ExactPrint FastString where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. + -- exact fs = printStringAdvance (show (unpackFS fs)) + exact fs = printStringAdvance (unpackFS fs) >> return fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecls GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsRules ((o,c), src) rules) = do + o' <- + case src of + NoSourceText -> printStringAtAA o "{-# RULES" + SourceText srcTxt -> printStringAtAA o (unpackFS srcTxt) + rules' <- markAnnotated rules + c' <- markEpToken c + return (HsRules ((o',c'),src) rules') + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do + (L ln' _) <- markAnnotated (L ln (nsrc, n)) + an0 <- markActivationL an lra_rest act + (an1, mtybndrs') <- + case mtybndrs of + Nothing -> return (an0, Nothing) + Just bndrs -> do + an1 <- markLensFun an0 lra_tyanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall + bndrs' <- mapM markAnnotated bndrs + an2 <- markLensFun an1 lra_tyanns_snd (\mt -> mapM markEpToken mt) -- AnnDot + return (an2, Just bndrs') + + an2 <- markLensFun an1 lra_tmanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall + termbndrs' <- mapM markAnnotated termbndrs + an3 <- markLensFun an2 lra_tmanns_snd (\mt -> mapM markEpToken mt) -- AnnDot + + lhs' <- markAnnotated lhs + an4 <- markLensFun an3 lra_equal markEpToken + rhs' <- markAnnotated rhs + return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') + + +markActivationL :: (Monad m, Monoid w) + => a -> Lens a ActivationAnn -> Activation -> EP w m a +markActivationL a l act = do + new <- markActivation (view l a) act + return (set l new a) + +markActivation :: (Monad m, Monoid w) + => ActivationAnn -> Activation -> EP w m ActivationAnn +markActivation (ActivationAnn o c t v) act = do + case act of + ActiveBefore src phase -> do + o' <- markEpToken o -- '[' + t' <- mapM markEpToken t -- ~ + v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v + c' <- markEpToken c -- ']' + return (ActivationAnn o' c' t' v') + ActiveAfter src phase -> do + o' <- markEpToken o -- '[' + v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v + c' <- markEpToken c -- ']' + return (ActivationAnn o' c' t v') + NeverActive -> do + o' <- markEpToken o -- '[' + t' <- mapM markEpToken t -- ~ + c' <- markEpToken c -- ']' + return (ActivationAnn o' c' t' v) + _ -> return (ActivationAnn o c t v) + +-- --------------------------------------------------------------------- + +instance ExactPrint (SpliceDecl GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (SpliceDecl x splice flag) = do + splice' <- markAnnotated splice + return (SpliceDecl x splice' flag) + +-- --------------------------------------------------------------------- + +instance ExactPrint (DocDecl GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + -- We print these as plain comments instead, do a NOP here. + exact v = return v + +-- --------------------------------------------------------------------- + +instance ExactPrint (RoleAnnotDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (RoleAnnotDecl (tt,tr) ltycon roles) = do + tt' <- markEpToken tt + tr' <- markEpToken tr + ltycon' <- markAnnotated ltycon + let markRole (L l (Just r)) = do + (L l' r') <- markAnnotated (L l r) + return (L l' (Just r')) + markRole (L l Nothing) = do + e' <- printStringAtAA (entry l) "_" + return (L (l { entry = e'}) Nothing) + roles' <- mapM markRole roles + return (RoleAnnotDecl (tt',tr') ltycon' roles') + +-- --------------------------------------------------------------------- + +instance ExactPrint Role where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleBndr GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (RuleBndr x ln) = do + ln' <- markAnnotated ln + return (RuleBndr x ln') + exact (RuleBndrSig (AnnTyVarBndr os cs ap dc) ln (HsPS x ty)) = do + os' <- markEpaLocationAll os "(" + ln' <- markAnnotated ln + dc' <- markEpUniToken dc + ty' <- markAnnotated ty + cs' <- markEpaLocationAll cs ")" + return (RuleBndrSig (AnnTyVarBndr os' cs' ap dc') ln' (HsPS x ty')) + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor fe _ _ _s = fe + exact (FamEqn { feqn_ext = (ops, cps, eq) + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }) = do + ((ops', cps'), tycon', bndrs', pats',_) <- exactHsFamInstLHS ops cps tycon bndrs pats fixity Nothing + eq' <- markEpToken eq + rhs' <- markAnnotated rhs + return (FamEqn { feqn_ext = (ops', cps', eq') + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) + +-- --------------------------------------------------------------------- + +exactHsFamInstLHS :: + (Monad m, Monoid w) + => [EpToken "("] + -> [EpToken ")"] + -> LocatedN RdrName + -> HsOuterTyVarBndrs () GhcPs + -> HsFamEqnPats GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EP w m ( ([EpToken "("], [EpToken ")"]) + , LocatedN RdrName + , HsOuterTyVarBndrs () GhcPs + , HsFamEqnPats GhcPs, Maybe (LHsContext GhcPs)) +exactHsFamInstLHS ops cps thing bndrs typats fixity mb_ctxt = do + -- TODO:AZ: do these ans exist? They are in the binders now + -- an0 <- markEpAnnL an lidl AnnForall + bndrs' <- markAnnotated bndrs + -- an1 <- markEpAnnL an0 lidl AnnDot + mb_ctxt' <- mapM markAnnotated mb_ctxt + (ops', cps', thing', typats') <- exact_pats ops cps typats + return ((ops', cps'), thing', bndrs', typats', mb_ctxt') + where + exact_pats :: (Monad m, Monoid w) + => [EpToken "("] -> [EpToken ")"] -> HsFamEqnPats GhcPs + -> EP w m ([EpToken "("], [EpToken ")"], LocatedN RdrName, HsFamEqnPats GhcPs) + exact_pats ops1 cps1 (patl:patr:pats) + | Infix <- fixity + = let exact_op_app = do + ops' <- mapM markEpToken ops1 + patl' <- markAnnotated patl + thing' <- markAnnotated thing + patr' <- markAnnotated patr + cps' <- mapM markEpToken cps1 + return (ops', cps', thing', [patl',patr']) + in case pats of + [] -> exact_op_app + _ -> do + (ops', cps', thing', p) <- exact_op_app + pats' <- mapM markAnnotated pats + return (ops', cps', thing', p++pats') + + exact_pats ops0 cps0 pats = do + ops' <- mapM markEpToken ops0 + thing' <- markAnnotated thing + pats' <- markAnnotated pats + cps' <- mapM markEpToken cps0 + return (ops', cps', thing', pats') + +-- --------------------------------------------------------------------- + +instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) + => ExactPrint (HsArg GhcPs tm ty) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsValArg x tm) = do + tm' <- markAnnotated tm + return (HsValArg x tm') + exact (HsTypeArg at ty) = do + at' <- markEpToken at + ty' <- markAnnotated ty + return (HsTypeArg at' ty') + exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source + +-- --------------------------------------------------------------------- + +instance ExactPrint (ClsInstDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (ClsInstDecl { cid_ext = (mbWarn, AnnClsInstDecl i w oc semis cc, sortKey) + , cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + = do + (mbWarn', i', w', mbOverlap', inst_ty') <- top_matter + oc' <- markEpToken oc + semis' <- mapM markEpToken semis + (sortKey', ds) <- withSortKey sortKey + [(ClsAtTag, prepareListAnnotationA ats), + (ClsAtdTag, prepareListAnnotationF adts), + (ClsMethodTag, prepareListAnnotationA binds), + (ClsSigTag, prepareListAnnotationA sigs) + ] + cc' <- markEpToken cc + let + ats' = undynamic ds + adts' = undynamic ds + binds' = undynamic ds + sigs' = undynamic ds + return (ClsInstDecl { cid_ext = (mbWarn', AnnClsInstDecl i' w' oc' semis' cc', sortKey') + , cid_poly_ty = inst_ty', cid_binds = binds' + , cid_sigs = sigs', cid_tyfam_insts = ats' + , cid_overlap_mode = mbOverlap' + , cid_datafam_insts = adts' }) + + where + top_matter = do + i' <- markEpToken i + mw <- mapM markAnnotated mbWarn + mo <- mapM markAnnotated mbOverlap + it <- markAnnotated inst_ty + w' <- markEpToken w -- Optional + return (mw, i', w', mo,it) + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyFamInstDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact d@(TyFamInstDecl { tfid_xtn = (tt,ti), tfid_eqn = eqn }) = do + tt' <- markEpToken tt + ti' <- markEpToken ti + eqn' <- markAnnotated eqn + return (d { tfid_xtn = (tt',ti'), tfid_eqn = eqn' }) + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP OverlapMode) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + -- NOTE: NoOverlap is only used in the typechecker + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do + o' <- markAnnOpen'' o src "{-# NO_OVERLAP" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do + o' <- markAnnOpen'' o src "{-# OVERLAPPABLE" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do + o' <- markAnnOpen'' o src "{-# OVERLAPPING" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do + o' <- markAnnOpen'' o src "{-# OVERLAPS" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do + o' <- markAnnOpen'' o src "{-# INCOHERENT" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do + o' <- markAnnOpen'' o src "{-# INCOHERENT" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsBind GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (FunBind x fid matches) = do + matches' <- markAnnotated matches + let + fun_id' = case unLoc (mg_alts matches') of + [] -> fid + (L _ m:_) -> case m_ctxt m of + FunRhs f _ _ _ -> f + _ -> fid + return (FunBind x fun_id' matches') + + exact (PatBind x pat q grhss) = do + q' <- markAnnotated q + pat' <- markAnnotated pat + grhss' <- markAnnotated grhss + return (PatBind x pat' q' grhss') + exact (PatSynBind x bind) = do + bind' <- markAnnotated bind + return (PatSynBind x bind') + + exact x = error $ "HsBind: exact for " ++ showAst x + +instance ExactPrint (HsMultAnn GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsNoMultAnn x) = return (HsNoMultAnn x) + exact (HsPct1Ann tok) = do + tok' <- markEpToken tok + return (HsPct1Ann tok') + exact (HsMultAnn tok ty) = do + tok' <- markEpToken tok + ty' <- markAnnotated ty + return (HsMultAnn tok' ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (PatSynBind GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (PSB{ psb_ext = AnnPSB ap ao ac al ae + , psb_id = psyn, psb_args = details + , psb_def = pat + , psb_dir = dir }) = do + ap' <- markEpToken ap + (ao', ac', psyn', details') <- + case details of + InfixCon v1 v2 -> do + v1' <- markAnnotated v1 + psyn' <- markAnnotated psyn + v2' <- markAnnotated v2 + return (ao, ac, psyn',InfixCon v1' v2') + PrefixCon tvs vs -> do + psyn' <- markAnnotated psyn + tvs' <- markAnnotated tvs + vs' <- markAnnotated vs + return (ao, ac, psyn', PrefixCon tvs' vs') + RecCon vs -> do + psyn' <- markAnnotated psyn + ao' <- mapM markEpToken ao + vs' <- markAnnotated vs + ac' <- mapM markEpToken ac + return (ao', ac', psyn', RecCon vs') + + (al', ae', pat', dir') <- + case dir of + Unidirectional -> do + al' <- mapM markEpUniToken al + pat' <- markAnnotated pat + return (al', ae, pat', dir) + ImplicitBidirectional -> do + ae' <- mapM markEpToken ae + pat' <- markAnnotated pat + return (al, ae', pat', dir) + ExplicitBidirectional mg -> do + al' <- mapM markEpUniToken al + pat' <- markAnnotated pat + mg' <- markAnnotated mg + return (al', ae, pat', ExplicitBidirectional mg') + + return (PSB{ psb_ext = AnnPSB ap' ao' ac' al' ae' + , psb_id = psyn', psb_args = details' + , psb_def = pat' + , psb_dir = dir' }) + + +-- --------------------------------------------------------------------- + +instance ExactPrint (RecordPatSynField GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (RecordPatSynField f v) = do + f' <- markAnnotated f + return (RecordPatSynField f' v) + +-- --------------------------------------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Match an mctxt pats grhss) = + exactMatch (Match an mctxt pats grhss) + +-- ------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Match an mctxt pats grhss) = + exactMatch (Match an mctxt pats grhss) + +-- --------------------------------------------------------------------- + +exactMatch :: (Monad m, Monoid w, ExactPrint (GRHSs GhcPs body)) + => (Match GhcPs body) -> EP w m (Match GhcPs body) +exactMatch (Match an mctxt pats grhss) = do + + debugM $ "exact Match entered" + + (mctxt', pats') <- + case mctxt of + FunRhs fun fixity strictness (AnnFunRhs strict opens closes) -> do + debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun + strict' <- markEpToken strict + case fixity of + Prefix -> do + epTokensToComments "(" opens + epTokensToComments ")" closes + fun' <- markAnnotated fun + pats' <- markAnnotated pats + return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats') + Infix -> + case pats of + L l (p1:p2:rest) + | null rest -> do + p1' <- markAnnotated p1 + fun' <- markAnnotated fun + p2' <- markAnnotated p2 + return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), L l [p1',p2']) + | otherwise -> do + opens' <- markEpToken1 opens + p1' <- markAnnotated p1 + fun' <- markAnnotated fun + p2' <- markAnnotated p2 + closes' <- markEpToken1 closes + rest' <- mapM markAnnotated rest + return (FunRhs fun' fixity strictness (AnnFunRhs strict' opens' closes'), L l (p1':p2':rest')) + _ -> panic "FunRhs" + + LamAlt v -> do + pats' <- markAnnotated pats + return (LamAlt v, pats') + + CaseAlt -> do + pats' <- markAnnotated pats + return (CaseAlt, pats') + + _ -> do + mctxt' <- withPpr mctxt + return (mctxt', pats) + + grhss' <- markAnnotated grhss + + return (Match an mctxt' pats' grhss') + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (GRHSs cs grhss binds) = do + addCommentsA $ priorComments cs + addCommentsA $ getFollowingComments cs + grhss' <- markAnnotated grhss + binds' <- markAnnotated binds + -- The comments will be added back as they are printed + return (GRHSs emptyComments grhss' binds') + + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (GRHSs cs grhss binds) = do + addCommentsA $ priorComments cs + addCommentsA $ getFollowingComments cs + grhss' <- markAnnotated grhss + binds' <- markAnnotated binds + -- The comments will be added back as they are printed + return (GRHSs emptyComments grhss' binds') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsLocalBinds GhcPs) where + getAnnotationEntry (HsValBinds an _) = fromAnn an + getAnnotationEntry (HsIPBinds{}) = NoEntryVal + getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal + + setAnnotationAnchor (HsValBinds an a) anc ts cs = HsValBinds (setAnchorEpaL an anc ts cs) a + setAnnotationAnchor a _ _ _ = a + + exact (HsValBinds an valbinds) = do + an0 <- markLensFun' an lal_rest markEpToken -- 'where' + + case al_anchor $ anns an of + Just anc -> do + when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) + _ -> return () + + (an1, valbinds') <- markAnnList an0 $ markAnnotatedWithLayout valbinds + debugM $ "exact HsValBinds: an1=" ++ showAst an1 + medr <- getExtraDPReturn + an2 <- case medr of + Nothing -> return an1 + Just (ss,dp) -> do + setExtraDPReturn Nothing + return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta ss dp []) }} + return (HsValBinds an2 valbinds') + + exact (HsIPBinds an bs) = do + (an2,bs') <- markAnnListA an $ \an0 -> do + an1 <- markLensFun' an0 lal_rest markEpToken + bs' <- markAnnotated bs + return (an1, bs') + return (HsIPBinds an2 bs') + exact b@(EmptyLocalBinds _) = return b + + +-- --------------------------------------------------------------------- +instance ExactPrint (HsValBindsLR GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (ValBinds sortKey binds sigs) = do + decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs) + let + binds' = concatMap decl2Bind decls + sigs' = concatMap decl2Sig decls + sortKey' = captureOrderBinds decls + return (ValBinds sortKey' binds' sigs') + exact (XValBindsLR _) = panic "XValBindsLR" + +undynamic :: Typeable a => [Dynamic] -> [a] +undynamic ds = mapMaybe fromDynamic ds + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsIPBinds GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IPBinds x binds) = setLayoutBoth $ do + binds' <- markAnnotated binds + return (IPBinds x binds') + +-- --------------------------------------------------------------------- + +instance ExactPrint (IPBind GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IPBind an lr rhs) = do + lr' <- markAnnotated lr + an0 <- markEpToken an + rhs' <- markAnnotated rhs + return (IPBind an0 lr' rhs') + + +-- --------------------------------------------------------------------- + +instance ExactPrint HsIPName where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact i@(HsIPName fs) = printStringAdvanceA ("?" ++ (unpackFS fs)) >> return i + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotationF :: (Monad m, Monoid w) => + [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)] +prepareListAnnotationF ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls + where + go (L l a) = do + (L l' d') <- markAnnotated (L l a) + return (toDyn (L l' d')) + +prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)] +prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls + where + go b = do + b' <- markAnnotated b + return (toDyn b') + +withSortKey :: (Monad m, Monoid w) + => AnnSortKey DeclTag -> [(DeclTag, [(RealSrcSpan, EP w m Dynamic)])] + -> EP w m (AnnSortKey DeclTag, [Dynamic]) +withSortKey annSortKey xs = do + debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey + let (sk, ordered) = case annSortKey of + NoAnnSortKey -> (annSortKey', map snd os) + where + doOne (tag, ds) = map (\d -> (tag, d)) ds + xsExpanded = concatMap doOne xs + os = sortBy orderByFst $ xsExpanded + annSortKey' = AnnSortKey (map fst os) + AnnSortKey _keys -> (annSortKey, orderedDecls annSortKey (Map.fromList xs)) + ordered' <- mapM snd ordered + return (sk, ordered') + +orderByFst :: Ord a => (t, (a,b1)) -> (t, (a, b2)) -> Ordering +orderByFst (_,(a,_)) (_,(b,_)) = compare a b + +-- --------------------------------------------------------------------- + +instance ExactPrint (Sig GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (TypeSig (AnnSig dc mp md) vars ty) = do + (dc', vars', ty') <- exactVarSig dc vars ty + return (TypeSig (AnnSig dc' mp md) vars' ty') + + exact (PatSynSig (AnnSig dc mp md) lns typ) = do + mp' <- mapM markEpToken mp + lns' <- markAnnotated lns + dc' <- markEpUniToken dc + typ' <- markAnnotated typ + return (PatSynSig (AnnSig dc' mp' md) lns' typ') + + exact (ClassOpSig (AnnSig dc mp md) is_deflt vars ty) + | is_deflt = do + md' <- mapM markEpToken md + (dc', vars',ty') <- exactVarSig dc vars ty + return (ClassOpSig (AnnSig dc' mp md') is_deflt vars' ty') + | otherwise = do + (dc', vars',ty') <- exactVarSig dc vars ty + return (ClassOpSig (AnnSig dc' mp md) is_deflt vars' ty') + + exact (FixSig ((af, ma),src) (FixitySig ns names (Fixity v fdir))) = do + let fixstr = case fdir of + InfixL -> "infixl" + InfixR -> "infixr" + InfixN -> "infix" + af' <- printStringAtAA af fixstr + ma' <- mapM (\l -> printStringAtAA l (sourceTextToString src (show v))) ma + ns' <- markAnnotated ns + names' <- markAnnotated names + return (FixSig ((af',ma'),src) (FixitySig ns' names' (Fixity v fdir))) + + exact (InlineSig (o,c,act) ln inl) = do + o' <- markAnnOpen'' o (inl_src inl) "{-# INLINE" + act' <- markActivation act (inl_act inl) + ln' <- markAnnotated ln + c' <- markEpToken c + return (InlineSig (o', c', act') ln' inl) + + exact (SpecSig (AnnSpecSig o c dc act) ln typs inl) = do + o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + act' <- markActivation act (inl_act inl) + ln' <- markAnnotated ln + dc' <- markEpUniToken dc + typs' <- markAnnotated typs + c' <- markEpToken c + return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl) + + exact (SpecInstSig ((o,i,c),src) typ) = do + o' <- markAnnOpen'' o src "{-# SPECIALISE" + i' <- markEpToken i + typ' <- markAnnotated typ + c' <- markEpToken c + return (SpecInstSig ((o',i',c'),src) typ') + + exact (MinimalSig ((o,c),src) formula) = do + o' <- markAnnOpen'' o src "{-# MINIMAL" + formula' <- markAnnotated formula + c' <- markEpToken c + return (MinimalSig ((o',c'),src) formula') + + exact (SCCFunSig ((o,c),src) ln ml) = do + o' <- markAnnOpen'' o src "{-# SCC" + ln' <- markAnnotated ln + ml' <- markAnnotated ml + c' <- markEpToken c + return (SCCFunSig ((o',c'),src) ln' ml') + + exact (CompleteMatchSig ((o,md,c),src) cs mty) = do + o' <- markAnnOpen'' o src "{-# COMPLETE" + cs' <- mapM markAnnotated cs + (md', mty') <- + case mty of + Nothing -> return (md, mty) + Just ty -> do + md' <- mapM markEpUniToken md + ty' <- markAnnotated ty + return (md', Just ty') + c' <- markEpToken c + return (CompleteMatchSig ((o',md',c'),src) cs' mty') + +-- --------------------------------------------------------------------- + +instance ExactPrint NamespaceSpecifier where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact NoNamespaceSpecifier = return NoNamespaceSpecifier + exact (TypeNamespaceSpecifier typeTok) = do + typeTok' <- markEpToken typeTok + return (TypeNamespaceSpecifier typeTok') + exact (DataNamespaceSpecifier dataTok) = do + dataTok' <- markEpToken dataTok + return (DataNamespaceSpecifier dataTok') + +-- --------------------------------------------------------------------- + +exactVarSig :: (Monad m, Monoid w, ExactPrint a) + => TokDcolon -> [LocatedN RdrName] -> a -> EP w m (TokDcolon, [LocatedN RdrName], a) +exactVarSig dc vars ty = do + vars' <- mapM markAnnotated vars + dc' <- markEpUniToken dc + ty' <- markAnnotated ty + return (dc', vars', ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (StandaloneKindSig GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (StandaloneKindSig (tt,td) vars sig) = do + tt' <- markEpToken tt + vars' <- markAnnotated vars + td' <- markEpUniToken td + sig' <- markAnnotated sig + return (StandaloneKindSig (tt',td') vars' sig') + +-- --------------------------------------------------------------------- + +instance ExactPrint (DefaultDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DefaultDecl (d,op,cp) cl tys) = do + d' <- markEpToken d + op' <- markEpToken op + cl' <- markAnnotated cl + tys' <- markAnnotated tys + cp' <- markEpToken cp + return (DefaultDecl (d',op',cp') cl' tys') + +-- --------------------------------------------------------------------- + +instance ExactPrint (AnnDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsAnnotation (AnnPragma o c s l1 l2 t m, src) prov e) = do + o' <- markAnnOpen'' o src "{-# ANN" + (t', m', prov') <- + case prov of + (ValueAnnProvenance n) -> do + n' <- markAnnotated n + return (t, m, ValueAnnProvenance n') + (TypeAnnProvenance n) -> do + t' <- markEpToken t + n' <- markAnnotated n + return (t', m, TypeAnnProvenance n') + ModuleAnnProvenance -> do + m' <- markEpToken m + return (t, m', prov) + + e' <- markAnnotated e + c' <- markEpToken c + return (HsAnnotation (AnnPragma o' c' s l1 l2 t' m',src) prov' e') + +-- --------------------------------------------------------------------- + +instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (BF.Var x) = do + x' <- markAnnotated x + return (BF.Var x') + exact (BF.Or ls) = do + ls' <- markAnnotated ls + return (BF.Or ls') + exact (BF.And ls) = do + ls' <- markAnnotated ls + return (BF.And ls') + exact (BF.Parens x) = do + x' <- markAnnotated x + return (BF.Parens x') + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _= a + exact (HsWC x ty) = do + ty' <- markAnnotated ty + return (HsWC x ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHS an _ _) = fromAnn an + setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b + + exact (GRHS an guards expr) = do + an0 <- if null guards + then return an + else markLensFun' an lga_vbar (\mt -> mapM markEpToken mt) + guards' <- markAnnotated guards + -- Mark the matchSeparator for these GRHSs + an1 <- markLensFun' an0 lga_sep (\s -> case s of + Left tok -> Left <$> markEpToken tok + Right tok -> Right <$> markEpUniToken tok) + expr' <- markAnnotated expr + return (GRHS an1 guards' expr') + +instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHS ann _ _) = fromAnn ann + setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b + + exact (GRHS an guards expr) = do + an0 <- markLensFun' an lga_vbar (\mt -> mapM markEpToken mt) + guards' <- markAnnotated guards + -- Mark the matchSeparator for these GRHSs + an1 <- markLensFun' an0 lga_sep (\s -> case s of + Left tok -> Left <$> markEpToken tok + Right tok -> Right <$> markEpUniToken tok) + expr' <- markAnnotated expr + return (GRHS an1 guards' expr') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsExpr GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (HsVar x n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered. + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (HsVar x n') + exact (HsUnboundVar an n) = do + case an of + Just (EpAnnUnboundVar (ob,cb) l) -> do + ob' <- markEpToken ob + l' <- markEpToken l + cb' <- markEpToken cb + return (HsUnboundVar (Just (EpAnnUnboundVar (ob',cb') l')) n) + _ -> do + printStringAdvanceA "_" >> return () + return (HsUnboundVar an n) + exact x@(HsOverLabel src l) = do + printStringAdvanceA "#" >> return () + case src of + NoSourceText -> printStringAdvanceA (unpackFS l) >> return () + SourceText txt -> printStringAdvanceA (unpackFS txt) >> return () + return x + + exact x@(HsIPVar _ (HsIPName n)) + = printStringAdvance ("?" ++ unpackFS n) >> return x + + 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 + case str of + SourceText s -> printStringAdvance (unpackFS s) >> return () + NoSourceText -> withPpr x >> return () + return x + + exact (HsLit an lit) = do + lit' <- withPpr lit + return (HsLit an lit') + + exact (HsLam an lam_variant mg) = do + an0 <- markLensFun an lepl_lambda markEpToken + an1 <- case lam_variant of + LamSingle -> return an0 + LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) + LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml) + mg' <- markAnnotated mg + return (HsLam an1 lam_variant mg') + + exact (HsApp an e1 e2) = do + p <- getPosP + debugM $ "HsApp entered. p=" ++ show p + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsApp an e1' e2') + exact (HsAppType at fun arg) = do + fun' <- markAnnotated fun + at' <- markEpToken at + arg' <- markAnnotated arg + return (HsAppType at' fun' arg') + exact (OpApp x e1 e2 e3) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + e3' <- markAnnotated e3 + return (OpApp x e1' e2' e3') + + exact (NegApp an e s) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (NegApp an0 e' s) + + exact (HsPar (lpar, rpar) e) = do + lpar' <- markEpToken lpar + e' <- markAnnotated e + debugM $ "HsPar closing paren" + rpar' <- markEpToken rpar + debugM $ "HsPar done" + return (HsPar (lpar', rpar') e') + + exact (SectionL an expr op) = do + expr' <- markAnnotated expr + op' <- markAnnotated op + return (SectionL an expr' op') + + exact (SectionR an op expr) = do + op' <- markAnnotated op + expr' <- markAnnotated expr + return (SectionR an op' expr') + + exact (ExplicitTuple (o,c) args b) = do + o0 <- if b == Boxed then printStringAtAA o "(" + else printStringAtAA o "(#" + + args' <- mapM markAnnotated args + + c0 <- if b == Boxed then printStringAtAA c ")" + else printStringAtAA c "#)" + debugM $ "ExplicitTuple done" + return (ExplicitTuple (o0,c0) args' b) + + exact (ExplicitSum an alt arity expr) = do + an0 <- markLensFun an laesOpen (\loc -> printStringAtAA loc "(#") + an1 <- markLensFun an0 laesBarsBefore (\locs -> mapM markEpToken locs) + expr' <- markAnnotated expr + an2 <- markLensFun an1 laesBarsAfter (\locs -> mapM markEpToken locs) + an3 <- markLensFun an2 laesClose (\loc -> printStringAtAA loc "#)") + return (ExplicitSum an3 alt arity expr') + + exact (HsCase an e alts) = do + an0 <- markLensFun an lhsCaseAnnCase markEpToken + e' <- markAnnotated e + an1 <- markLensFun an0 lhsCaseAnnOf markEpToken + alts' <- setLayoutBoth $ markAnnotated alts + return (HsCase an1 e' alts') + + exact (HsIf an e1 e2 e3) = do + an0 <- markLensFun an laiIf markEpToken + e1' <- markAnnotated e1 + an1 <- markLensFun an0 laiThenSemi (\mt -> mapM markEpToken mt) + an2 <- markLensFun an1 laiThen markEpToken + e2' <- markAnnotated e2 + an3 <- markLensFun an2 laiElseSemi (\mt -> mapM markEpToken mt) + an4 <- markLensFun an3 laiElse markEpToken + e3' <- markAnnotated e3 + return (HsIf an4 e1' e2' e3') + + exact (HsMultiIf (i,o,c) mg) = do + i0 <- markEpToken i + o0 <- markEpToken o + mg' <- markAnnotated mg + c0 <- markEpToken c + return (HsMultiIf (i0,o0,c0) mg') + + exact (HsLet (tkLet, tkIn) binds e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + tkLet' <- markEpToken tkLet + binds' <- setLayoutBoth $ markAnnotated binds + tkIn' <- markEpToken tkIn + e' <- markAnnotated e + return (HsLet (tkLet',tkIn') binds' e') + + exact (HsDo an do_or_list_comp stmts) = do + debugM $ "HsDo" + (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts + return (HsDo an' do_or_list_comp stmts') + + exact (ExplicitList an es) = do + debugM $ "ExplicitList start" + an0 <- markLensBracketsO' an lal_brackets + es' <- markAnnotated es + an1 <- markLensBracketsC' an0 lal_brackets + debugM $ "ExplicitList end" + return (ExplicitList an1 es') + exact (RecordCon (open, close) con_id binds) = do + con_id' <- markAnnotated con_id + open' <- mapM markEpToken open + binds' <- markAnnotated binds + close' <- mapM markEpToken close + return (RecordCon (open',close') con_id' binds') + exact (RecordUpd (open, close) expr fields) = do + expr' <- markAnnotated expr + open' <- mapM markEpToken open + fields' <- markAnnotated fields + close' <- mapM markEpToken close + return (RecordUpd (open', close') expr' fields') + exact (HsGetField an expr field) = do + expr' <- markAnnotated expr + field' <- markAnnotated field + return (HsGetField an expr' field') + exact (HsProjection an flds) = do + an0 <- markLensFun an lapOpen markEpToken + flds' <- mapM markAnnotated flds + an1 <- markLensFun an0 lapClose markEpToken + return (HsProjection an1 flds') + exact (ExprWithTySig an expr sig) = do + expr' <- markAnnotated expr + an0 <- markEpUniToken an + sig' <- markAnnotated sig + return (ExprWithTySig an0 expr' sig') + exact (ArithSeq (AnnArithSeq o mc dd c) s seqInfo) = do + o' <- markEpToken o + (mc', dd', seqInfo') <- + case seqInfo of + From e -> do + e' <- markAnnotated e + dd' <- markEpToken dd + return (mc, dd', From e') + FromTo e1 e2 -> do + e1' <- markAnnotated e1 + dd' <- markEpToken dd + e2' <- markAnnotated e2 + return (mc, dd', FromTo e1' e2') + FromThen e1 e2 -> do + e1' <- markAnnotated e1 + mc' <- mapM markEpToken mc + e2' <- markAnnotated e2 + dd' <- markEpToken dd + return (mc', dd', FromThen e1' e2') + FromThenTo e1 e2 e3 -> do + e1' <- markAnnotated e1 + mc' <- mapM markEpToken mc + e2' <- markAnnotated e2 + dd' <- markEpToken dd + e3' <- markAnnotated e3 + return (mc', dd', FromThenTo e1' e2' e3') + c' <- markEpToken c + return (ArithSeq (AnnArithSeq o' mc' dd' c') s seqInfo') + + + exact (HsTypedBracket (o,c) e) = do + o' <- case o of + BracketNoE t -> BracketNoE <$> markEpToken t + BracketHasE t -> BracketHasE <$> markEpToken t + e' <- markAnnotated e + c' <- markEpToken c + return (HsTypedBracket (o',c') e') + + exact (HsUntypedBracket a (ExpBr (o,c) e)) = do + o' <- case o of + BracketNoE t -> BracketNoE <$> markEpUniToken t + BracketHasE t -> BracketHasE <$> markEpToken t + e' <- markAnnotated e + c' <- markEpUniToken c + return (HsUntypedBracket a (ExpBr (o',c') e')) + + exact (HsUntypedBracket a (PatBr (o,c) e)) = do + o' <- markEpToken o + e' <- markAnnotated e + c' <- markEpUniToken c + return (HsUntypedBracket a (PatBr (o',c') e')) + + exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do + o' <- markEpToken o + oc' <- markEpToken oc + e' <- markAnnotated e + cc' <- markEpToken cc + c' <- markEpUniToken c + return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e')) + + exact (HsUntypedBracket a (TypBr (o,c) e)) = do + o' <- markEpToken o + e' <- markAnnotated e + c' <- markEpUniToken c + return (HsUntypedBracket a (TypBr (o',c') e')) + + exact (HsUntypedBracket a (VarBr an b e)) = do + (an0, e') <- if b + then do + an' <- printStringAtAA an "'" + e' <- markAnnotated e + return (an', e') + else do + an' <- printStringAtAA an "''" + e' <- markAnnotated e + return (an', e') + return (HsUntypedBracket a (VarBr an0 b e')) + + exact (HsTypedSplice an s) = do + an0 <- markEpToken an + s' <- markAnnotated s + return (HsTypedSplice an0 s') + + exact (HsUntypedSplice an s) = do + s' <- markAnnotated s + return (HsUntypedSplice an s') + + exact (HsProc (pr,r) p c) = do + debugM $ "HsProc start" + pr' <- markEpToken pr + p' <- markAnnotated p + r' <- markEpUniToken r + c' <- markAnnotated c + return (HsProc (pr',r') p' c') + + exact (HsStatic an e) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (HsStatic an0 e') + + exact (HsPragE a prag e) = do + prag' <- markAnnotated prag + e' <- markAnnotated e + return (HsPragE a prag' e') + + exact (HsEmbTy toktype t) = do + toktype' <- markEpToken toktype + t' <- markAnnotated t + return (HsEmbTy toktype' t') + + exact (HsFunArr _ mult arg res) = do + arg' <- markAnnotated arg + mult' <- markArrow mult + res' <- markAnnotated res + return (HsFunArr noExtField mult' arg' res') + + exact (HsForAll _ tele body) = do + tele' <- markAnnotated tele + body' <- markAnnotated body + return (HsForAll noExtField tele' body') + + exact (HsQual _ ctxt body) = do + ctxt' <- markAnnotated ctxt + body' <- markAnnotated body + return (HsQual noExtField ctxt' body') + + exact x = error $ "exact HsExpr for:" ++ showAst x + +-- --------------------------------------------------------------------- + +exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => AnnList EpaLocation -> HsDoFlavour -> LocatedAn an a + -> EP w m (AnnList EpaLocation, LocatedAn an a) +exactDo an (DoExpr m) stmts = exactMdo an m "do" >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an GhciStmtCtxt stmts = markLensFun an lal_rest (\l -> printStringAtAA l "do") >>= + \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an (MDoExpr m) stmts = exactMdo an m "mdo" >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an ListComp stmts = markMaybeDodgyStmts an stmts +exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts + +exactMdo :: (Monad m, Monoid w) + => AnnList EpaLocation -> Maybe ModuleName -> String -> EP w m (AnnList EpaLocation) +exactMdo an Nothing kw = markLensFun an lal_rest (\l -> printStringAtAA l kw) +exactMdo an (Just module_name) kw = markLensFun an lal_rest (\l -> printStringAtAA l n) + where + n = (moduleNameString module_name) ++ "." ++ kw + +markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => AnnList l -> LocatedAn an a -> EP w m (AnnList l, LocatedAn an a) +markMaybeDodgyStmts an stmts = + if notDodgy stmts + then do + r <- markAnnotatedWithLayout stmts + return (an, r) + else return (an, stmts) + +notDodgy :: GenLocated (EpAnn ann) a -> Bool +notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc + +notDodgyE :: EpaLocation -> Bool +notDodgyE anc = + case anc of + EpaSpan s -> isGoodSrcSpan s + EpaDelta{} -> True + +-- --------------------------------------------------------------------- +instance ExactPrint (HsPragE GhcPs) where + getAnnotationEntry HsPragSCC{} = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsPragSCC (AnnPragma o c s l1 l2 t m,st) sl) = do + o' <- markAnnOpen'' o st "{-# SCC" + l1' <- printStringAtAA l1 (sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl)) + c' <- markEpToken c + return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl) + + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsUntypedSplice GhcPs) where + getAnnotationEntry _ = NoEntryVal + + setAnnotationAnchor a _ _ _= a + + exact (HsUntypedSpliceExpr an e) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (HsUntypedSpliceExpr an0 e') + + exact (HsQuasiQuote an q (L l 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 + return (HsQuasiQuote an q (L l fs)) + +-- --------------------------------------------------------------------- + +-- TODO:AZ: combine these instances +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (MG x matches) = do + -- TODO:AZ use SortKey, in MG ann. + matches' <- markAnnotated matches + return (MG x matches') + +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (MG x matches) = do + -- TODO:AZ use SortKey, in MG ann. + matches' <- if notDodgy matches + then markAnnotated matches + else return matches + return (MG x matches') + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsRecFields x fields mdot) = do + fields' <- markAnnotated fields + mdot' <- case mdot of + Nothing -> return Nothing + Just (L ss d) -> do + ss' <- printStringAtAA ss ".." + return $ Just (L ss' d) + -- Note: mdot contains the SrcSpan where the ".." appears, if present + return (HsRecFields x fields' mdot') + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsFieldBind (LocatedA (FieldOcc GhcPs)) body) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsFieldBind an f arg isPun) = do + debugM $ "HsFieldBind" + f' <- markAnnotated f + (an0, arg') <- if isPun then return (an, arg) + else do + an0 <- mapM markEpToken an + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsFieldBind an f arg isPun) = do + debugM $ "HsFieldBind FieldLabelStrings" + f' <- markAnnotated f + (an0, arg') <- if isPun then return (an, arg) + else do + an0 <- mapM markEpToken an + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) + +-- --------------------------------------------------------------------- + +instance ExactPrint (LHsRecUpdFields GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do + debugM $ "RegularRecUpdFields" + rbinds' <- markAnnotated rbinds + return $ flds { recUpdFields = rbinds' } + exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do + debugM $ "OverloadedRecUpdFields" + pbinds' <- markAnnotated pbinds + return $ flds { olRecUpdFields = pbinds' } + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldLabelStrings GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (DotFieldOcc GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do + an0 <- markLensFun an lafDot (\ml -> mapM markEpToken ml) + -- The field name has a SrcSpanAnnN, print it as a + -- LocatedN RdrName + L loc' _ <- markAnnotated (L loc (mkVarUnqual fs)) + return (DotFieldOcc an0 (L loc' (FieldLabelString fs))) + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsTupArg GhcPs) where + getAnnotationEntry (Present _ _) = NoEntryVal + getAnnotationEntry (Missing (EpAnn _ False _)) = NoEntryVal + getAnnotationEntry (Missing an) = fromAnn an + + setAnnotationAnchor (Present a b) _ _ _ = Present a b + setAnnotationAnchor (Missing an) anc ts cs = Missing (setAnchorEpa an anc ts cs) + + exact (Present a e) = Present a <$> markAnnotated e + + exact a@(Missing (EpAnn _ False _)) = return a + exact a@(Missing _) = printStringAdvance "," >> return a + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmdTop GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmd GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp True) = do + arr' <- markAnnotated arr + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤙" + NormalSyntax -> printStringAtAA l "-<" + arg' <- markAnnotated arg + return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp True) + exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp False) = do + arg' <- markAnnotated arg + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤚" + NormalSyntax -> printStringAtAA l ">-" + arr' <- markAnnotated arr + return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp False) + exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp True) = do + arr' <- markAnnotated arr + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤛" + NormalSyntax -> printStringAtAA l "-<<" + arg' <- markAnnotated arg + return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp True) + exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp False) = do + arg' <- markAnnotated arg + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤜" + NormalSyntax -> printStringAtAA l ">>-" + arr' <- markAnnotated arr + return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False) + + exact (HsCmdArrForm an e fixity cs) = do + an0 <- markLensBracketsO' an lal_brackets + (e',cs') <- case (fixity, cs) of + (Infix, (arg1:argrest)) -> do + arg1' <- markAnnotated arg1 + e' <- markAnnotated e + argrest' <- markAnnotated argrest + return (e', arg1':argrest') + (Prefix, _) -> do + e' <- markAnnotated e + cs' <- markAnnotated cs + return (e', cs') + (Infix, []) -> error "Not possible" + an1 <- markLensBracketsC' an0 lal_brackets + return (HsCmdArrForm an1 e' fixity cs') + + exact (HsCmdApp an e1 e2) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsCmdApp an e1' e2') + + exact (HsCmdLam an lam_variant matches) = do + an0 <- markLensFun an lepl_lambda markEpToken + an1 <- case lam_variant of + LamSingle -> return an0 + LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) + LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml) + matches' <- markAnnotated matches + return (HsCmdLam an1 lam_variant matches') + + exact (HsCmdPar (lpar, rpar) e) = do + lpar' <- markEpToken lpar + e' <- markAnnotated e + rpar' <- markEpToken rpar + return (HsCmdPar (lpar', rpar') e') + + exact (HsCmdCase an e alts) = do + an0 <- markLensFun an lhsCaseAnnCase markEpToken + e' <- markAnnotated e + an1 <- markLensFun an0 lhsCaseAnnOf markEpToken + alts' <- markAnnotated alts + return (HsCmdCase an1 e' alts') + + exact (HsCmdIf an a e1 e2 e3) = do + an0 <- markLensFun an laiIf markEpToken + e1' <- markAnnotated e1 + an1 <- markLensFun an0 laiThenSemi (\mt -> mapM markEpToken mt) + an2 <- markLensFun an1 laiThen markEpToken + e2' <- markAnnotated e2 + an3 <- markLensFun an2 laiElseSemi (\mt -> mapM markEpToken mt) + an4 <- markLensFun an3 laiElse markEpToken + e3' <- markAnnotated e3 + return (HsCmdIf an4 a e1' e2' e3') + + exact (HsCmdLet (tkLet, tkIn) binds e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + tkLet' <- markEpToken tkLet + binds' <- setLayoutBoth $ markAnnotated binds + tkIn' <- markEpToken tkIn + e' <- markAnnotated e + return (HsCmdLet (tkLet', tkIn') binds' e') + + exact (HsCmdDo an es) = do + debugM $ "HsCmdDo" + an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do") + es' <- markAnnotated es + return (HsCmdDo an0 es') + +-- --------------------------------------------------------------------- + +instance ( + ExactPrint (LocatedA (body GhcPs)), + Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW, + (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (LastStmt a body b c) = do + debugM $ "LastStmt" + body' <- markAnnotated body + return (LastStmt a body' b c) + + exact (BindStmt an pat body) = do + debugM $ "BindStmt" + pat' <- markAnnotated pat + an0 <- markEpUniToken an + body' <- markAnnotated body + return (BindStmt an0 pat' body') + + exact (BodyStmt a body b c) = do + debugM $ "BodyStmt" + body' <- markAnnotated body + return (BodyStmt a body' b c) + + exact (LetStmt tlet binds) = do + debugM $ "LetStmt" + tlet' <- markEpToken tlet + binds' <- markAnnotated binds + return (LetStmt tlet' binds') + + exact (ParStmt a pbs b c) = do + debugM $ "ParStmt" + pbs' <- markAnnotated pbs + return (ParStmt a pbs' b c) + + exact (TransStmt an form stmts b using by c d e) = do + debugM $ "TransStmt" + stmts' <- markAnnotated stmts + (an', by', using') <- exactTransStmt an by using form + return (TransStmt an' form stmts' b using' by' c d e) + + exact (RecStmt an stmts a b c d e) = do + debugM $ "RecStmt" + an0 <- markLensFun an lal_rest markEpToken + (an1, stmts') <- markAnnList' an0 (markAnnotated stmts) + return (RecStmt an1 stmts' a b c d e) + +-- --------------------------------------------------------------------- + +instance ExactPrint (ParStmtBlock GhcPs GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (ParStmtBlock a stmts b c) = do + stmts' <- markAnnotated stmts + return (ParStmtBlock a stmts' b c) + +exactTransStmt :: (Monad m, Monoid w) + => AnnTransStmt -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm + -> EP w m (AnnTransStmt, Maybe (LHsExpr GhcPs), (LHsExpr GhcPs)) +exactTransStmt (AnnTransStmt at ag ab au) by using ThenForm = do + debugM $ "exactTransStmt:ThenForm" + at' <- markEpToken at + using' <- markAnnotated using + case by of + Nothing -> return (AnnTransStmt at' ag ab au, by, using') + Just b -> do + ab' <- mapM markEpToken ab + b' <- markAnnotated b + return ((AnnTransStmt at' ag ab' au), Just b', using') +exactTransStmt (AnnTransStmt at ag ab au) by using GroupForm = do + debugM $ "exactTransStmt:GroupForm" + at' <- markEpToken at + ag' <- mapM markEpToken ag + (ab', by') <- case by of + Nothing -> return (ab, by) + Just b -> do + ab0 <- mapM markEpToken ab + b' <- markAnnotated b + return (ab0, Just b') + au' <- mapM markEpToken au + using' <- markAnnotated using + return (AnnTransStmt at' ag' ab' au', by', using') + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyClDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (FamDecl a decl) = do + decl' <- markAnnotated decl + return (FamDecl a decl') + + exact (SynDecl { tcdSExt = AnnSynDecl ops cps t eq + , 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 + -- TODO: no longer sorting on insert. What now? + epTokensToComments "(" ops + epTokensToComments ")" cps + t' <- markEpToken t + + (_,ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing + eq' <- markEpToken eq + rhs' <- markAnnotated rhs + return (SynDecl { tcdSExt = AnnSynDecl [] [] t' eq' + , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity + , tcdRhs = rhs' }) + + exact (DataDecl { tcdDExt = x, tcdLName = ltycon, tcdTyVars = tyvars + , tcdFixity = fixity, tcdDataDefn = defn }) = do + (_,ltycon', tyvars', _, defn') <- + exactDataDefn (exactVanillaDeclHead ltycon tyvars fixity) defn + return (DataDecl { tcdDExt = x, tcdLName = ltycon', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) + + -- ----------------------------------- + + exact (ClassDecl {tcdCExt = (AnnClassDecl c ops cps vb w oc cc semis, lo, 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 && null methods && null ats && null at_defs -- No "where" part + = do + (c', w', vb', fds', lclas', tyvars',context') <- top_matter + oc' <- markEpToken oc + cc' <- markEpToken cc + return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis, lo, sortKey), + tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', + tcdFixity = fixity, + tcdFDs = fds', + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = _docs}) + + | otherwise -- Laid out + = do + (c', w', vb', fds', lclas', tyvars',context') <- top_matter + oc' <- markEpToken oc + semis' <- mapM markEpToken semis + (sortKey', ds) <- withSortKey sortKey + [(ClsSigTag, prepareListAnnotationA sigs), + (ClsMethodTag, prepareListAnnotationA methods), + (ClsAtTag, prepareListAnnotationA ats), + (ClsAtdTag, prepareListAnnotationA at_defs) + -- ++ prepareListAnnotation docs + ] + cc' <- markEpToken cc + let + sigs' = undynamic ds + methods' = undynamic ds + ats' = undynamic ds + at_defs' = undynamic ds + return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis', lo, sortKey'), + tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', + tcdFixity = fixity, + tcdFDs = fds', + tcdSigs = sigs', tcdMeths = methods', + tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = _docs}) + where + top_matter = do + epTokensToComments "(" ops + epTokensToComments ")" cps + c' <- markEpToken c + (_,lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context + (vb', fds') <- if (null fds) + then return (vb, fds) + else do + vb' <- markEpToken vb + fds' <- markAnnotated fds + return (vb', fds') + w' <- markEpToken w + return (c', w', vb', fds', lclas', tyvars',context') + + +-- --------------------------------------------------------------------- + +instance ExactPrint (FunDep GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (FunDep an ls rs') = do + ls' <- markAnnotated ls + an0 <- markEpUniToken an + rs'' <- markAnnotated rs' + return (FunDep an0 ls' rs'') + +-- --------------------------------------------------------------------- + +instance ExactPrint (FamilyDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (FamilyDecl { fdExt = AnnFamilyDecl ops cps t d f dc eq vb w oc dd cc + , fdInfo = info + , fdTopLevel = top_level + , fdLName = ltycon + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L lr result + , fdInjectivityAnn = mb_inj }) = do + (d',t') <- exactFlavour (d,t) info + f' <- exact_top_level f + + epTokensToComments "(" ops + epTokensToComments ")" cps + (_,ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing + (dc', eq', result') <- exact_kind (dc, eq) + (vb', mb_inj') <- + case mb_inj of + Nothing -> return (vb, mb_inj) + Just inj -> do + vb' <- markEpToken vb + inj' <- markAnnotated inj + return (vb', Just inj') + (w', oc', dd', cc', info') <- + case info of + ClosedTypeFamily mb_eqns -> do + w' <- markEpToken w + oc' <- markEpToken oc + (dd', mb_eqns') <- + case mb_eqns of + Nothing -> do + dd' <- markEpToken dd + return (dd', mb_eqns) + Just eqns -> do + eqns' <- markAnnotated eqns + return (dd, Just eqns') + cc' <- markEpToken cc + return (w',oc',dd',cc', ClosedTypeFamily mb_eqns') + _ -> return (w,oc,dd,cc, info) + return (FamilyDecl { fdExt = AnnFamilyDecl [] [] t' d' f' dc' eq' vb' w' oc' dd' cc' + , fdInfo = info' + , fdTopLevel = top_level + , fdLName = ltycon' + , fdTyVars = tyvars' + , fdFixity = fixity + , fdResultSig = L lr result' + , fdInjectivityAnn = mb_inj' }) + where + exact_top_level tfamily = + case top_level of + TopLevel -> markEpToken tfamily + NotTopLevel -> do + -- It seems that in some kind of legacy + -- mode the 'family' keyword is still + -- accepted. + markEpToken tfamily + + exact_kind (tdcolon, tequal) = + case result of + NoSig _ -> return (tdcolon, tequal, result) + KindSig x kind -> do + tdcolon' <- markEpUniToken tdcolon + kind' <- markAnnotated kind + return (tdcolon', tequal, KindSig x kind') + TyVarSig x tv_bndr -> do + tequal' <- markEpToken tequal + tv_bndr' <- markAnnotated tv_bndr + return (tdcolon, tequal', TyVarSig x tv_bndr') + + +exactFlavour :: (Monad m, Monoid w) => (EpToken "data", EpToken "type") -> FamilyInfo GhcPs -> EP w m (EpToken "data", EpToken "type") +exactFlavour (td,tt) DataFamily = (\td' -> (td',tt)) <$> markEpToken td +exactFlavour (td,tt) OpenTypeFamily = (td,) <$> markEpToken tt +exactFlavour (td,tt) (ClosedTypeFamily {}) = (td,) <$> markEpToken tt + +-- --------------------------------------------------------------------- + +exactDataDefn + :: (Monad m, Monoid w) + => (Maybe (LHsContext GhcPs) -> EP w m (r + , LocatedN RdrName + , a + , b + , Maybe (LHsContext GhcPs))) -- Printing the header + -> HsDataDefn GhcPs + -> EP w m ( r -- ^ from exactHdr + , LocatedN RdrName, a, b, HsDataDefn GhcPs) +exactDataDefn exactHdr + (HsDataDefn { dd_ext = AnnDataDefn ops cps t nt d i dc w oc cc eq + , dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) = do + + + epTokensToComments "(" ops + epTokensToComments ")" cps + + (t',nt',d') <- case condecls of + DataTypeCons is_type_data _ -> do + t' <- if is_type_data + then markEpToken t + else return t + d' <- markEpToken d + return (t',nt,d') + NewTypeCon _ -> do + nt' <- markEpToken nt + return (t, nt', d) + + i' <- markEpToken i -- optional 'instance' + mb_ct' <- mapM markAnnotated mb_ct + (anx, ln', tvs', b, mctxt') <- exactHdr context + (dc', mb_sig') <- case mb_sig of + Nothing -> return (dc, Nothing) + Just kind -> do + dc' <- markEpUniToken dc + kind' <- markAnnotated kind + return (dc', Just kind') + w' <- if (needsWhere condecls) + then markEpToken w + else return w + oc' <- markEpToken oc + (eq', condecls') <- exact_condecls eq (toList condecls) + let condecls'' = case condecls of + DataTypeCons td _ -> DataTypeCons td condecls' + NewTypeCon _ -> case condecls' of + [decl] -> NewTypeCon decl + _ -> panic "exacprint NewTypeCon" + cc' <- markEpToken cc + derivings' <- mapM markAnnotated derivings + return (anx, ln', tvs', b, + (HsDataDefn { dd_ext = AnnDataDefn [] [] t' nt' d' i' dc' w' oc' cc' eq' + , dd_ctxt = mctxt' + , dd_cType = mb_ct' + , dd_kindSig = mb_sig' + , dd_cons = condecls'', dd_derivs = derivings' })) + + +exactVanillaDeclHead :: (Monad m, Monoid w) + => LocatedN RdrName + -> LHsQTyVars GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EP w m ( () -- TO allow use in exactDataDefn + , LocatedN RdrName + , LHsQTyVars GhcPs + , (), Maybe (LHsContext GhcPs)) +exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do + let + exact_tyvars (varl:varsr) + | hvarsr : tvarsr@(_ : _) <- varsr + , fixity == Infix = do + varl' <- markAnnotated varl + thing' <- markAnnotated thing + hvarsr' <- markAnnotated hvarsr + tvarsr' <- markAnnotated tvarsr + return (thing', varl':hvarsr':tvarsr') + | fixity == Infix = do + varl' <- markAnnotated varl + thing' <- markAnnotated thing + varsr' <- markAnnotated varsr + return (thing', varl':varsr') + | otherwise = do + thing' <- markAnnotated thing + vs <- mapM markAnnotated (varl:varsr) + return (thing', vs) + exact_tyvars [] = do + thing' <- markAnnotated thing + return (thing', []) + context' <- mapM markAnnotated context + (thing', tyvars') <- exact_tyvars tyvars + return ((), thing', tvs { hsq_explicit = tyvars' }, (), context') + +-- --------------------------------------------------------------------- + +instance ExactPrint (InjectivityAnn GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (InjectivityAnn rarrow lhs rhs) = do + lhs' <- markAnnotated lhs + rarrow' <- markEpUniToken rarrow + rhs' <- mapM markAnnotated rhs + return (InjectivityAnn rarrow' lhs' rhs') + +-- --------------------------------------------------------------------- + +class Typeable flag => ExactPrintTVFlag flag where + exactTVDelimiters :: (Monad m, Monoid w) + => AnnTyVarBndr -> flag + -> EP w m (HsTyVarBndr flag GhcPs) + -> EP w m (AnnTyVarBndr, flag, HsTyVarBndr flag GhcPs) + +instance ExactPrintTVFlag () where + exactTVDelimiters (AnnTyVarBndr os cs ap dc) flag thing_inside = do + os' <- markEpaLocationAll os "(" + r <- thing_inside + cs' <- markEpaLocationAll cs ")" + return (AnnTyVarBndr os' cs' ap dc, flag, r) + +instance ExactPrintTVFlag Specificity where + exactTVDelimiters (AnnTyVarBndr os cs ap dc) s thing_inside = do + os' <- markEpaLocationAll os open + r <- thing_inside + cs' <- markEpaLocationAll cs close + return (AnnTyVarBndr os' cs' ap dc, s, r) + where + (open, close) = case s of + SpecifiedSpec -> ("(", ")") + InferredSpec -> ("{", "}") + +instance ExactPrintTVFlag (HsBndrVis GhcPs) where + exactTVDelimiters (AnnTyVarBndr os cs ap dc) bvis thing_inside = do + bvis' <- case bvis of + HsBndrRequired _ -> return bvis + HsBndrInvisible at -> HsBndrInvisible <$> markEpToken at + os' <- markEpaLocationAll os "(" + r <- thing_inside + cs' <- markEpaLocationAll cs ")" + return (AnnTyVarBndr os' cs' ap dc, bvis', r) + +instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsTvb an flag n (HsBndrNoKind _)) = do + r <- exactTVDelimiters an flag $ do + n' <- markAnnotated n + return (HsTvb an flag n' (HsBndrNoKind noExtField)) + case r of + (an', flag', HsTvb _ _ n'' k'') -> return (HsTvb an' flag' n'' k'') + + exact (HsTvb an@(AnnTyVarBndr os cs ap dc) flag n (HsBndrKind _ k)) = do + r <- exactTVDelimiters an flag $ do + n' <- markAnnotated n + dc' <- markEpUniToken dc + k' <- markAnnotated k + let an0 = AnnTyVarBndr os cs ap dc' + return (HsTvb an0 flag n' (HsBndrKind noExtField k')) + case r of + (an',flag', HsTvb an1 _ n'' k'') -> return (HsTvb (an'{ atv_dcolon = atv_dcolon an1 }) flag' n'' k'') + +instance ExactPrint (HsBndrVar GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsBndrVar x n) = do + n' <- markAnnotated n + return (HsBndrVar x n') + exact (HsBndrWildCard t) = do + t' <- markEpToken t + return (HsBndrWildCard t') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsType GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (HsForAllTy { hst_xforall = an + , hst_tele = tele, hst_body = ty }) = do + tele' <- markAnnotated tele + ty' <- markAnnotated ty + return (HsForAllTy { hst_xforall = an + , hst_tele = tele', hst_body = ty' }) + + exact (HsQualTy an ctxt ty) = do + ctxt' <- markAnnotated ctxt + ty' <- markAnnotated ty + return (HsQualTy an ctxt' ty') + exact (HsTyVar an promoted name) = do + an0 <- if (promoted == IsPromoted) + then markEpToken an + else return an + name' <- markAnnotated name + return (HsTyVar an0 promoted name') + exact (HsAppTy an t1 t2) = do + t1' <- markAnnotated t1 + t2' <- markAnnotated t2 + return (HsAppTy an t1' t2') + exact (HsAppKindTy at ty ki) = do + ty' <- markAnnotated ty + at' <- markEpToken at + ki' <- markAnnotated ki + return (HsAppKindTy at' ty' ki') + exact (HsFunTy an mult ty1 ty2) = do + ty1' <- markAnnotated ty1 + mult' <- markArrow mult + ty2' <- markAnnotated ty2 + return (HsFunTy an mult' ty1' ty2') + exact (HsListTy an tys) = do + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsListTy an1 tys') + exact (HsTupleTy an con tys) = do + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsTupleTy an1 con tys') + exact (HsSumTy an tys) = do + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsSumTy an1 tys') + exact (HsOpTy x promoted t1 lo t2) = do + t1' <- markAnnotated t1 + lo' <- markAnnotated lo + t2' <- markAnnotated t2 + return (HsOpTy x promoted t1' lo' t2') + exact (HsParTy (o,c) ty) = do + o' <- markEpToken o + ty' <- markAnnotated ty + c' <- markEpToken c + return (HsParTy (o',c') ty') + exact (HsIParamTy an n t) = do + n' <- markAnnotated n + an0 <- markEpUniToken an + t' <- markAnnotated t + return (HsIParamTy an0 n' t') + exact (HsStarTy an isUnicode) = do + if isUnicode + then printStringAdvance "\x2605" -- Unicode star + else printStringAdvance "*" + return (HsStarTy an isUnicode) + exact (HsKindSig an ty k) = do + ty' <- markAnnotated ty + an0 <- markEpUniToken an + k' <- markAnnotated k + return (HsKindSig an0 ty' k') + exact (HsSpliceTy a splice) = do + splice' <- markAnnotated splice + return (HsSpliceTy a splice') + exact (HsDocTy an ty doc) = do + ty' <- markAnnotated ty + return (HsDocTy an ty' doc) + exact (HsBangTy ((o,c,tk), mt) (HsBang up str) ty) = do + (o',c') <- + case mt of + NoSourceText -> return (o,c) + SourceText src -> do + debugM $ "HsBangTy: src=" ++ showAst src + o' <- printStringAtAA o (unpackFS src) + c' <- markEpToken c + return (o',c') + tk' <- + case str of + SrcLazy -> printStringAtAA tk "~" + SrcStrict -> printStringAtAA tk "!" + NoSrcStrict -> return tk + ty' <- markAnnotated ty + return (HsBangTy ((o',c',tk'), mt) (HsBang up str) ty') + exact (HsExplicitListTy (sq,o,c) prom tys) = do + sq' <- if (isPromoted prom) + then markEpToken sq + else return sq + o' <- markEpToken o + tys' <- markAnnotated tys + c' <- markEpToken c + return (HsExplicitListTy (sq',o',c') prom tys') + exact (HsExplicitTupleTy (sq, o, c) prom tys) = do + sq' <- if (isPromoted prom) + then markEpToken sq + else return sq + o' <- markEpToken o + tys' <- markAnnotated tys + c' <- markEpToken c + return (HsExplicitTupleTy (sq', o', c') prom tys') + exact (HsTyLit a 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) + return (HsTyLit a lit) + exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t + exact x = error $ "missing match for HsType:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsForAllTelescope GhcPs) where + getAnnotationEntry (HsForAllVis an _) = fromAnn an + getAnnotationEntry (HsForAllInvis an _) = fromAnn an + + setAnnotationAnchor (HsForAllVis an a) anc ts cs = HsForAllVis (setAnchorEpa an anc ts cs) a + setAnnotationAnchor (HsForAllInvis an a) anc ts cs = HsForAllInvis (setAnchorEpa an anc ts cs) a + + exact (HsForAllVis (EpAnn l (f,r) cs) bndrs) = do + f' <- markEpUniToken f + bndrs' <- markAnnotated bndrs + r' <- markEpUniToken r + return (HsForAllVis (EpAnn l (f',r') cs) bndrs') + + exact (HsForAllInvis (EpAnn l (f,d) cs) bndrs) = do + f' <- markEpUniToken f + bndrs' <- markAnnotated bndrs + d' <- markEpToken d + return (HsForAllInvis (EpAnn l (f',d') cs) bndrs') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDerivingClause GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsDerivingClause { deriv_clause_ext = an + , deriv_clause_strategy = dcs + , deriv_clause_tys = dct }) = do + an0 <- markEpToken an + dcs0 <- case dcs of + Just (L _ ViaStrategy{}) -> return dcs + _ -> mapM markAnnotated dcs + dct' <- markAnnotated dct + dcs1 <- case dcs0 of + Just (L _ ViaStrategy{}) -> mapM markAnnotated dcs0 + _ -> return dcs0 + return (HsDerivingClause { deriv_clause_ext = an0 + , deriv_clause_strategy = dcs1 + , deriv_clause_tys = dct' }) + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivStrategy GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (StockStrategy an) = do + an0 <- markEpToken an + return (StockStrategy an0) + exact (AnyclassStrategy an) = do + an0 <- markEpToken an + return (AnyclassStrategy an0) + exact (NewtypeStrategy an) = do + an0 <- markEpToken an + return (NewtypeStrategy an0) + exact (ViaStrategy (XViaStrategyPs an ty)) = do + an0 <- markEpToken an + ty' <- markAnnotated ty + return (ViaStrategy (XViaStrategyPs an0 ty')) + +-- --------------------------------------------------------------------- + +instance (ExactPrint a) => ExactPrint (LocatedC a) where + getAnnotationEntry (L sann _) = fromAnn sann + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn anc (AnnContext ma opens closes) cs) a) = do + opens' <- mapM markEpToken opens + a' <- markAnnotated a + closes' <- mapM markEpToken closes + return (L (EpAnn anc (AnnContext ma opens' closes') cs) a') + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivClauseTys GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DctSingle x ty) = do + ty' <- markAnnotated ty + return (DctSingle x ty') + exact (DctMulti x tys) = do + tys' <- markAnnotated tys + return (DctMulti x tys') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsSig a bndrs ty) = do + bndrs' <- markAnnotated bndrs + ty' <- markAnnotated ty + return (HsSig a bndrs' ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedN RdrName) where + getAnnotationEntry (L sann _) = fromAnn sann + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn anc ann cs) n) = do + ann' <- + case ann of + NameAnn a l t -> do + mn <- markName a (Just (l,n)) + case mn of + (a', (Just (l',_n))) -> do + return (NameAnn a' l' t) + _ -> error "ExactPrint (LocatedN RdrName)" + NameAnnCommas a commas t -> do + a0 <- markNameAdornmentO a + commas' <- forM commas markEpToken + a1 <- markNameAdornmentC a0 + return (NameAnnCommas a1 commas' t) + NameAnnBars (o,c) bars t -> do + o' <- markEpToken o + bars' <- mapM markEpToken bars + c' <- markEpToken c + return (NameAnnBars (o',c') bars' t) + NameAnnOnly a t -> do + (a',_) <- markName a Nothing + return (NameAnnOnly a' t) + NameAnnRArrow o nl c t -> do + o' <- mapM markEpToken o + nl' <- markEpUniToken nl + c' <- mapM markEpToken c + return (NameAnnRArrow o' nl' c' t) + NameAnnQuote q name t -> do + debugM $ "NameAnnQuote" + q' <- markEpToken q + (L name' _) <- markAnnotated (L name n) + return (NameAnnQuote q' name' t) + NameAnnTrailing t -> do + _anc' <- printUnicode anc n + return (NameAnnTrailing t) + return (L (EpAnn anc ann' cs) n) + + +markNameAdornmentO :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment +markNameAdornmentO (NameParens o c) = do + o' <- markEpToken o + return (NameParens o' c) +markNameAdornmentO (NameParensHash o c) = do + o' <- markEpToken o + return (NameParensHash o' c) +markNameAdornmentO (NameBackquotes o c) = do + o' <- markEpToken o + return (NameBackquotes o' c) +markNameAdornmentO (NameSquare o c) = do + o' <- markEpToken o + return (NameSquare o' c) +markNameAdornmentO NameNoAdornment = return NameNoAdornment + +markNameAdornmentC :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment +markNameAdornmentC (NameParens o c) = do + c' <- markEpToken c + return (NameParens o c') +markNameAdornmentC (NameParensHash o c) = do + c' <- markEpToken c + return (NameParensHash o c') +markNameAdornmentC (NameBackquotes o c) = do + c' <- markEpToken c + return (NameBackquotes o c') +markNameAdornmentC (NameSquare o c) = do + c' <- markEpToken c + return (NameSquare o c') +markNameAdornmentC NameNoAdornment = return NameNoAdornment + +printUnicode :: (Monad m, Monoid w) => EpaLocation -> RdrName -> EP w m EpaLocation +printUnicode anc n = do + let str = case (showPprUnsafe n) of + -- TODO: unicode support? + "forall" -> if spanLength (epaLocationRealSrcSpan anc) == 1 then "∀" else "forall" + s -> s + loc <- printStringAtAAC NoCaptureComments (EpaDelta (getHasLoc anc) (SameLine 0) []) str + case loc of + EpaSpan _ -> return anc + EpaDelta ss dp [] -> return $ EpaDelta ss dp [] + EpaDelta _ _ _cs -> error "printUnicode should not capture comments" + + +markName :: (Monad m, Monoid w) + => NameAdornment -> Maybe (EpaLocation,RdrName) + -> EP w m (NameAdornment, Maybe (EpaLocation,RdrName)) +markName adorn mname = do + adorn0 <- markNameAdornmentO adorn + mname' <- + case mname of + Nothing -> return Nothing + Just (name, a) -> do + name' <- printStringAtAAC CaptureComments name (showPprUnsafe a) + return (Just (name',a)) + adorn1 <- markNameAdornmentC adorn0 + return (adorn1, mname') + +markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn] +markTrailing ts = do + p <- getPosP + debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) + mapM markKwT ts + +-- --------------------------------------------------------------------- + +-- based on pp_condecls in Decls.hs +exact_condecls :: (Monad m, Monoid w) + => EpToken "=" -> [LConDecl GhcPs] -> EP w m (EpToken "=",[LConDecl GhcPs]) +exact_condecls eq cs + | gadt_syntax -- In GADT syntax + = do + cs' <- mapM markAnnotated cs + return (eq, cs') + | otherwise -- In H98 syntax + = do + eq0 <- markEpToken eq + cs' <- mapM markAnnotated cs + return (eq0, cs') + where + gadt_syntax = case cs of + [] -> False + (L _ ConDeclH98{} : _) -> False + (L _ ConDeclGADT{} : _) -> True + +-- --------------------------------------------------------------------- + +instance ExactPrint (ConDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + +-- based on pprConDecl + exact (ConDeclH98 { con_ext = AnnConDeclH98 tforall tdot tdarrow + , con_name = con + , con_forall = has_forall + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) = do + tforall' <- if has_forall + then markEpUniToken tforall + else return tforall + ex_tvs' <- mapM markAnnotated ex_tvs + tdot' <- if has_forall + then markEpToken tdot + else return tdot + mcxt' <- mapM markAnnotated mcxt + tdarrow' <- if (isJust mcxt) + then markEpUniToken tdarrow + else return tdarrow + + (con', args') <- exact_details args + return (ConDeclH98 { con_ext = AnnConDeclH98 tforall' tdot' tdarrow' + , con_name = con' + , con_forall = has_forall + , con_ex_tvs = ex_tvs' + , con_mb_cxt = mcxt' + , con_args = args' + , con_doc = doc }) + + 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 + t1' <- markAnnotated t1 + con' <- markAnnotated con + t2' <- markAnnotated t2 + return (con', InfixCon t1' t2') + exact_details (PrefixCon tyargs tys) = do + con' <- markAnnotated con + tyargs' <- markAnnotated tyargs + tys' <- markAnnotated tys + return (con', PrefixCon tyargs' tys') + exact_details (RecCon fields) = do + con' <- markAnnotated con + fields' <- markAnnotated fields + return (con', RecCon fields') + + -- ----------------------------------- + + exact (ConDeclGADT { con_g_ext = AnnConDeclGADT ops cps dcol + , con_names = cons + , con_bndrs = bndrs + , con_mb_cxt = mcxt, con_g_args = args + , con_res_ty = res_ty, con_doc = doc }) = do + cons' <- mapM markAnnotated cons + dcol' <- markEpUniToken dcol + epTokensToComments "(" ops + epTokensToComments ")" cps + + -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 + bndrs' <- case bndrs of + L _ (HsOuterImplicit _) -> return bndrs + _ -> markAnnotated bndrs + + mcxt' <- mapM markAnnotated mcxt + args' <- + case args of + (PrefixConGADT x args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT x args0') + (RecConGADT rarr fields) -> do + fields' <- markAnnotated fields + rarr' <- markEpUniToken rarr + return (RecConGADT rarr' fields') + res_ty' <- markAnnotated res_ty + return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' + , con_names = cons' + , con_bndrs = bndrs' + , con_mb_cxt = mcxt', con_g_args = args' + , con_res_ty = res_ty', con_doc = doc }) + +-- --------------------------------------------------------------------- + +instance ExactPrint Void where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact x = return x + +-- --------------------------------------------------------------------- + +instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where + getAnnotationEntry (HsOuterImplicit _) = NoEntryVal + getAnnotationEntry (HsOuterExplicit an _) = fromAnn an + + setAnnotationAnchor (HsOuterImplicit a) _ _ _ = HsOuterImplicit a + setAnnotationAnchor (HsOuterExplicit an a) anc ts cs = HsOuterExplicit (setAnchorEpa an anc ts cs) a + + exact b@(HsOuterImplicit _) = pure b + exact (HsOuterExplicit (EpAnn l (f,d) cs) bndrs) = do + f' <- markEpUniToken f + bndrs' <- markAnnotated bndrs + d' <- markEpToken d + return (HsOuterExplicit (EpAnn l (f',d') cs) bndrs') + +-- --------------------------------------------------------------------- + +instance ExactPrint (ConDeclField GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (ConDeclField td names ftype mdoc) = do + names' <- markAnnotated names + td' <- markEpUniToken td + ftype' <- markAnnotated ftype + return (ConDeclField td' names' ftype' mdoc) + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldOcc GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (FieldOcc x n) = do + n' <- markAnnotated n + return (FieldOcc x n') + +-- --------------------------------------------------------------------- + +instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsScaled arr t) = do + t' <- markAnnotated t + arr' <- markArrow arr + return (HsScaled arr' t') + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP CType) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType stp mh (stct,ct))) = do + o' <- markAnnOpen'' o stp "{-# CTYPE" + l1' <- case mh of + Nothing -> return l1 + Just (Header srcH _h) -> + printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") + l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "") + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType stp mh (stct,ct))) + +-- --------------------------------------------------------------------- + +instance ExactPrint (SourceText, RuleName) where + -- We end up at the right place from the Located wrapper + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (st, rn) + = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") + >> return (st, 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 (LocatedLI [LocatedA (IE GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact (L an ies) = do + debugM $ "LocatedL [LIE" + an0 <- markLensFun' an (lal_rest . lfst) markEpToken + p <- getPosP + debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p + (an1, ies') <- markAnnList an0 (markAnnotated (filter notIEDoc ies)) + return (L an1 ies') + +instance (ExactPrint (Match GhcPs (LocatedA body))) + => ExactPrint (LocatedLW [LocatedA (Match GhcPs (LocatedA body))]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an a) = do + debugM $ "LocatedL [LMatch" + -- TODO: markAnnList? + an0 <- markLensFun' an lal_rest markEpToken + an1 <- markLensBracketsO an0 lal_brackets + an2 <- markEpAnnAllLT an1 lal_semis + a' <- markAnnotated a + an3 <- markLensBracketsC an2 lal_brackets + return (L an3 a') + +instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an stmts) = do + debugM $ "LocatedL [ExprLStmt" + (an'', stmts') <- markAnnList an $ do + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + markAnnotated stmts + return (L an'' stmts') + +instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L ann es) = do + debugM $ "LocatedL [CmdLStmt" + an0 <- markLensBracketsO ann lal_brackets + es' <- mapM markAnnotated es + an1 <- markLensBracketsC an0 lal_brackets + return (L an1 es') + +instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an fs) = do + debugM $ "LocatedL [LConDeclField" + (an', fs') <- markAnnList an (markAnnotated fs) + return (L an' fs') + +instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an bf) = do + debugM $ "LocatedL [LBooleanFormula" + (an', bf') <- markAnnList an (markAnnotated bf) + return (L an' bf') + +-- --------------------------------------------------------------------- +-- LocatedL instances end -- +-- ===================================================================== + +instance ExactPrint (IE GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IEVar depr ln doc) = do + depr' <- markAnnotated depr + ln' <- markAnnotated ln + doc' <- markAnnotated doc + return (IEVar depr' ln' doc') + exact (IEThingAbs depr thing doc) = do + depr' <- markAnnotated depr + thing' <- markAnnotated thing + doc' <- markAnnotated doc + return (IEThingAbs depr' thing' doc') + exact (IEThingAll (depr, (op,dd,cp)) thing doc) = do + depr' <- markAnnotated depr + thing' <- markAnnotated thing + op' <- markEpToken op + dd' <- markEpToken dd + cp' <- markEpToken cp + doc' <- markAnnotated doc + return (IEThingAll (depr', (op',dd',cp')) thing' doc') + + exact (IEThingWith (depr, (op,dd,c,cp)) thing wc withs doc) = do + depr' <- markAnnotated depr + thing' <- markAnnotated thing + op' <- markEpToken op + (dd',c', wc', withs') <- + case wc of + NoIEWildcard -> do + withs'' <- markAnnotated withs + return (dd, c, wc, withs'') + IEWildcard pos -> do + let (bs, as) = splitAt pos withs + bs' <- markAnnotated bs + dd' <- markEpToken dd + c' <- markEpToken c + as' <- markAnnotated as + return (dd',c', wc, bs'++as') + cp' <- markEpToken cp + doc' <- markAnnotated doc + return (IEThingWith (depr', (op',dd',c',cp')) thing' wc' withs' doc') + + exact (IEModuleContents (depr, an) m) = do + depr' <- markAnnotated depr + an0 <- markEpToken an + m' <- markAnnotated m + return (IEModuleContents (depr', an0) m') + + -- These three exist to not error out, but are no-ops The contents + -- appear as "normal" comments too, which we process instead. + exact (IEGroup x lev doc) = do + return (IEGroup x lev doc) + exact (IEDoc x doc) = do + return (IEDoc x doc) + exact (IEDocNamed x str) = do + return (IEDocNamed x str) + +-- --------------------------------------------------------------------- + +instance ExactPrint (IEWrappedName GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IEName x n) = do + n' <- markAnnotated n + return (IEName x n') + exact (IEDefault r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEDefault r' n') + exact (IEPattern r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEPattern r' n') + exact (IEType r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEType r' n') + +-- --------------------------------------------------------------------- + +instance ExactPrint (Pat GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (WildPat w) = do + anchor' <- getAnchorU + debugM $ "WildPat:anchor'=" ++ show anchor' + _ <- printStringAtRs anchor' "_" + return (WildPat w) + exact (VarPat x n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered. + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (VarPat x n') + exact (LazyPat an pat) = do + an0 <- markEpToken an + pat' <- markAnnotated pat + return (LazyPat an0 pat') + exact (AsPat at n pat) = do + n' <- markAnnotated n + at' <- markEpToken at + pat' <- markAnnotated pat + return (AsPat at' n' pat') + exact (ParPat (lpar, rpar) pat) = do + lpar' <- markEpToken lpar + pat' <- markAnnotated pat + rpar' <- markEpToken rpar + return (ParPat (lpar', rpar') pat') + + exact (BangPat an pat) = do + an0 <- markEpToken an + pat' <- markAnnotated pat + return (BangPat an0 pat') + + exact (ListPat an pats) = do + (an', pats') <- markAnnList' an (markAnnotated pats) + return (ListPat an' pats') + + exact (TuplePat (o,c) pats boxity) = do + o0 <- case boxity of + Boxed -> printStringAtAA o "(" + Unboxed -> printStringAtAA o "(#" + pats' <- markAnnotated pats + c0 <- case boxity of + Boxed -> printStringAtAA c ")" + Unboxed -> printStringAtAA c "#)" + return (TuplePat (o0,c0) pats' boxity) + + exact (SumPat an pat alt arity) = do + an0 <- markLensFun an (lsumPatParens . lfst) (\loc -> printStringAtAA loc "(#") + an1 <- markLensFun an0 lsumPatVbarsBefore (\locs -> mapM markEpToken locs) + pat' <- markAnnotated pat + an2 <- markLensFun an1 lsumPatVbarsAfter (\locs -> mapM markEpToken locs) + an3 <- markLensFun an2 (lsumPatParens . lsnd) (\loc -> printStringAtAA loc "#)") + return (SumPat an3 pat' alt arity) + + exact (OrPat an pats) = do + pats' <- markAnnotated (NE.toList pats) + return (OrPat an (NE.fromList pats')) + + exact (ConPat an con details) = do + (an', con', details') <- exactUserCon an con details + return (ConPat an' con' details') + exact (ViewPat tokarr expr pat) = do + expr' <- markAnnotated expr + an0 <- markEpUniToken tokarr + pat' <- markAnnotated pat + return (ViewPat an0 expr' pat') + exact (SplicePat x splice) = do + splice' <- markAnnotated splice + return (SplicePat x splice') + exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p + exact (NPat an ol mn z) = do + an0 <- if (isJust mn) + then markEpToken an + else return an + ol' <- markAnnotated ol + return (NPat an0 ol' mn z) + + exact (NPlusKPat an n k lit2 a b) = do + n' <- markAnnotated n + an' <- markEpToken an + k' <- markAnnotated k + return (NPlusKPat an' n' k' lit2 a b) + + exact (SigPat an pat sig) = do + pat' <- markAnnotated pat + an0 <- markEpUniToken an + sig' <- markAnnotated sig + return (SigPat an0 pat' sig') + + exact (EmbTyPat toktype tp) = do + toktype' <- markEpToken toktype + tp' <- markAnnotated tp + return (EmbTyPat toktype' tp') + + exact (InvisPat (tokat, spec) tp) = do + tokat' <- markEpToken tokat + tp' <- markAnnotated tp + pure (InvisPat (tokat', spec) tp') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsPatSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsPS an ty) = do + ty' <- markAnnotated ty + return (HsPS an ty') + +instance ExactPrint (HsTyPat GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsTP an ty) = do + ty' <- markAnnotated ty + return (HsTP an ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsOverLit GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + 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 (unpackFS s) >> return ol + NoSourceText -> return ol + +-- --------------------------------------------------------------------- + +hsLit2String :: HsLit GhcPs -> String +hsLit2String lit = + case lit of + HsChar src v -> toSourceTextWithSuffix src v "" + HsCharPrim src p -> toSourceTextWithSuffix src p "" + HsString src v -> toSourceTextWithSuffix src v "" + HsMultilineString 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 "" + HsInt8Prim src v -> toSourceTextWithSuffix src v "" + HsInt16Prim src v -> toSourceTextWithSuffix src v "" + HsInt32Prim src v -> toSourceTextWithSuffix src v "" + HsInt64Prim src v -> toSourceTextWithSuffix src v "" + HsWord8Prim src v -> toSourceTextWithSuffix src v "" + HsWord16Prim src v -> toSourceTextWithSuffix src v "" + HsWord32Prim 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 "##" + +toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String +toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix +toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix + +sourceTextToString :: SourceText -> String -> String +sourceTextToString NoSourceText alt = alt +sourceTextToString (SourceText txt) _ = unpackFS txt + +-- --------------------------------------------------------------------- + +exactUserCon :: (Monad m, Monoid w, ExactPrint con) + => (Maybe (EpToken "{"), Maybe (EpToken "}")) -> con -> HsConPatDetails GhcPs + -> EP w m ((Maybe (EpToken "{"), Maybe (EpToken "}")), con, HsConPatDetails GhcPs) +exactUserCon an c (InfixCon p1 p2) = do + p1' <- markAnnotated p1 + c' <- markAnnotated c + p2' <- markAnnotated p2 + return (an, c', InfixCon p1' p2') +exactUserCon (open,close) c details = do + c' <- markAnnotated c + open' <- mapM markEpToken open + details' <- exactConArgs details + close' <- mapM markEpToken close + return ((open', close'), c', details') + +instance ExactPrint (HsConPatTyArg GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsConPatTyArg at tyarg) = do + at' <- markEpToken at + tyarg' <- markAnnotated tyarg + return (HsConPatTyArg at' tyarg') + +exactConArgs :: (Monad m, Monoid w) + => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) +exactConArgs (PrefixCon tyargs pats) = do + tyargs' <- markAnnotated tyargs + pats' <- markAnnotated pats + return (PrefixCon tyargs' pats') +exactConArgs (InfixCon p1 p2) = do + p1' <- markAnnotated p1 + p2' <- markAnnotated p2 + return (InfixCon p1' p2') +exactConArgs (RecCon rpats) = do + rpats' <- markAnnotated rpats + return (RecCon rpats') + +-- --------------------------------------------------------------------- + +entryFromLocatedA :: (HasTrailing ann) => LocatedAn ann a -> Entry +entryFromLocatedA (L la _) = fromAnn 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 + p' <- getPosP + d <- getPriorEndD + debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',d,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 + +-- | Print a comment, using the current layout offset to convert the +-- @DeltaPos@ to an absolute position. +printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +printQueuedComment Comment{commentContents} dp = do + p <- getPosP + d <- getPriorEndD + 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 + p' <- getPosP + d' <- getPriorEndD + debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d') + debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) + +------------------------------------------------------------------------ + +setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a +setLayoutBoth k = do + oldLHS <- getLayoutOffsetD + 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 a -> EP w m a +setLayoutTopLevelP k = do + debugM $ "setLayoutTopLevelP entered" + oldAnchorOffset <- getLayoutOffsetP + modify (\a -> a { pMarkLayout = False + , pLHS = 0} ) + r <- k + debugM $ "setLayoutTopLevelP:resetting" + setLayoutOffsetP oldAnchorOffset + return r + +------------------------------------------------------------------------ + +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 EpaLocation) +getExtraDP = gets uExtraDP + +setExtraDP :: (Monad m, Monoid w) => Maybe EpaLocation -> EP w m () +setExtraDP md = do + debugM $ "setExtraDP:" ++ show md + modify (\s -> s {uExtraDP = md}) + +getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe (SrcSpan, DeltaPos)) +getExtraDPReturn = gets uExtraDPReturn + +setExtraDPReturn :: (Monad m, Monoid w) => Maybe (SrcSpan, DeltaPos) -> EP w m () setExtraDPReturn md = do debugM $ "setExtraDPReturn:" ++ show md modify (\s -> s {uExtraDPReturn = md}) diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Language.Haskell.GHC.ExactPrint.Lookup - ( - keywordToString - , AnnKeywordId(..) - , Comment(..) - ) where - -import GHC (AnnKeywordId(..)) -import Language.Haskell.GHC.ExactPrint.Types - --- | Maps `AnnKeywordId` to the corresponding String representation. --- There is no specific mapping for the following constructors. --- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`, --- `AnnInfix` -keywordToString :: AnnKeywordId -> String -keywordToString kw = - let mkErr x = error $ "keywordToString: missing case for:" ++ show x - in - case kw of - -- Specifically handle all cases so that there are pattern match - -- warnings if new constructors are added. - AnnAnyclass -> "anyclass" - AnnOpen -> mkErr kw - AnnClose -> mkErr kw - AnnVal -> mkErr kw - AnnPackageName -> mkErr kw - AnnHeader -> mkErr kw - AnnFunId -> mkErr kw - AnnInfix -> mkErr kw - AnnValStr -> mkErr kw - AnnName -> mkErr kw - AnnAs -> "as" - AnnBang -> "!" - AnnBackquote -> "`" - AnnBy -> "by" - AnnCase -> "case" - AnnCases -> "cases" - AnnClass -> "class" - AnnCloseB -> "|)" - AnnCloseBU -> "⦈" - AnnCloseC -> "}" - AnnCloseP -> ")" - AnnClosePH -> "#)" - AnnCloseQ -> "|]" - AnnCloseQU -> "⟧" - AnnCloseS -> "]" - AnnColon -> ":" - AnnComma -> "," - AnnCommaTuple -> "," - AnnDarrow -> "=>" - AnnData -> "data" - AnnDcolon -> "::" - AnnDefault -> "default" - AnnDeriving -> "deriving" - AnnDo -> "do" - AnnDot -> "." - AnnDotdot -> ".." - AnnElse -> "else" - AnnEqual -> "=" - AnnExport -> "export" - AnnFamily -> "family" - AnnForall -> "forall" - AnnForeign -> "foreign" - AnnGroup -> "group" - AnnHiding -> "hiding" - AnnIf -> "if" - AnnImport -> "import" - AnnIn -> "in" - AnnInstance -> "instance" - AnnLam -> "\\" - AnnLarrow -> "<-" - AnnLet -> "let" - AnnLollyU -> "⊸" - AnnMdo -> "mdo" - AnnMinus -> "-" - AnnModule -> "module" - AnnNewtype -> "newtype" - AnnOf -> "of" - AnnOpenB -> "(|" - AnnOpenBU -> "⦇" - AnnOpenC -> "{" - AnnOpenE -> "[e|" - AnnOpenEQ -> "[|" - AnnOpenEQU -> "⟦" - AnnOpenP -> "(" - AnnOpenPH -> "(#" - AnnOpenS -> "[" - AnnPattern -> "pattern" - AnnPercent -> "%" - AnnPercentOne -> "%1" - AnnProc -> "proc" - AnnQualified -> "qualified" - AnnRarrow -> "->" - AnnRec -> "rec" - AnnRole -> "role" - AnnSafe -> "safe" - AnnSemi -> ";" - AnnSignature -> "signature" - AnnStock -> "stock" - AnnStatic -> "static" - AnnThen -> "then" - AnnTilde -> "~" - AnnType -> "type" - AnnUnit -> "()" - AnnUsing -> "using" - AnnVbar -> "|" - AnnWhere -> "where" - Annlarrowtail -> "-<" - Annrarrowtail -> ">-" - AnnLarrowtail -> "-<<" - AnnRarrowtail -> ">>-" - AnnSimpleQuote -> "'" - AnnThTyQuote -> "''" - AnnDollar -> "$" - AnnDollarDollar -> "$$" - AnnDarrowU -> "⇒" - AnnDcolonU -> "∷" - AnnForallU -> "∀" - AnnLarrowU -> "←" - AnnLarrowtailU -> "⤛" - AnnRarrowU -> "→" - AnnRarrowtailU -> "⤜" - AnnlarrowtailU -> "⤙" - AnnrarrowtailU -> "⤚" - 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 @@ -289,7 +289,8 @@ let pc = GHC.priorComments cs fc = GHC.getFollowingComments cs - bf (GHC.L anc _) = GHC.anchor anc > ss + bf (GHC.L anc _) = GHC.epaLocationRealSrcSpan anc > ss + (prior,f) = break bf fc cs'' = GHC.EpaCommentsBalanced (pc <> prior) f in cs'' @@ -310,7 +311,7 @@ -- Move any comments on the decl that occur prior to the location pc = GHC.priorComments csd fc = GHC.getFollowingComments csd - bf (GHC.L anch _) = GHC.anchor anch > r + bf (GHC.L anch _) = GHC.epaLocationRealSrcSpan anch > r (move,keep) = break bf pc csd' = GHC.EpaCommentsBalanced keep fc @@ -326,8 +327,8 @@ -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs') where - (ds1,cs') = case break (\(GHC.AddEpAnn k _) -> k == GHC.AnnWhere) (GHC.am_main an) of - (_, (GHC.AddEpAnn _ whereLoc:_)) -> + (ds1,cs') = case GHC.am_where an of + GHC.EpTok whereLoc -> case GHC.hsmodDecls p of (d:ds0) -> (d':ds0, cs0) where (d',cs0) = moveComments whereLoc d cs 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 @@ -24,7 +24,6 @@ import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC -import qualified GHC.Fingerprint.Type as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Settings as GHC import qualified GHC.Types.Error as GHC @@ -232,24 +231,32 @@ $ msgs injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags -injectCppOptions CppOptions{..} dflags = - foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile) +injectCppOptions CppOptions{..} dflags = folded_opt where mkDefine = ("-D" ++) mkIncludeDir = ("-I" ++) mkInclude = ("-include" ++) - + file_flags = map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile + addFs = [addOptP, addOptJSP, addOptCmmP] + folded_opt = foldr ($) dflags (addFs <*> file_flags) addOptP :: String -> GHC.DynFlags -> GHC.DynFlags addOptP f = alterToolSettings $ \s -> s { GHC.toolSettings_opt_P = f : GHC.toolSettings_opt_P s - , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s) + , GHC.toolSettings_opt_P_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_P s) } +addOptJSP :: String -> GHC.DynFlags -> GHC.DynFlags +addOptJSP f = alterToolSettings $ \s -> s + { GHC.toolSettings_opt_JSP = f : GHC.toolSettings_opt_JSP s + , GHC.toolSettings_opt_JSP_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_JSP s) + } +addOptCmmP :: String -> GHC.DynFlags -> GHC.DynFlags +addOptCmmP f = alterToolSettings $ \s -> s + { GHC.toolSettings_opt_CmmP = f : GHC.toolSettings_opt_CmmP s + , GHC.toolSettings_opt_CmmP_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_CmmP s) + } alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) } - -fingerprintStrings :: [String] -> GHC.Fingerprint -fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss -- --------------------------------------------------------------------- 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,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -91,7 +92,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) -import GHC.Data.Bag import GHC.Data.FastString import GHC.Types.SrcLoc @@ -204,17 +204,18 @@ -- --------------------------------------------------------------------- captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs -captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig dc rs') ns (HsWC xw ty)))) - = (L l (SigD x (TypeSig (AnnSig dc' rs') ns (HsWC xw ty')))) +captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig NoEpUniTok mp md) ns (HsWC xw ty)))) + = (L l (SigD x (TypeSig (AnnSig NoEpUniTok mp md) ns (HsWC xw ty)))) +captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns (HsWC xw ty)))) + = (L l (SigD x (TypeSig (AnnSig (EpUniTok dca' u) mp md) 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 (EpAnn anc' _ _) _ -> anchor anc' -- TODO MovedAnchor? - dc' = case dca of - EpaSpan (RealSrcSpan r _) -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) - _ -> AddEpAnn kw dca + L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc' + dca' = case dca of + EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) []) + _ -> dca -- --------------------------------- @@ -223,10 +224,10 @@ (L (EpAnn anc0 a c) b) -> let anc' = case anc0 of - EpaDelta _ _ -> anc0 + EpaDelta _ _ _ -> anc0 _ -> case dca of - EpaSpan _ -> EpaDelta (SameLine 1) [] - EpaDelta _ cs0 -> EpaDelta (SameLine 1) cs0 + EpaSpan ss -> EpaDelta ss (SameLine 1) [] + EpaDelta ss _ cs0 -> EpaDelta ss (SameLine 1) cs0 in (L (EpAnn anc' a c) b) captureTypeSigSpacing s = s @@ -249,19 +250,22 @@ -- |Set the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments. setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a -setEntryDP (L (EpAnn (EpaSpan (UnhelpfulSpan _)) an cs) a) dp - = L (EpAnn (EpaDelta dp []) an cs) a -setEntryDP (L (EpAnn (EpaSpan _) an (EpaComments [])) a) dp - = L (EpAnn (EpaDelta dp []) an (EpaComments [])) a -setEntryDP (L (EpAnn (EpaDelta d csd) an cs) a) dp - = L (EpAnn (EpaDelta d' csd') an cs') a +setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp + = L (EpAnn (EpaDelta ss dp []) an cs) a +setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp + = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a +setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp + = L (EpAnn (EpaDelta ss d' csd') an cs') a where + -- I suspect we should assume the comments are already in the + -- right place, and just set the entry DP for this case. This + -- avoids suprises from the caller. (d', csd', cs') = case cs of EpaComments (h:t) -> let (dp0,c') = go h in - (dp0, c':t++csd, EpaComments []) + (dp0, csd, EpaComments (c':t)) EpaComments [] -> (dp, csd, cs) EpaCommentsBalanced (h:t) ts -> @@ -278,67 +282,73 @@ in (dp0, c':t, EpaCommentsBalanced [] ts) go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e) - go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c) - go (L (EpaSpan _) c) = (d, L (EpaDelta dp NoComments) c) -setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp + go (L (EpaDelta ss0 _ c0) c) = (d, L (EpaDelta ss0 dp c0) c) + go (L (EpaSpan ss0) c) = (d, L (EpaDelta ss0 dp NoComments) c) +setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp = case sortEpaComments (priorComments cs) of [] -> - L (EpAnn (EpaDelta dp []) an cs) a + L (EpAnn (EpaDelta ss dp []) an cs) a (L ca c:cs') -> - L (EpAnn (EpaDelta edp csd) an cs'') a + L (EpAnn (EpaDelta ss edp csd) an cs'') a where cs'' = setPriorComments cs [] - csd = L (EpaDelta dp NoComments) c:commentOrigDeltas cs' + csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs' lc = last $ (L ca c:cs') delta = case getLoc lc of EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r EpaSpan _ -> (SameLine 0) - EpaDelta _dp _ -> DifferentLine 1 0 + EpaDelta _ _dp _ -> DifferentLine 1 0 line = getDeltaLine delta col = deltaColumn delta edp' = if line == 0 then SameLine col else DifferentLine line col - edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r)) + edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ epaLocationRealSrcSpan $ getLoc lc), r)) -- --------------------------------------------------------------------- getEntryDP :: LocatedAn t a -> DeltaPos -getEntryDP (L (EpAnn (EpaDelta dp _) _ _) _) = dp +getEntryDP (L (EpAnn (EpaDelta _ dp _) _ _) _) = dp getEntryDP _ = SameLine 1 -- --------------------------------------------------------------------- addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation -addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs -addEpaLocationDelta _off _anc (EpaSpan (UnhelpfulSpan _)) = EpaDelta (SameLine 0) [] -addEpaLocationDelta off anc (EpaSpan (RealSrcSpan r _)) - = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] +addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs +addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) [] +addEpaLocationDelta off anc (EpaSpan ss@(RealSrcSpan r _)) + = EpaDelta ss (adjustDeltaForOffset 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 (EpaDelta _ _ _) (L la a) = L la a setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp' where dp' = case la of (EpAnn (EpaSpan (RealSrcSpan r' _)) _ _) -> adjustDeltaForOffset off (ss2deltaEnd anc r') (EpAnn (EpaSpan _) _ _) -> adjustDeltaForOffset off (SameLine 0) - (EpAnn (EpaDelta dp _) _ _) -> adjustDeltaForOffset off dp + (EpAnn (EpaDelta _ dp _) _ _) -> adjustDeltaForOffset off dp -- --------------------------------------------------------------------- --- |Take the annEntryDelta associated with the first item and associate it with the second. --- Also transfer any comments occurring before it. +-- |Take the annEntryDelta associated with the first item and +-- associate it with the second. Also transfer any comments occurring +-- before it. transferEntryDP :: (Typeable t1, Typeable t2) => LocatedAn t1 a -> LocatedAn t2 b -> (LocatedAn t2 b) -transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn _anc2 an2 cs2) b) = +transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn anc2 an2 cs2) b) = + -- Note: the EpaDelta version of an EpaLocation contains the original + -- SrcSpan. We must preserve that. + let anc1' = case (anc1,anc2) of + (EpaDelta _ dp cs, EpaDelta ss2 _ _) -> EpaDelta ss2 dp cs + (_, _) -> anc1 -- Problem: if the original had preceding comments, blindly -- transferring the location is not correct - case priorComments cs1 of - [] -> (L (EpAnn anc1 (combine an1 an2) cs2) b) + in case priorComments cs1 of + [] -> (L (EpAnn anc1' (combine an1 an2) cs2) b) -- TODO: what happens if the receiving side already has comments? - (L _ _:_) -> (L (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) b) + (L _ _:_) -> (L (EpAnn anc1' (combine an1 an2) (cs1 <> cs2)) b) -- |If a and b are the same type return first arg, else return second @@ -368,9 +378,14 @@ -- --------------------------------------------------------------------- --- | If we compile in haddock mode we get DocDecls, which we strip out --- while exact printing. Make sure we do not balance any comments on --- to them be stripping them out here already. +-- | If we compile in haddock mode, the haddock processing inserts +-- DocDecls to carry the Haddock Documentation. We ignore these in +-- exact printing, as all the comments are also available in their +-- normal location, and the haddock processing is lossy, in that it +-- does not preserve all haddock-like comments. When we balance +-- comments in a list, we migrate some to preceding or following +-- declarations in the list. We must make sure we do not move any to +-- these DocDecls, which are not printed. balanceCommentsList :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] balanceCommentsList decls = balanceCommentsList' (filter notDocDecl decls) @@ -486,7 +501,7 @@ (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds) vb = case replaceDeclsValbinds w lb (reverse decls') of (HsValBinds _ vb') -> vb' - _ -> ValBinds NoAnnSortKey emptyBag [] + _ -> ValBinds NoAnnSortKey [] [] balanceCommentsListA :: [LocatedA a] -> [LocatedA a] @@ -544,15 +559,15 @@ trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] trailingCommentsDeltas _ [] = [] -trailingCommentsDeltas r (la@(L (EpaDelta dp _) _):las) +trailingCommentsDeltas r (la@(L (EpaDelta _ dp _) _):las) = (getDeltaLine dp, la): trailingCommentsDeltas r las trailingCommentsDeltas r (la@(L l _):las) - = deltaComment r la : trailingCommentsDeltas (anchor l) las + = deltaComment r la : trailingCommentsDeltas (epaLocationRealSrcSpan l) las where deltaComment rs' (L loc c) = (abs(ll - al), L loc c) where (al,_) = ss2posEnd rs' - (ll,_) = ss2pos (anchor loc) + (ll,_) = ss2pos (epaLocationRealSrcSpan loc) priorCommentsDeltas :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] @@ -560,14 +575,14 @@ where go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] go _ [] = [] - go _ (la@(L l@(EpaDelta dp _) _):las) = (deltaLine dp, la) : go (anchor l) las - go rs' (la@(L l _):las) = deltaComment rs' la : go (anchor l) las + go _ (la@(L l@(EpaDelta _ dp _) _):las) = (getDeltaLine dp, la) : go (epaLocationRealSrcSpan l) las + go rs' (la@(L l _):las) = deltaComment rs' la : go (epaLocationRealSrcSpan l) las deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment) deltaComment rs' (L loc c) = (abs(ll - al), L loc c) where (al,_) = ss2pos rs' - (ll,_) = ss2pos (anchor loc) + (ll,_) = ss2pos (epaLocationRealSrcSpan loc) -- --------------------------------------------------------------------- @@ -656,18 +671,17 @@ addCommentOrigDeltasAnn :: (EpAnn a) -> (EpAnn a) 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 (EpAnn anc _ _) _) = anchor anc +anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc -- | Get the full span of interest for comments from a LocatedA. -- This extends up to the last TrailingAnn fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan fullSpanFromLocatedA (L (EpAnn anc (AnnListItem tas) _) _) = rr where - r = anchor anc + r = epaLocationRealSrcSpan anc trailing_loc ta = case ta_location ta of EpaSpan (RealSrcSpan s _) -> [s] _ -> [] @@ -691,7 +705,7 @@ (csp,csf) = case anc1 of EpaComments cs -> ([],cs) EpaCommentsBalanced p f -> (p,f) - (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchor anc) csf) + (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (epaLocationRealSrcSpan anc) csf) move = map snd move' stay = map snd stay' cs1 = epaCommentsBalanced csp stay @@ -715,7 +729,7 @@ -- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the -- given @DeltaPos@. noAnnSrcSpanDP :: (NoAnn ann) => DeltaPos -> EpAnn ann -noAnnSrcSpanDP dp = EpAnn (EpaDelta dp []) noAnn emptyComments +noAnnSrcSpanDP dp = EpAnn (EpaDelta noSrcSpan dp []) noAnn emptyComments noAnnSrcSpanDP0 :: (NoAnn ann) => EpAnn ann noAnnSrcSpanDP0 = noAnnSrcSpanDP (SameLine 0) @@ -727,17 +741,17 @@ noAnnSrcSpanDPn s = noAnnSrcSpanDP (SameLine s) d0 :: EpaLocation -d0 = EpaDelta (SameLine 0) [] +d0 = EpaDelta noSrcSpan (SameLine 0) [] d1 :: EpaLocation -d1 = EpaDelta (SameLine 1) [] +d1 = EpaDelta noSrcSpan (SameLine 1) [] dn :: Int -> EpaLocation -dn n = EpaDelta (SameLine n) [] +dn n = EpaDelta noSrcSpan (SameLine n) [] addComma :: SrcSpanAnnA -> SrcSpanAnnA addComma (EpAnn anc (AnnListItem as) cs) - = EpAnn anc (AnnListItem (AddCommaAnn d0:as)) cs + = EpAnn anc (AnnListItem (AddCommaAnn (EpTok d0):as)) cs -- --------------------------------------------------------------------- @@ -807,7 +821,7 @@ hsDecls :: t -> [LHsDecl GhcPs] -- | Replace the directly enclosed decl list by the given - -- decl list. As parto of replacing it will update list order + -- decl list. As part of replacing it will 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 @@ -886,8 +900,8 @@ off = case l of (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 - (EpaDelta (SameLine _) _) -> LayoutStartCol 0 - (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c + (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0 + (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex newDecls'' = case newDecls of [] -> newDecls @@ -1065,7 +1079,7 @@ = let oldSpan = spanHsLocaLBinds b an = oldWhereAnnotation a w (realSrcSpan oldSpan) - decs = listToBag $ concatMap decl2Bind new + decs = concatMap decl2Bind new sigs = concatMap decl2Sig new sortKey = captureOrderBinds new in (HsValBinds an (ValBinds sortKey decs sigs)) @@ -1073,40 +1087,39 @@ replaceDeclsValbinds w (EmptyLocalBinds _) new = let an = newWhereAnnotation w - newBinds = concatMap decl2Bind new - newSigs = concatMap decl2Sig new - decs = listToBag $ newBinds - sigs = newSigs + decs = concatMap decl2Bind new + sigs = concatMap decl2Sig new sortKey = captureOrderBinds new in (HsValBinds an (ValBinds sortKey decs sigs)) -oldWhereAnnotation :: EpAnn AnnList -> WithWhere -> RealSrcSpan -> (EpAnn AnnList) +oldWhereAnnotation :: EpAnn (AnnList (EpToken "where")) + -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where"))) oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an' -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, -- change the AnnList anchor to have the correct DP too where - (AnnList ancl o c _r t) = an + (AnnList ancl p s _r t) = an w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] - WithoutWhere -> [] + WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) + WithoutWhere -> NoEpTok (anc', ancl') = case ww of WithWhere -> (anc, ancl) WithoutWhere -> (anc, ancl) an' = EpAnn anc' - (AnnList ancl' o c w t) + (AnnList ancl' p s w t) cs -newWhereAnnotation :: WithWhere -> (EpAnn AnnList) +newWhereAnnotation :: WithWhere -> (EpAnn (AnnList (EpToken "where"))) newWhereAnnotation ww = an where - anc = EpaDelta (DifferentLine 1 3) [] - anc2 = EpaDelta (DifferentLine 1 5) [] + anc = EpaDelta noSrcSpan (DifferentLine 1 3) [] + anc2 = EpaDelta noSrcSpan (DifferentLine 1 5) [] w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] - WithoutWhere -> [] + WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) + WithoutWhere -> NoEpTok an = EpAnn anc - (AnnList (Just anc2) Nothing Nothing w []) + (AnnList (Just anc2) ListNone [] w []) emptyComments -- --------------------------------------------------------------------- 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 @@ -29,7 +29,7 @@ commentContents :: !String -- ^ The contents of the comment including separators , commentLoc :: !NoCommentsLocation , commentPriorTok :: !RealSrcSpan - , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. + , commentOrigin :: !(Maybe String) -- ^ We sometimes turn syntax into comments in order to process them properly. } deriving (Data, Eq) @@ -41,7 +41,7 @@ -- 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) + compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ epaLocationRealSrcSpan ss1) (ss2pos $ epaLocationRealSrcSpan ss2) where ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss) 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,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -59,9 +60,7 @@ import qualified GHC import GHC hiding (EpaComment) import GHC.Base (NonEmpty(..)) -import GHC.Data.Bag import GHC.Data.FastString -import qualified GHC.Data.Strict as Strict import GHC.Driver.Ppr import GHC.Hs.Dump import GHC.Parser.Lexer (allocateComments) @@ -69,7 +68,6 @@ import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import Language.Haskell.GHC.ExactPrint.Lookup import Language.Haskell.GHC.ExactPrint.Types import Debug.Trace @@ -169,13 +167,6 @@ fl = l + dl fc = co + dc -undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn -undeltaSpan anc kw dp = AddEpAnn kw (EpaSpan (RealSrcSpan sp Strict.Nothing)) - where - (l,c) = undelta (ss2pos anc) dp (LayoutStartCol 0) - len = length (keywordToString kw) - sp = range2rs ((l,c),(l,c+len)) - -- --------------------------------------------------------------------- adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos @@ -233,8 +224,8 @@ -- `MovedAnchor` operation based on the original location, only if it -- does not already have one. commentOrigDelta :: LEpaComment -> LEpaComment -commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp)) - = (L (EpaDelta dp NoComments) (GHC.EpaComment t pp)) +commentOrigDelta (L (EpaSpan ss@(RealSrcSpan la _)) (GHC.EpaComment t pp)) + = (L (EpaDelta ss dp NoComments) (GHC.EpaComment t pp)) `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp)) where (r,c) = ss2posEnd pp @@ -275,7 +266,7 @@ addCommentsListItem :: EpAnn AnnListItem -> State [LEpaComment] (EpAnn AnnListItem) addCommentsListItem = addComments - addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) + addCommentsList :: EpAnn (AnnList ()) -> State [LEpaComment] (EpAnn (AnnList ())) addCommentsList = addComments addCommentsGrhs :: EpAnn GrhsAnn -> State [LEpaComment] (EpAnn GrhsAnn) @@ -306,7 +297,7 @@ (sortEpaComments $ fc ++ cs_after) where (cs_before,cs_after) - = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos $ anchor ac) ) + = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) @@ -322,7 +313,7 @@ Just _ -> -- We have a module name. Capture all comments up to the `where` let - (these, remaining) = splitOnWhere Before (am_main $ anns an) cs + (these, remaining) = splitOnWhere Before (am_where $ anns an) cs (EpAnn a anno ocs) = an :: EpAnn AnnsModule anm = EpAnn a anno (workInComments ocs these) in @@ -330,15 +321,15 @@ (an1,cs0a) = case lo of EpExplicitBraces (EpTok (EpaSpan (RealSrcSpan s _))) _close -> let - (stay,cs0a') = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos $ s)) cs0 + (stay,cs0a') = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ s)) cs0 cs' = workInComments (comments an0) stay in (an0 { comments = cs' }, cs0a') _ -> (an0,cs0) -- Deal with possible leading semis (an2, cs0b) = case am_decls $ anns an1 of - (AddSemiAnn (EpaSpan (RealSrcSpan s _)):_) -> (an1 {comments = cs'}, cs0b') + (AddSemiAnn (EpTok (EpaSpan (RealSrcSpan s _))):_) -> (an1 {comments = cs'}, cs0b') where - (stay,cs0b') = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos $ s)) cs0a + (stay,cs0b') = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ s)) cs0a cs' = workInComments (comments an1) stay _ -> (an1,cs0a) @@ -349,10 +340,10 @@ where hc1' = workInComments (comments an2) csh' an3' = an2 { comments = hc1' } - (csh', cs0b') = case al_open $ anns l of - Just (AddEpAnn _ (EpaSpan (RealSrcSpan s _))) ->(h, n) + (csh', cs0b') = case annListBracketsLocs $ al_brackets $ anns l of + (EpaSpan (RealSrcSpan s _),_) ->(h, n) where - (h,n) = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos s) ) + (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) cs0b _ -> ([], cs0b) @@ -366,9 +357,9 @@ -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = if null ( am_main $ anns an3) + (hc1,hc_cs) = if NoEpTok == (am_where $ anns an3) then (hc0,[]) - else splitOnWhere After (am_main $ anns an3) hc0 + else splitOnWhere After (am_where $ anns an3) hc0 hc2 = workInComments (comments an3) hc1 an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } @@ -384,16 +375,23 @@ cs4' = workInComments cs4 these (xs',rest') = allocPreceding xs rest +annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation) +annListBracketsLocs (ListParens o c) = (getEpTokenLoc o, getEpTokenLoc c) +annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c) +annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) +annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) +annListBracketsLocs ListNone = (noAnn, noAnn) + + data SplitWhere = Before | After -splitOnWhere :: SplitWhere -> [AddEpAnn] -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) -splitOnWhere _ [] csIn = (csIn,[]) -splitOnWhere w (AddEpAnn AnnWhere (EpaSpan (RealSrcSpan s _)):_) csIn = (hc, fc) + +splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) +splitOnWhere w (EpTok (EpaSpan (RealSrcSpan s _))) csIn = (hc, fc) where splitFunc Before anc_pos c_pos = c_pos < anc_pos splitFunc After anc_pos c_pos = anc_pos < c_pos - (hc,fc) = break (\(L ll _) -> splitFunc w (ss2pos $ anchor ll) (ss2pos s)) csIn -splitOnWhere _ (AddEpAnn AnnWhere _:_) csIn = (csIn, []) -splitOnWhere f (_:as) csIn = splitOnWhere f as csIn + (hc,fc) = break (\(L ll _) -> splitFunc w (ss2pos $ epaLocationRealSrcSpan ll) (ss2pos s)) csIn +splitOnWhere _ _ csIn = (csIn,[]) balanceFirstLocatedAComments :: [LocatedA a] -> ([LocatedA a], [LEpaComment]) balanceFirstLocatedAComments [] = ([],[]) @@ -403,7 +401,7 @@ EpaSpan (RealSrcSpan s _) -> (csd', hc) `debug` ("balanceFirstLocatedAComments: (csd,csd',attached,header)=" ++ showAst (csd,csd',attached,header)) where - (priors, inners) = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos s) ) + (priors, inners) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) (priorComments csd) pcds = priorCommentsDeltas' s priors (attached, header) = break (\(d,_c) -> d /= 1) pcds @@ -419,14 +417,14 @@ where go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] go _ [] = [] - go _ (la@(L l@(EpaDelta dp _) _):las) = (deltaLine dp, la) : go (anchor l) las - go rs' (la@(L l _):las) = deltaComment rs' la : go (anchor l) las + go _ (la@(L l@(EpaDelta _ dp _) _):las) = (getDeltaLine dp, la) : go (epaLocationRealSrcSpan l) las + go rs' (la@(L l _):las) = deltaComment rs' la : go (epaLocationRealSrcSpan l) las deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment) deltaComment rs' (L loc c) = (abs(ll - al), L loc c) where (al,_) = ss2pos rs' - (ll,_) = ss2pos (anchor loc) + (ll,_) = ss2pos (epaLocationRealSrcSpan loc) allocatePriorComments :: Pos @@ -434,7 +432,7 @@ -> ([LEpaComment], [LEpaComment]) allocatePriorComments ss_loc comment_q = let - cmp (L l _) = ss2pos (anchor l) <= ss_loc + cmp (L l _) = ss2pos (epaLocationRealSrcSpan l) <= ss_loc (newAnns,after) = partition cmp comment_q in (after, newAnns) @@ -451,7 +449,7 @@ EpTok (EpaSpan (RealSrcSpan s _)) -> ss2pos s _ -> (1,1) _ -> (1,1) - (new_before, new_after) = break (\(L ll _) -> (ss2pos $ anchor ll) > end_loc ) cs + (new_before, new_after) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > end_loc ) cs addTrailingComments end_loc' cur new = epaCommentsBalanced pc' fc' where @@ -462,8 +460,8 @@ (L ac _:_) -> (sortEpaComments $ pc ++ cs_before, sortEpaComments $ fc ++ cs_after) where (cs_before,cs_after) - = if (ss2pos $ anchor ac) > end_loc' - then break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos $ anchor ac) ) new + = if (ss2pos $ epaLocationRealSrcSpan ac) > end_loc' + then break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new else (new_before, new_after) -- --------------------------------------------------------------------- @@ -480,7 +478,7 @@ (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)] -hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment] +hsDocStringComments :: EpaLocation -> RealSrcSpan -> GHC.HsDocString -> [Comment] hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) = let decStr = printDecorator dec @@ -544,7 +542,7 @@ -- |Must compare without span filenames, for CPP injected comments with fake filename cmpComments :: Comment -> Comment -> Ordering -cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) +cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ epaLocationRealSrcSpan l1) (ss2pos $ epaLocationRealSrcSpan l2) -- |Sort, comparing without span filenames, for CPP injected comments with fake filename sortComments :: [Comment] -> [Comment] @@ -554,19 +552,16 @@ sortEpaComments :: [LEpaComment] -> [LEpaComment] sortEpaComments cs = sortBy cmp cs where - cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) + cmp (L l1 _) (L l2 _) = compare (ss2pos $ epaLocationRealSrcSpan l1) (ss2pos $ epaLocationRealSrcSpan l2) -- | Makes a comment which originates from a specific keyword. -mkKWComment :: AnnKeywordId -> NoCommentsLocation -> Comment -mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) - = Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) -mkKWComment kw (EpaSpan (UnhelpfulSpan _)) - = Comment (keywordToString kw) (EpaDelta (SameLine 0) NoComments) placeholderRealSpan (Just kw) -mkKWComment kw (EpaDelta dp cs) - = Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw) +mkKWComment :: String -> NoCommentsLocation -> Comment +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) +mkKWComment kw (EpaSpan (UnhelpfulSpan _)) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) +mkKWComment kw (EpaDelta ss dp cs) = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw) -sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a] -sortAnchorLocated = sortBy (compare `on` (anchor . getLoc)) +sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a] +sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc)) -- | Calculates the distance from the start of a string to the end of -- a string. @@ -602,25 +597,6 @@ -- --------------------------------------------------------------------- -trailingAnnLoc :: TrailingAnn -> EpaLocation -trailingAnnLoc (AddSemiAnn ss) = ss -trailingAnnLoc (AddCommaAnn ss) = ss -trailingAnnLoc (AddVbarAnn ss) = ss -trailingAnnLoc (AddDarrowAnn ss) = ss -trailingAnnLoc (AddDarrowUAnn ss) = ss - -setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn -setTrailingAnnLoc (AddSemiAnn _) ss = (AddSemiAnn ss) -setTrailingAnnLoc (AddCommaAnn _) ss = (AddCommaAnn ss) -setTrailingAnnLoc (AddVbarAnn _) ss = (AddVbarAnn ss) -setTrailingAnnLoc (AddDarrowAnn _) ss = (AddDarrowAnn ss) -setTrailingAnnLoc (AddDarrowUAnn _) ss = (AddDarrowUAnn ss) - -addEpAnnLoc :: AddEpAnn -> EpaLocation -addEpAnnLoc (AddEpAnn _ l) = l - --- --------------------------------------------------------------------- - type DeclsByTag a = Map.Map DeclTag [(RealSrcSpan, a)] orderedDecls @@ -657,7 +633,7 @@ decls = orderedDecls sortKey $ Map.fromList [(ClsSigTag, map (\(L l s) -> (srs l, L l (SigD noExtField s))) sigs), - (ClsMethodTag, map (\(L l s) -> (srs l, L l (ValD noExtField s))) (bagToList methods)), + (ClsMethodTag, map (\(L l s) -> (srs l, L l (ValD noExtField s))) methods), (ClsAtTag, map (\(L l s) -> (srs l, L l (TyClD noExtField $ FamDecl noExtField s))) ats), (ClsAtdTag, map (\(L l s) -> (srs l, L l (InstD noExtField $ TyFamInstD noExtField s))) at_defs) ] @@ -681,12 +657,12 @@ [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) partitionWithSortKey = go where - go [] = ([], emptyBag, [], [], [], [], []) + go [] = ([], [], [], [], [], [], []) go ((L l decl) : ds) = let (tags, bs, ss, ts, tfis, dfis, docs) = go ds in case decl of ValD _ b - -> (ClsMethodTag:tags, L l b `consBag` bs, ss, ts, tfis, dfis, docs) + -> (ClsMethodTag:tags, L l b : bs, ss, ts, tfis, dfis, docs) SigD _ s -> (ClsSigTag:tags, bs, L l s : ss, ts, tfis, dfis, docs) TyClD _ (FamDecl _ t) @@ -724,7 +700,7 @@ hsDeclsLocalBinds lb = case lb of HsValBinds _ (ValBinds sortKey bs sigs) -> let - bds = map wrapDecl (bagToList bs) + bds = map wrapDecl bs sds = map wrapSig sigs in orderedDeclsBinds sortKey bds sds @@ -735,7 +711,7 @@ hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs] hsDeclsValBinds (ValBinds sortKey bs sigs) = let - bds = map wrapDecl (bagToList bs) + bds = map wrapDecl bs sds = map wrapSig sigs in orderedDeclsBinds sortKey bds sds diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,32 +28,34 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC98 - | GHC910 +data GHCVersion = GHC910 + | GHC912 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion -#if MIN_VERSION_ghc(9,10,0) -ghcVersion = GHC910 +#if MIN_VERSION_ghc(9,12,0) +ghcVersion = GHC912 #else -ghcVersion = GHC98 +ghcVersion = GHC910 #endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of - GHC98 -> ["pre-ghc910"] GHC910 -> ["pre-ghc910", "ghc910"] - -- GHC910 -> ["ghc910"] - -- GHC910 -> ["ghc910-copied"] - -- GHC910 -> ["ghc910", "ghc910-copied"] + GHC912 -> ["pre-ghc910", "ghc910", "ghc912"] + -- GHC912 -> ["ghc912"] + -- GHC912 -> ["ghc912-copied"] + -- GHC912 -> ["ghc912", "ghc912-copied"] -- --------------------------------------------------------------------- main :: IO () main = hSilence [stderr] $ do print ghcVersion + cwd <- getCurrentDirectory + putStrLn $ "cwd:" ++ show cwd tests <- mkTests cnts <- fst <$> runTestText (putTextToHandle stdout True) tests putStrLn $ show cnts @@ -206,8 +208,15 @@ -- mkParserTest libdir "ghc910" "CppComment.hs" -- mkParserTest libdir "ghc910" "Class.hs" -- mkParserTest libdir "ghc910" "Test138.hs" - mkParserTest libdir "vect" "DiophantineVect.hs" + -- mkParserTest libdir "vect" "DiophantineVect.hs" + -- mkParserTest libdir "pre-ghc910" "RandomPGC.hs" + + -- mkParserTest libdir "ghc912" "Module.hs" + -- mkParserTest libdir "ghc912" "tests.hs" + mkParserTestMD libdir "ghc912" "Fff.hs" + -- mkParserTestMD libdir "ghc912" "Module.hs" + -- mkParserTestMD libdir "ghc912" "Operator.hs" -- Needs GHC changes diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -13,7 +13,6 @@ 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 @@ -131,15 +130,17 @@ replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do - let anc = (EpaDelta (DifferentLine 1 3) []) - let anc2 = (EpaDelta (DifferentLine 1 5) []) + let anc = (EpaDelta noSrcSpan (DifferentLine 1 3) []) + let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 5) []) let an = EpAnn anc - (AnnList (Just anc2) Nothing Nothing - [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] []) + (AnnList (Just anc2) ListNone + [] + (EpTok (EpaDelta noSrcSpan (SameLine 0) [])) + []) emptyComments let decls = [s,d] let sortKey = captureOrderBinds decls - let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl']) + let binds = (HsValBinds an (ValBinds sortKey [decl'] [sig'])) return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds))) replaceLocalBinds x = return x @@ -159,7 +160,7 @@ 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 oldDecls = sortLocatedA $ map wrapDecl binds ++ map wrapSig sigs let decls = s:d:oldDecls let oldDecls' = captureLineSpacing oldDecls let oldBinds = concatMap decl2Bind oldDecls' @@ -167,11 +168,11 @@ os' = setEntryDP os (DifferentLine 2 0) let sortKey = captureOrderBinds decls let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (EpaDelta (DifferentLine 1 5) [])) a b c dd) cs) + let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 5) [])) a b c dd) cs) -- let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van -- let van' = (EpAnn anc (AnnList (Just (EpaDelta (DifferentLine 1 5) [])) a b c dd) cs) let binds' = (HsValBinds van' - (ValBinds sortKey (listToBag $ decl':oldBinds) + (ValBinds sortKey (decl':oldBinds) (sig':os':oldSigs))) return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) `debug` ("oldDecls=" ++ showAst oldDecls) @@ -263,13 +264,13 @@ replace :: HsExpr GhcPs -> HsExpr GhcPs replace (HsLet (tkLet, _) localDecls expr) = - let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls - [l2,_l1] = map wrapDecl $ bagToList bagDecls - bagDecls' = listToBag $ concatMap decl2Bind [l2] + let (HsValBinds x (ValBinds xv decls sigs)) = localDecls + [l2,_l1] = map wrapDecl decls + bagDecls' = concatMap decl2Bind [l2] (L _ e) = expr - a = EpAnn (EpaDelta (SameLine 1) []) noAnn emptyComments + a = EpAnn (EpaDelta noSrcSpan (SameLine 1) []) noAnn emptyComments expr' = L a e - tkIn' = EpTok (EpaDelta (DifferentLine 1 0) []) + tkIn' = EpTok (EpaDelta noSrcSpan (DifferentLine 1 0) []) in (HsLet (tkLet, tkIn') (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') @@ -463,6 +464,7 @@ let (lp',_,_w) = runTransform doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" return lp' + -- --------------------------------------------------------------------- rmDecl3 :: Changer @@ -471,9 +473,9 @@ doRmDecl = replaceDecls lp [de1',sd1,d2] where [de1,d2] = hsDecls lp - (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1] -> + (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a] -> let - sd1' = setEntryDP sd1 (DifferentLine 2 0) + sd1' = setEntryDP sd1a (DifferentLine 2 0) in ([],Just sd1') lp' = doRmDecl @@ -487,10 +489,10 @@ doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] where [de1] = hsDecls lp - (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> + (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] -> let - sd2' = transferEntryDP' sd1 sd2 - sd1' = setEntryDP sd1 (DifferentLine 2 0) + sd2' = transferEntryDP' sd1a sd2 + sd1' = setEntryDP sd1a (DifferentLine 2 0) in ([sd2'],Just sd1') lp' = doRmDecl return lp' @@ -505,9 +507,7 @@ go :: HsExpr GhcPs -> Transform (HsExpr GhcPs) go (HsLet (tkLet, tkIn) lb expr) = do let decs = hsDeclsLocalBinds lb - let hdecs : _ = decs let dec = last decs - -- _ <- transferEntryDP hdecs dec let lb' = replaceDeclsValbinds WithoutWhere lb [dec] return (HsLet (tkLet, tkIn) lb' expr) go x = return x @@ -593,9 +593,9 @@ v2 = L ( noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n2)) Nothing) impHiding = L (EpAnn d0 (AnnList Nothing - (Just (AddEpAnn AnnOpenP d1)) - (Just (AddEpAnn AnnCloseP d0)) - [(AddEpAnn AnnHiding d1)] + (ListParens (EpTok d1) (EpTok d0)) + [] + (EpTok d1, []) []) emptyComments) [v1,v2] imp1' = imp1 { ideclImportList = Just (EverythingBut,impHiding)} @@ -618,9 +618,9 @@ Just (_,L _lh ns) = ideclImportList imp1 lh' = (EpAnn d0 (AnnList Nothing - (Just (AddEpAnn AnnOpenP d1)) - (Just (AddEpAnn AnnCloseP d0)) - [(AddEpAnn AnnHiding d1)] + (ListParens (EpTok d1) (EpTok d0)) + [] + (EpTok d1, []) []) emptyComments) n1 = L (noAnnSrcSpanDP0) (mkVarUnqual (mkFastString "n1")) diff --git a/tests/examples/ghc910/ConPat.hs b/tests/examples/ghc910/ConPat.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/ConPat.hs @@ -0,0 +1,17 @@ +module ConPat where + + + + + + + + + + + + + + +yyy = let snd:fst:xs = flipFirst global + in f fst snd diff --git a/tests/examples/ghc910/Operator1.hs b/tests/examples/ghc910/Operator1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Operator1.hs @@ -0,0 +1,7 @@ +module Operator1 where + +main :: IO () +main = do + putStrLn $ show {- c3 -} $ {- c4 -} foo {- c1 -} || {- c2 -} bar + +{-# RULES "print" forall x. putStrLn $ show $ x = print $ x #-} diff --git a/tests/examples/ghc912/Fff.hs b/tests/examples/ghc912/Fff.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/Fff.hs @@ -0,0 +1,1 @@ +test = foo . not . not diff --git a/tests/examples/ghc912/Module.hs b/tests/examples/ghc912/Module.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/Module.hs @@ -0,0 +1,7 @@ +module Module where + +fff = do + let { + ; (a, b) = foo + } + pure () diff --git a/tests/examples/ghc912/Operator.hs b/tests/examples/ghc912/Operator.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/Operator.hs @@ -0,0 +1,54 @@ +module Operator where + +main :: IO () +main = do + print $ 3 + 4 + -- lets make sure + print $ foo || + -- that comments end up in the right place + bar || + baz && + -- even this one + quux + + -- lets also make sure + print $ foo + -- that these comments end up in the right place + || bar + || baz + -- even when the operator is leading + && quux + + return ({- comment -} x >= 1 || y >= 2) + + print $ foo || bar + print $ foo || bar + print $ foo || bar + print $ {- comment here -} foo || bar + print $ foo {- comment here -} || bar + print $ foo || {- comment here -} bar + print $ foo || bar {- comment here -} + + print $ foo || bar + print $ foo || bar + +{-# RULES "print" forall x. putStrLn $ show $ x = print $ x #-} + +f :: Int -> Bool +f x = x == 2 + +g :: Int -> Bool +g y = (y == 2) /= False + +roundtrip :: IO [a] +roundtrip = return $ mconcat + [ timeToText $ time_enrolled - mod time_enrolled t + , ":" + ] + +-- Ensure local fixity declarations are handled properly +(.@@@) :: (a -> b) -> a -> b +f .@@@ x = f x + +infixr 0 .@@@ +{-# RULES "printAt" forall x. putStrLn .@@@ show .@@@ x = print $ x #-} diff --git a/tests/examples/ghc912/T23501a.hs b/tests/examples/ghc912/T23501a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/T23501a.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, NoListTuplePuns #-} + +module T23501a where + +import Prelude.Experimental (List, Unit) +import Data.Kind (Type, Constraint) + +---------------------------- +-- Class declarations -- +---------------------------- + +class C1 (_ :: k) _ -- no SAKS + where f1 :: k -> Unit + +f1' :: C1 @k a b => k -> Unit +f1' @_ @a @b = f1 @_ @a @b + +type C2 :: k1 -> k2 -> Constraint +class C2 (_ :: k) _ where + f2 :: k -> Unit + +f2' :: C2 @k1 @k2 a b => k1 -> Unit +f2' @_ @_ @a @b = f2 @_ @_ @a @b + +type C3 :: k1 -> k2 -> Constraint +class C3 @k @_ _ _ where + f3 :: k -> Unit + +f3' :: C3 @k1 @k2 a b => k1 -> Unit +f3' @_ @_ @a @b = f3 @_ @_ @a @b + +--------------------------- +-- Data declarations -- +--------------------------- + +data D1 k (_ :: k) _ -- no SAKS + where MkD1 :: k -> D1 k a b + +mkD1 :: k -> D1 k a b +mkD1 = MkD1 + +type D2 :: forall (k1 :: Type) -> k1 -> k2 -> Type +data D2 k (_ :: k) _ where + MkD2 :: k -> D2 k a b + +mkD2 :: k -> D2 k a b +mkD2 = MkD2 + +type D3 :: k1 -> k2 -> Type +data D3 @k @_ _ _ = MkD3 k + +data MProxy (_ :: Type) = MPrx +data CProxy (_ :: k -> Constraint) = CPrx + +type Rec :: (k -> Type) -> List k -> Type +data Rec _ _ where + RNil :: Rec f [] + (:&) :: f x -> Rec f xs -> Rec f (x:xs) + +------------------ +-- Newtypes -- +------------------ + +newtype N1 k (_ :: k) _ -- no SAKS + = MkN1 k + +mkN1 :: k -> N1 k a b +mkN1 = MkN1 + +type N2 :: forall (k1 :: Type) -> k1 -> k2 -> Type +newtype N2 k (_ :: k) _ = MkN2 k + +mkN2 :: k -> N2 k a b +mkN2 = MkN2 + +---------------------------- +-- Open type families -- +---------------------------- + +type family OTF1 (_ :: Type -> Type) _ -- no SAKS + +type instance OTF1 f x = f x + +otf1 :: OTF1 Maybe Int -> Int +otf1 Nothing = 0 +otf1 (Just x) = x + +type OTF2 :: (Type -> Type) -> Type -> Type +type family OTF2 (_ :: Type -> Type) _ + +type instance OTF2 f x = f x + +otf2 :: OTF2 Maybe Int -> Int +otf2 Nothing = 0 +otf2 (Just x) = x + +------------------------------ +-- Closed type families -- +------------------------------ + +type family CTF1 (_ :: Type -> Type) _ -- no SAKS + where CTF1 f x = f x + +ctf1 :: CTF1 Maybe Int -> Int +ctf1 Nothing = 0 +ctf1 (Just x) = x + +type CTF2 :: (Type -> Type) -> Type -> Type +type family CTF2 (_ :: Type -> Type) _ where + CTF2 f x = f x + +ctf2 :: CTF2 Maybe Int -> Int +ctf2 Nothing = 0 +ctf2 (Just x) = x + +type CTF3 :: k1 -> k2 -> Type +type family CTF3 @_ @k _ _ + where CTF3 @_ @k _ _ = k + +ctf3 :: CTF3 a True -> Bool +ctf3 = id + +----------------------- +-- Type synonyms -- +----------------------- + +type T1 (_ :: Type -> Type) _ = () -- no SAKS + +type T2 :: (Type -> Type) -> k -> Type +type T2 (_ :: Type -> Type) _ = Unit + +type T3 :: k1 -> k2 -> Type +type T3 @_ @k _ _ = k + +type FConst _ = () + diff --git a/tests/examples/pre-ghc910/RandomPGC.hs b/tests/examples/pre-ghc910/RandomPGC.hs deleted file mode 100644 --- a/tests/examples/pre-ghc910/RandomPGC.hs +++ /dev/null @@ -1,597 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : System.Random --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE in the 'random' repository) --- --- Maintainer : libraries@haskell.org --- Stability : stable --- Portability : portable --- --- This library deals with the common task of pseudo-random number --- generation. The library makes it possible to generate repeatable --- results, by starting with a specified initial random number generator, --- or to get different results on each run by using the system-initialised --- generator or by supplying a seed from some other source. --- --- The library is split into two layers: --- --- * A core /random number generator/ provides a supply of bits. --- The class 'RandomGen' provides a common interface to such generators. --- The library provides one instance of 'RandomGen', the abstract --- data type 'StdGen'. Programmers may, of course, supply their own --- instances of 'RandomGen'. --- --- * The class 'Random' provides a way to extract values of a particular --- type from a random number generator. For example, the 'Float' --- instance of 'Random' allows one to generate random values of type --- 'Float'. --- --- This implementation uses the Portable Combined Generator of L'Ecuyer --- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by --- Lennart Augustsson. It has a period of roughly 2.30584e18. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module RandomPGC - ( - - -- $intro - - -- * Random number generators - -#ifdef ENABLE_SPLITTABLEGEN - RandomGen(next, genRange) - , SplittableGen(split) -#else - RandomGen(next, genRange, split) -#endif - -- ** Standard random number generators - , StdGen - , mkStdGen - - -- ** The global random number generator - - -- $globalrng - - , getStdRandom - , getStdGen - , setStdGen - , newStdGen - - -- * Random values of various types - , Random ( random, randomR, - randoms, randomRs, - randomIO, randomRIO ) - - -- * References - -- $references - - ) where - -import Prelude - -import Data.Bits -import Data.Int -import Data.Word -import Foreign.C.Types - -#ifdef __NHC__ -import CPUTime ( getCPUTime ) -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.C ( CTime, CUInt ) -#else -import System.CPUTime ( getCPUTime ) -import Data.Time ( getCurrentTime, UTCTime(..) ) -import Data.Ratio ( numerator, denominator ) -#endif -import Data.Char ( isSpace, chr, ord ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import Data.IORef ( atomicModifyIORef' ) -import Numeric ( readDec ) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts ( build ) -#else --- | A dummy variant of build without fusion. -{-# INLINE build #-} -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build g = g (:) [] -#endif - --- The standard nhc98 implementation of Time.ClockTime does not match --- the extended one expected in this module, so we lash-up a quick --- replacement here. -#ifdef __NHC__ -foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime -getTime :: IO (Integer, Integer) -getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) -#else -getTime :: IO (Integer, Integer) -getTime = do - utc <- getCurrentTime - let daytime = toRational $ utctDayTime utc - return $ quotRem (numerator daytime) (denominator daytime) -#endif - --- | The class 'RandomGen' provides a common interface to random number --- generators. --- -#ifdef ENABLE_SPLITTABLEGEN --- Minimal complete definition: 'next'. -#else --- Minimal complete definition: 'next' and 'split'. -#endif - -class RandomGen g where - - -- |The 'next' operation returns an 'Int' that is uniformly distributed - -- in the range returned by 'genRange' (including both end points), - -- and a new generator. - next :: g -> (Int, g) - - -- |The 'genRange' operation yields the range of values returned by - -- the generator. - -- - -- It is required that: - -- - -- * If @(a,b) = 'genRange' g@, then @a < b@. - -- - -- * 'genRange' always returns a pair of defined 'Int's. - -- - -- The second condition ensures that 'genRange' cannot examine its - -- argument, and hence the value it returns can be determined only by the - -- instance of 'RandomGen'. That in turn allows an implementation to make - -- a single call to 'genRange' to establish a generator's range, without - -- being concerned that the generator returned by (say) 'next' might have - -- a different range to the generator passed to 'next'. - -- - -- The default definition spans the full range of 'Int'. - genRange :: g -> (Int,Int) - - -- default method - genRange _ = (minBound, maxBound) - -#ifdef ENABLE_SPLITTABLEGEN --- | The class 'SplittableGen' proivides a way to specify a random number --- generator that can be split into two new generators. -class SplittableGen g where -#endif - -- |The 'split' operation allows one to obtain two distinct random number - -- generators. This is very useful in functional programs (for example, when - -- passing a random number generator down to recursive calls), but very - -- little work has been done on statistically robust implementations of - -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] - -- are the only examples we know of). - split :: g -> (g, g) - -{- | -The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. - -The result of repeatedly using 'next' should be at least as statistically -robust as the /Minimal Standard Random Number Generator/ described by -["System.Random\#Park", "System.Random\#Carta"]. -Until more is known about implementations of 'split', all we require is -that 'split' deliver generators that are (a) not identical and -(b) independently robust in the sense just given. - -The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the -state of a random number generator. -It is required that @'read' ('show' g) == g@. - -In addition, 'reads' may be used to map an arbitrary string (not necessarily one -produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' -instance of 'StdGen' has the following properties: - -* It guarantees to succeed on any string. - -* It guarantees to consume only a finite portion of the string. - -* Different argument strings are likely to result in different results. - --} - -data StdGen - = StdGen !Int32 !Int32 - -instance RandomGen StdGen where - next = stdNext - genRange _ = stdRange - -#ifdef ENABLE_SPLITTABLEGEN -instance SplittableGen StdGen where -#endif - split = stdSplit - -instance Show StdGen where - showsPrec p (StdGen s1 s2) = - showsPrec p s1 . - showChar ' ' . - showsPrec p s2 - -instance Read StdGen where - readsPrec _p = \ r -> - case try_read r of - r'@[_] -> r' - _ -> [stdFromString r] -- because it shouldn't ever fail. - where - try_read r = do - (s1, r1) <- readDec (dropWhile isSpace r) - (s2, r2) <- readDec (dropWhile isSpace r1) - return (StdGen s1 s2, r2) - -{- - If we cannot unravel the StdGen from a string, create - one based on the string given. --} -stdFromString :: String -> (StdGen, String) -stdFromString s = (mkStdGen num, rest) - where (cs, rest) = splitAt 6 s - num = foldl (\a x -> x + 3 * a) 1 (map ord cs) - - -{- | -The function 'mkStdGen' provides an alternative way of producing an initial -generator, by mapping an 'Int' into a generator. Again, distinct arguments -should be likely to produce distinct generators. --} -mkStdGen :: Int -> StdGen -- why not Integer ? -mkStdGen s = mkStdGen32 $ fromIntegral s - -{- -From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be -initialized to values in the range [1, 2147483562] and [1, 2147483398] -respectively." --} -mkStdGen32 :: Int32 -> StdGen -mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) - where - -- We want a non-negative number, but we can't just take the abs - -- of sMaybeNegative as -minBound == minBound. - s = sMaybeNegative .&. maxBound - (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - -createStdGen :: Integer -> StdGen -createStdGen s = mkStdGen32 $ fromIntegral s - -{- | -With a source of random number supply in hand, the 'Random' class allows the -programmer to extract random values of a variety of types. - -Minimal complete definition: 'randomR' and 'random'. - --} - -class Random a where - -- | Takes a range /(lo,hi)/ and a random number generator - -- /g/, and returns a random value uniformly distributed in the closed - -- interval /[lo,hi]/, together with a new generator. It is unspecified - -- what happens if /lo>hi/. For continuous types there is no requirement - -- that the values /lo/ and /hi/ are ever produced, but they may be, - -- depending on the implementation and the interval. - randomR :: RandomGen g => (a,a) -> g -> (a,g) - - -- | The same as 'randomR', but using a default range determined by the type: - -- - -- * For bounded types (instances of 'Bounded', such as 'Char'), - -- the range is normally the whole type. - -- - -- * For fractional types, the range is normally the semi-closed interval - -- @[0,1)@. - -- - -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. - random :: RandomGen g => g -> (a, g) - - -- | Plural variant of 'randomR', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randomRs #-} - randomRs :: RandomGen g => (a,a) -> g -> [a] - randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) - - -- | Plural variant of 'random', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randoms #-} - randoms :: RandomGen g => g -> [a] - randoms g = build (\cons _nil -> buildRandoms cons random g) - - -- | A variant of 'randomR' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomRIO :: (a,a) -> IO a - randomRIO range = getStdRandom (randomR range) - - -- | A variant of 'random' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomIO :: IO a - randomIO = getStdRandom random - --- | Produce an infinite list-equivalent of random values. -{-# INLINE buildRandoms #-} -buildRandoms :: RandomGen g - => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion - -> (g -> (a,g)) -- ^ E.g. 'random' - -> g -- ^ A 'RandomGen' instance - -> as -buildRandoms cons rand = go - where - -- The seq fixes part of #4218 and also makes fused Core simpler. - go g = x `seq` (x `cons` go g') where (x,g') = rand g - - -instance Random Integer where - randomR ival g = randomIvalInteger ival g - random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g - -instance Random Int where randomR = randomIvalIntegral; random = randomBounded -instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded - -#ifndef __NHC__ --- Word is a type synonym in nhc98. -instance Random Word where randomR = randomIvalIntegral; random = randomBounded -#endif -instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded - -instance Random CChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULong where randomR = randomIvalIntegral; random = randomBounded -instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded -instance Random CSize where randomR = randomIvalIntegral; random = randomBounded -instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded -instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded - -instance Random Char where - randomR (a,b) g = - case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of - (x,g') -> (chr x, g') - random g = randomR (minBound,maxBound) g - -instance Random Bool where - randomR (a,b) g = - case (randomIvalInteger (bool2Int a, bool2Int b) g) of - (x, g') -> (int2Bool x, g') - where - bool2Int :: Bool -> Integer - bool2Int False = 0 - bool2Int True = 1 - - int2Bool :: Int -> Bool - int2Bool 0 = False - int2Bool _ = True - - random g = randomR (minBound,maxBound) g - -{-# INLINE randomRFloating #-} -randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) -randomRFloating (l,h) g - | l>h = randomRFloating (h,l) g - | otherwise = let (coef,g') = random g in - (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow - -instance Random Double where - randomR = randomRFloating - random rng = - case random rng of - (x,rng') -> - -- We use 53 bits of randomness corresponding to the 53 bit significand: - ((fromIntegral (mask53 .&. (x::Int64)) :: Double) - / fromIntegral twoto53, rng') - where - twoto53 = (2::Int64) ^ (53::Int64) - mask53 = twoto53 - 1 - -instance Random Float where - randomR = randomRFloating - random rng = - -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. - case random rng of - (x,rng') -> - -- We use 24 bits of randomness corresponding to the 24 bit significand: - ((fromIntegral (mask24 .&. (x::Int32)) :: Float) - / fromIntegral twoto24, rng') - -- Note, encodeFloat is another option, but I'm not seeing slightly - -- worse performance with the following [2011.06.25]: --- (encodeFloat rand (-24), rng') - where - mask24 = twoto24 - 1 - twoto24 = (2::Int32) ^ (24::Int32) - --- CFloat/CDouble are basically the same as a Float/Double: -instance Random CFloat where - randomR = randomRFloating - random rng = case random rng of - (x,rng') -> (realToFrac (x::Float), rng') - -instance Random CDouble where - randomR = randomRFloating - -- A MYSTERY: - -- Presently, this is showing better performance than the Double instance: - -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) - random = randomFrac - -- random rng = case random rng of - -- (x,rng') -> (realToFrac (x::Double), rng') - -mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = do - ct <- getCPUTime - (sec, psec) <- getTime - return (createStdGen (sec * 12345 + psec + ct + o)) - -randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) -randomBounded = randomR (minBound, maxBound) - --- The two integer functions below take an [inclusive,inclusive] range. -randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) -randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) - -{-# SPECIALIZE randomIvalInteger :: (Num a) => - (Integer, Integer) -> StdGen -> (a, StdGen) #-} - -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng - | l > h = randomIvalInteger (h,l) rng - | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') - where - (genlo, genhi) = genRange rng - b = fromIntegral genhi - fromIntegral genlo + 1 - - -- Probabilities of the most likely and least likely result - -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen - -- is uniform, of course - - -- On average, log q / log b more random values will be generated - -- than the minimum - q = 1000 - k = h - l + 1 - magtgt = k * q - - -- generate random values until we exceed the target magnitude - f mag v g | mag >= magtgt = (v, g) - | otherwise = v' `seq`f (mag*b) v' g' where - (x,g') = next g - v' = (v * b + (fromIntegral x - fromIntegral genlo)) - - --- The continuous functions on the other hand take an [inclusive,exclusive) range. -randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) -randomFrac = randomIvalDouble (0::Double,1) realToFrac - -randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) -randomIvalDouble (l,h) fromDouble rng - | l > h = randomIvalDouble (h,l) fromDouble rng - | otherwise = - case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of - (x, rng') -> - let - scaled_x = - fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed - fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow - fromIntegral (x::Int32) - in - (scaled_x, rng') - -int32Count :: Integer -int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982 - -stdRange :: (Int,Int) -stdRange = (1, 2147483562) - -stdNext :: StdGen -> (Int, StdGen) --- Returns values in the range stdRange -stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') - where z' = if z < 1 then z + 2147483562 else z - z = s1'' - s2'' - - k = s1 `quot` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - - k' = s2 `quot` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - -stdSplit :: StdGen -> (StdGen, StdGen) -stdSplit std@(StdGen s1 s2) - = (left, right) - where - -- no statistical foundation for this! - left = StdGen new_s1 t2 - right = StdGen t1 new_s2 - - new_s1 | s1 == 2147483562 = 1 - | otherwise = s1 + 1 - - new_s2 | s2 == 1 = 2147483398 - | otherwise = s2 - 1 - - StdGen t1 t2 = snd (next std) - --- The global random number generator - -{- $globalrng #globalrng# - -There is a single, implicit, global random number generator of type -'StdGen', held in some global variable maintained by the 'IO' monad. It is -initialised automatically in some system-dependent fashion, for example, by -using the time of day, or Linux's kernel random number generator. To get -deterministic behaviour, use 'setStdGen'. --} - --- |Sets the global random number generator. -setStdGen :: StdGen -> IO () -setStdGen sgen = writeIORef theStdGen sgen - --- |Gets the global random number generator. -getStdGen :: IO StdGen -getStdGen = readIORef theStdGen - -theStdGen :: IORef StdGen -theStdGen = unsafePerformIO $ do - rng <- mkStdRNG 0 - newIORef rng - --- |Applies 'split' to the current global random generator, --- updates it with one of the results, and returns the other. -newStdGen :: IO StdGen -newStdGen = atomicModifyIORef' theStdGen split - -{- |Uses the supplied function to get a value from the current global -random generator, and updates the global generator with the new generator -returned by the function. For example, @rollDice@ gets a random integer -between 1 and 6: - -> rollDice :: IO Int -> rollDice = getStdRandom (randomR (1,6)) - --} - -getStdRandom :: (StdGen -> (a,StdGen)) -> IO a -getStdRandom f = atomicModifyIORef' theStdGen (swap . f) - where swap (v,g) = (g,v) - -{- $references - -1. FW #Burton# Burton and RL Page, /Distributed random number generation/, -Journal of Functional Programming, 2(2):203-212, April 1992. - -2. SK #Park# Park, and KW Miller, /Random number generators - -good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. - -3. DG #Carta# Carta, /Two fast implementations of the minimal standard -random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. - -4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, -Department of Mathematics, University of Salzburg, -, 1998. - -5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random -number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. - -The Web site is a great source of information. - --} diff --git a/tests/examples/transform/AddArgFromWhereComments.hs b/tests/examples/transform/AddArgFromWhereComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddArgFromWhereComments.hs @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True -- c4 + = new_def + +foo False = False diff --git a/tests/examples/transform/AddArgFromWhereComments.hs.expected b/tests/examples/transform/AddArgFromWhereComments.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddArgFromWhereComments.hs.expected @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True -- c4 + = new_def + +foo False = False