diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2017-02-07 v0.5.3.0 + * Support GHC 8.0.2 + * Correct the logic around RigidLayout to function as originally + intended. + * Introduce Pretty module to add default annotations to a bare AST + fragment, so that it can be printed correctly via exactprint. In + this case, "correct" is defined as generating the same AST if + parsed again, it may not be beautiful layout. + * Expose some additional internal parsing options (@lspitzner) + 2016-07-24 v0.5.2.1 * Remove additional files from release tarball diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,5 +1,5 @@ name: ghc-exactprint -version: 0.5.2.1 +version: 0.5.3.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10.2, this library provides a means to round trip any code that can @@ -26,7 +26,7 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 7.10.3, GHC == 8.0.1 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2 extra-source-files: ChangeLog tests/examples/failing/*.hs tests/examples/ghc710/*.hs @@ -47,7 +47,12 @@ Default: False } +Flag dev { + Description: Development mode, do not use ghc-exactprint lib in the tests + Default: False +} + library exposed-modules: Language.Haskell.GHC.ExactPrint , Language.Haskell.GHC.ExactPrint.Annotate @@ -55,6 +60,7 @@ , Language.Haskell.GHC.ExactPrint.GhcInterim , Language.Haskell.GHC.ExactPrint.Lookup , Language.Haskell.GHC.ExactPrint.Preprocess + , Language.Haskell.GHC.ExactPrint.Pretty , Language.Haskell.GHC.ExactPrint.Print , Language.Haskell.GHC.ExactPrint.Transform , Language.Haskell.GHC.ExactPrint.Types @@ -84,25 +90,40 @@ Test-Suite test type: exitcode-stdio-1.0 - hs-source-dirs: tests + if flag (dev) + hs-source-dirs: tests + src + else + hs-source-dirs: tests + main-is: Test.hs - other-modules: Test.Common, Test.Consistency, Test.Transform + other-modules: Test.Common + , Test.Consistency + , Test.NoAnnotations + , Test.Transform GHC-Options: -threaded Default-language: Haskell2010 if impl (ghc < 7.10.2) buildable: False Build-depends: HUnit >= 1.2 , base < 5 + , bytestring , containers >= 0.5 + , Diff , directory >= 1.2 , filepath >= 1.4 , ghc >= 7.10.2 - , ghc-exactprint >= 0.3 , ghc-paths >= 0.1 , mtl >= 2.2.1 , syb >= 0.5 , silently >= 1.2 , filemanip >= 0.3 + -- for the lib only + if flag (dev) + build-depends: free + else + build-depends: ghc-exactprint >= 0.5.3 + if impl (ghc >= 7.11) build-depends: ghc-boot @@ -165,8 +186,8 @@ , ghc >= 7.10.2 , ghc-paths >= 0.1 , HUnit - , text >= 1.2.2 - , turtle >= 1.2.5 + , text >= 1.2.2 + , turtle >= 1.3.0 buildable: True if impl (ghc >= 7.11) build-depends: ghc-boot diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint.hs @@ -16,12 +16,16 @@ -- * Transformation , module Language.Haskell.GHC.ExactPrint.Transform + -- * Adding default annotations + , addAnnotationsForPretty + -- * Printing , exactPrint ) where import Language.Haskell.GHC.ExactPrint.Delta +import Language.Haskell.GHC.ExactPrint.Pretty import Language.Haskell.GHC.ExactPrint.Print import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs --- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs @@ -1,3049 +1,3672 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | 'annotate' is a function which given a GHC AST fragment, constructs --- a syntax tree which indicates which annotations belong to each specific --- part of the fragment. --- --- "Delta" and "Print" provide two interpreters for this structure. You --- should probably use those unless you know what you're doing! --- --- The functor 'AnnotationF' has a number of constructors which correspond --- to different sitations which annotations can arise. It is hoped that in --- future versions of GHC these can be simplified by making suitable --- modifications to the AST. - -module Language.Haskell.GHC.ExactPrint.Annotate - ( - annotate - , AnnotationF(..) - , Annotated - , Annotate(..) - ) where - -import Data.Maybe ( fromMaybe ) -#if __GLASGOW_HASKELL__ <= 710 -import Data.Ord ( comparing ) -import Data.List ( sortBy ) -#endif - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified BooleanFormula as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC -import qualified OccName as GHC -import qualified Outputable as GHC - -import Control.Monad.Trans.Free -import Control.Monad.Free.TH (makeFreeCon) -import Control.Monad.Identity -import Data.Data - -import Debug.Trace - - -{-# ANN module "HLint: ignore Eta reduce" #-} --- --------------------------------------------------------------------- - --- | --- ['MarkPrim'] --- The main constructor. Marks that a specific AnnKeywordId could --- appear with an optional String which is used when printing. --- ['MarkEOF'] --- Special constructor which marks the end of file marker. --- ['MarkExternal'] TODO --- ['MarkOutside'] A @AnnKeywordId@ which is precisely located but not inside the --- current context. This is usually used to reassociated located --- @RdrName@ which are more naturally associated with their parent than --- in their own annotation. --- ['MarkInside'] --- The dual of MarkOutside. If we wish to mark a non-separating comma --- or semi-colon then we must use this constructor. --- ['MarkMany'] Some syntax elements allow an arbritary number of puncuation marks --- without reflection in the AST. This construction greedily takes all of --- the specified @AnnKeywordId@. --- ['MarkOffsetPrim'] Some syntax elements have repeated @AnnKeywordId@ which are --- seperated by different @AnnKeywordId@. Thus using MarkMany is --- unsuitable and instead we provide an index to specify which specific --- instance to choose each time. --- ['WithAST'] TODO --- ['CountAnns'] Sometimes the AST does not reflect the concrete source code and the --- only way to tell what the concrete source was is to count a certain --- kind of @AnnKeywordId@. --- ['WithSortKey'] There are many places where the syntactic ordering of elements is --- thrown away by the AST. This constructor captures the original --- ordering and reflects any changes in ordered as specified by the --- @annSortKey@ field in @Annotation@. --- ['SetLayoutFlag'] It is important to know precisely where layout rules apply. This --- constructor wraps a computation to indicate that LayoutRules apply to --- the corresponding construct. --- ['StoreOriginalSrcSpan'] TODO --- ['GetSrcSpanFromKw'] TODO --- ['StoreString'] TODO --- ['AnnotationsToComments'] Used when the AST is sufficiently vague that there is no other --- option but to convert a fragment of source code into a comment. This --- means it is impossible to edit such a fragment but means that --- processing files with such fragments is still possible. -data AnnotationF next where - MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next - MarkEOF :: next -> AnnotationF next - MarkExternal :: GHC.SrcSpan -> GHC.AnnKeywordId -> String -> next -> AnnotationF next - MarkOutside :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next - MarkInside :: GHC.AnnKeywordId -> next -> AnnotationF next - MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next - MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next - WithAST :: Data a => GHC.Located a - -> Annotated b -> next -> AnnotationF next - CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next - WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next - - SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next - - -- Required to work around deficiencies in the GHC AST - StoreOriginalSrcSpan :: AnnKey -> (AnnKey -> next) -> AnnotationF next - GetSrcSpanForKw :: GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next -#if __GLASGOW_HASKELL__ <= 710 - StoreString :: String -> GHC.SrcSpan -> next -> AnnotationF next -#endif - AnnotationsToComments :: [GHC.AnnKeywordId] -> next -> AnnotationF next - -deriving instance Functor (AnnotationF) - -type Annotated = FreeT AnnotationF Identity - - --- --------------------------------------------------------------------- - -makeFreeCon 'MarkEOF -makeFreeCon 'MarkPrim -makeFreeCon 'MarkOutside -makeFreeCon 'MarkInside -makeFreeCon 'MarkExternal -makeFreeCon 'MarkMany -makeFreeCon 'MarkOffsetPrim -makeFreeCon 'CountAnns -makeFreeCon 'StoreOriginalSrcSpan -makeFreeCon 'GetSrcSpanForKw -#if __GLASGOW_HASKELL__ <= 710 -makeFreeCon 'StoreString -#endif -makeFreeCon 'AnnotationsToComments -makeFreeCon 'WithSortKey - --- --------------------------------------------------------------------- - -setLayoutFlag :: Annotated () -> Annotated () -setLayoutFlag action = liftF (SetLayoutFlag NormalLayout action ()) - -setRigidFlag :: Annotated () -> Annotated () -setRigidFlag action = liftF (SetLayoutFlag RigidLayout action ()) - --- | Construct a syntax tree which represent which KeywordIds must appear --- where. -annotate :: (Annotate ast) => GHC.Located ast -> Annotated () -annotate = markLocated - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -workOutString :: GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated () -workOutString kw f = do - ss <- getSrcSpanForKw kw - storeString (f ss) ss -#endif - --- --------------------------------------------------------------------- - --- |Main driver point for annotations. -withAST :: Data a => GHC.Located a -> Annotated () -> Annotated () -withAST lss action = - liftF (WithAST lss prog ()) - where - prog = do - action - -- Automatically add any trailing comma or semi - markOutside GHC.AnnComma (G GHC.AnnComma) - --- --------------------------------------------------------------------- --- Additional smart constructors - -mark :: GHC.AnnKeywordId -> Annotated () -mark kwid = markPrim kwid Nothing - -markWithString :: GHC.AnnKeywordId -> String -> Annotated () -markWithString kwid s = markPrim kwid (Just s) - -markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated () -markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s) - -markOffset :: GHC.AnnKeywordId -> Int -> Annotated () -markOffset kwid n = markOffsetPrim kwid n Nothing - -markTrailingSemi :: Annotated () -markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep - --- --------------------------------------------------------------------- - --- | Constructs a syntax tree which contains information about which --- annotations are required by each element. -markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () -markLocated ast = - case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) of - Just d -> markLHsDecl d - Nothing -> withLocated ast markAST - -withLocated :: Data a - => GHC.Located a - -> (GHC.SrcSpan -> a -> Annotated ()) - -> Annotated () -withLocated a@(GHC.L l ast) action = - withAST a (action l ast) - --- --------------------------------------------------------------------- - -markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () -markListWithLayout ls = - setLayoutFlag (mapM_ markLocated ls) - -markLocalBindsWithLayout :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.HsLocalBinds name -> Annotated () -markLocalBindsWithLayout binds = - setLayoutFlag (markHsLocalBinds binds) - --- --------------------------------------------------------------------- - --- |This function is used to get around shortcomings in the GHC AST for 7.10.1 -markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> ast -> Annotated () -markLocatedFromKw kw a = do - ss <- getSrcSpanForKw kw - AnnKey ss' _ <- storeOriginalSrcSpan (mkAnnKey (GHC.L ss a)) - markLocated (GHC.L ss' a) - --- --------------------------------------------------------------------- - -markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () -markMaybe Nothing = return () -markMaybe (Just ast) = markLocated ast - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] -prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls - -applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated () -applyListAnnotations ls = withSortKey ls - -#if __GLASGOW_HASKELL__ <= 710 -lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a] -lexicalSortLocated = sortBy (comparing GHC.getLoc) -#endif - --- --------------------------------------------------------------------- - -class Data ast => Annotate ast where - markAST :: GHC.SrcSpan -> ast -> Annotated () - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsModule GHC.RdrName) where - markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do - - case mmn of - Nothing -> return () - Just (GHC.L ln mn) -> do - mark GHC.AnnModule - markExternal ln GHC.AnnVal (GHC.moduleNameString mn) - - case mdepr of - Nothing -> return () - Just depr -> markLocated depr - - case mexp of - Nothing -> return () - Just expr -> markLocated expr - - mark GHC.AnnWhere - mark GHC.AnnOpenC -- Possible '{' - markMany GHC.AnnSemi -- possible leading semis - mapM_ markLocated imps - - mapM_ markLocated decs - - mark GHC.AnnCloseC -- Possible '}' - - markEOF - --- --------------------------------------------------------------------- - -instance Annotate GHC.WarningTxt where - markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do - markExternal ls GHC.AnnOpen txt - mark GHC.AnnOpenS - mapM_ markLocated lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do - markExternal ls GHC.AnnOpen txt - mark GHC.AnnOpenS - mapM_ markLocated lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ <= 710 -#else -instance Annotate GHC.StringLiteral where - markAST l (GHC.StringLiteral src _) = markExternal l GHC.AnnVal src -#endif - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SourceText,GHC.FastString) where - -- markAST l (_,fs) = markAST l fs - markAST l (src,_fs) = markExternal l GHC.AnnVal src - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name) - => Annotate [GHC.LIE name] where - markAST _ ls = do - mark GHC.AnnHiding -- in an import decl - mark GHC.AnnOpenP -- '(' - mapM_ markLocated ls - mark GHC.AnnCloseP -- ')' - -instance (GHC.DataId name,Annotate name) - => Annotate (GHC.IE name) where - markAST _ ie = do - - case ie of - (GHC.IEVar ln) -> do - mark GHC.AnnPattern - mark GHC.AnnType - markLocated ln - - (GHC.IEThingAbs ln@(GHC.L _ n)) -> do - {- - At the moment (7.10.2) GHC does not cleanly represent an export of the form - "type Foo" - and it only captures the name "Foo". - - The Api Annotations workaround is to have the IEThingAbs SrcSpan - extend across both the "type" and "Foo", and then to capture the - individual item locations in an AnnType and AnnVal annotation. - - This need to be fixed for 7.12. - -} - cnt <- countAnns GHC.AnnType - if cnt == 1 - then do - mark GHC.AnnType - markLocatedFromKw GHC.AnnVal n - else markLocated ln - -#if __GLASGOW_HASKELL__ <= 710 - (GHC.IEThingWith ln ns) -> do -#else - (GHC.IEThingWith ln wc ns _lfs) -> do -{- - | IEThingWith (Located name) - IEWildcard - [Located name] - [Located (FieldLbl name)] - -- ^ Class/Type plus some methods/constructors - -- and record fields; see Note [IEThingWith] - --} -#endif - -- TODO: Deal with GHC 8.0 additions - markLocated ln - mark GHC.AnnOpenP -#if __GLASGOW_HASKELL__ <= 710 - mapM_ markLocated ns -#else - case wc of - GHC.NoIEWildcard -> mapM_ markLocated ns - GHC.IEWildcard n -> do - mapM_ markLocated (take n ns) - mark GHC.AnnDotdot - case drop n ns of - [] -> return () - ns' -> do - markOffset GHC.AnnComma 0 - mapM_ markLocated ns' -#endif - mark GHC.AnnCloseP - - (GHC.IEThingAll ln) -> do - markLocated ln - mark GHC.AnnOpenP - mark GHC.AnnDotdot - mark GHC.AnnCloseP - - (GHC.IEModuleContents (GHC.L lm mn)) -> do - mark GHC.AnnModule - markExternal lm GHC.AnnVal (GHC.moduleNameString mn) - - -- Only used in Haddock mode so we can ignore them. - (GHC.IEGroup _ _) -> return () - - (GHC.IEDoc _) -> return () - - (GHC.IEDocNamed _) -> return () - --- --------------------------------------------------------------------- -{- --- For details on above see note [Api annotations] in ApiAnnotation -data RdrName - = Unqual OccName - -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving (Data, Typeable) --} - -instance Annotate GHC.RdrName where - markAST l n = do - let - str = rdrName2String n - doNormalRdrName = do - let str' = case str of - "forall" -> if spanLength l == 1 then "∀" else str - _ -> str - mark GHC.AnnType - mark GHC.AnnOpenP -- '(' - markOffset GHC.AnnBackquote 0 - cnt <- countAnns GHC.AnnVal - cntT <- countAnns GHC.AnnCommaTuple - markMany GHC.AnnCommaTuple -- For '(,,,)' - case cnt of - 0 -> if cntT > 0 - then return () - else markExternal l GHC.AnnVal str' - 1 -> markWithString GHC.AnnVal str' - _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) - markOffset GHC.AnnBackquote 1 - mark GHC.AnnCloseP - - case n of - GHC.Unqual _ -> doNormalRdrName - GHC.Qual _ _ -> doNormalRdrName - _ -> do - case str of - -- Special handling for atypical RdrNames. - "[]" -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnCloseS -- ']' - "()" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnCloseP -- ')' - ('(':'#':_) -> do - markWithString GHC.AnnOpen "(#" -- '(#' - markMany GHC.AnnCommaTuple - markWithString GHC.AnnClose "#)"-- '#)' - "[::]" -> do - markWithString GHC.AnnOpen "[:" -- '[:' - markWithString GHC.AnnClose ":]" -- ':]' - "(->)" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnRarrow - mark GHC.AnnCloseP -- ')' - "~#" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnTildehsh - mark GHC.AnnCloseP -#if __GLASGOW_HASKELL__ <= 710 - "~" -> do - mark GHC.AnnOpenP - mark GHC.AnnTilde - mark GHC.AnnCloseP -#endif - _ -> doNormalRdrName - --- --------------------------------------------------------------------- - --- TODO: What is this used for? Not in ExactPrint -instance Annotate GHC.Name where - markAST l n = do - markExternal l GHC.AnnVal (showGhc n) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name) - => Annotate (GHC.ImportDecl name) where - markAST _ imp@(GHC.ImportDecl msrc modname mpkg src safeflag _qual _impl _as hiding) = do - - -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - mark GHC.AnnImport - - -- "{-# SOURCE" and "#-}" - when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) - >> markWithString GHC.AnnClose "#-}") - when safeflag (mark GHC.AnnSafe) - mark GHC.AnnQualified - case mpkg of - Nothing -> return () -#if __GLASGOW_HASKELL__ <= 710 - Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg)) -#else - Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg -#endif - - markLocated modname - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - mark GHC.AnnAs - markWithString GHC.AnnVal (GHC.moduleNameString mn) - - case hiding of - Nothing -> return () - Just (_isHiding,lie) -> do - mark GHC.AnnHiding - markLocated lie - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate GHC.ModuleName where - markAST l mname = - markExternal l GHC.AnnVal (GHC.moduleNameString mname) - --- --------------------------------------------------------------------- - --- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) -markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsDecl name -> Annotated () -markLHsDecl (GHC.L l decl) = - case decl of - GHC.TyClD d -> markLocated (GHC.L l d) - GHC.InstD d -> markLocated (GHC.L l d) - GHC.DerivD d -> markLocated (GHC.L l d) - GHC.ValD d -> markLocated (GHC.L l d) - GHC.SigD d -> markLocated (GHC.L l d) - GHC.DefD d -> markLocated (GHC.L l d) - GHC.ForD d -> markLocated (GHC.L l d) - GHC.WarningD d -> markLocated (GHC.L l d) - GHC.AnnD d -> markLocated (GHC.L l d) - GHC.RuleD d -> markLocated (GHC.L l d) - GHC.VectD d -> markLocated (GHC.L l d) - GHC.SpliceD d -> markLocated (GHC.L l d) - GHC.DocD d -> markLocated (GHC.L l d) - GHC.RoleAnnotD d -> markLocated (GHC.L l d) -#if __GLASGOW_HASKELL__ < 711 - GHC.QuasiQuoteD d -> markLocated (GHC.L l d) -#endif - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsDecl name) where - markAST l d = markLHsDecl (GHC.L l d) - --- --------------------------------------------------------------------- - -instance (Annotate name) - => Annotate (GHC.RoleAnnotDecl name) where - markAST _ (GHC.RoleAnnotDecl ln mr) = do - mark GHC.AnnType - mark GHC.AnnRole - markLocated ln - mapM_ markLocated mr - -instance Annotate (Maybe GHC.Role) where - markAST l Nothing = markExternal l GHC.AnnVal "_" - markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.SpliceDecl name) where - markAST _ (GHC.SpliceDecl e _flag) = do - mark GHC.AnnOpenPE - markLocated e - mark GHC.AnnCloseP - markTrailingSemi - -{- -- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) -- ImplicitSplice -- <=> f x y, i.e. a naked -- top level expression -- --} - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.VectDecl name) where - markAST _ (GHC.HsVect src ln e) = do - markWithString GHC.AnnOpen src -- "{-# VECTORISE" - markLocated ln - mark GHC.AnnEqual - markLocated e - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ (GHC.HsNoVect src ln) = do - markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" - markLocated ln - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ (GHC.HsVectTypeIn src _b ln mln) = do - markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" - mark GHC.AnnType - markLocated ln - mark GHC.AnnEqual - markMaybe mln - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ (GHC.HsVectTypeOut {}) = - traceM "warning: HsVectTypeOut appears after renaming" - - markAST _ (GHC.HsVectClassIn src ln) = do - markWithString GHC.AnnOpen src -- "{-# VECTORISE" - mark GHC.AnnClass - markLocated ln - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ (GHC.HsVectClassOut {}) = - traceM "warning: HsVecClassOut appears after renaming" - markAST _ (GHC.HsVectInstIn {}) = - traceM "warning: HsVecInstsIn appears after renaming" - markAST _ (GHC.HsVectInstOut {}) = - traceM "warning: HsVecInstOut appears after renaming" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.RuleDecls name) where - markAST _ (GHC.HsRules src rules) = do - markWithString GHC.AnnOpen src - mapM_ markLocated rules - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.RuleDecl name) where - markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do - markLocated ln - markActivation act - - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - markLocated lhs - mark GHC.AnnEqual - markLocated rhs - markTrailingSemi - --- --------------------------------------------------------------------- - -markActivation :: GHC.Activation -> Annotated () -markActivation act = do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ -#if __GLASGOW_HASKELL__ <= 710 - case act of - GHC.ActiveBefore n -> do - markWithString GHC.AnnVal (show n) - GHC.ActiveAfter n -> do - markWithString GHC.AnnVal (show n) - _ -> return () -#else - case act of - GHC.ActiveBefore src _ -> do - mark GHC.AnnTilde -- ~ - markWithString GHC.AnnVal src - GHC.ActiveAfter src _ -> do - markWithString GHC.AnnVal src - _ -> return () -#endif - mark GHC.AnnCloseS -- ']' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.RuleBndr name) where - markAST _ (GHC.RuleBndr ln) = markLocated ln -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLocated thing - mark GHC.AnnCloseP -- ")" -#else - markAST _ (GHC.RuleBndrSig ln st) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLHsSigWcType st - mark GHC.AnnCloseP -- ")" -#endif --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ <= 710 -#else -markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsSigWcType name -> Annotated () -markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do - case mwc of - Nothing -> markLocated ty - Just lwc -> do - -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty]) - -- markLocated (GHC.L lc sorted) - applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] - ++ prepareListAnnotation [ty] - ) -#endif --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.AnnDecl name) where - markAST _ (GHC.HsAnnotation src prov e) = do - markWithString GHC.AnnOpen src - mark GHC.AnnType - mark GHC.AnnModule - case prov of - (GHC.ValueAnnProvenance n) -> markLocated n - (GHC.TypeAnnProvenance n) -> markLocated n - (GHC.ModuleAnnProvenance) -> return () - - markLocated e - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate name => Annotate (GHC.WarnDecls name) where - markAST _ (GHC.Warnings src warns) = do - markWithString GHC.AnnOpen src - mapM_ markLocated warns - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance (Annotate name) - => Annotate (GHC.WarnDecl name) where - markAST _ (GHC.Warning lns txt) = do - mapM_ markLocated lns - mark GHC.AnnOpenS -- "[" - case txt of - GHC.WarningTxt _src ls -> mapM_ markLocated ls - GHC.DeprecatedTxt _src ls -> mapM_ markLocated ls - mark GHC.AnnCloseS -- "]" - -instance Annotate GHC.FastString where - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - markAST l fs = markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) - -- markAST l fs = markExternal l GHC.AnnVal ('"':(GHC.unpackFS fs++"\"")) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.ForeignDecl name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ForeignImport ln typ _ - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do -#else - markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _ - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do -{- - = ForeignImport - { fd_name :: Located name -- defines this name - , fd_sig_ty :: LHsSigType name -- sig_ty - , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty - , fd_fi :: ForeignImport } - --} -#endif - mark GHC.AnnForeign - mark GHC.AnnImport - markLocated cconv - if ll == GHC.noSrcSpan - then return () - else markLocated safety - -- markMaybe mh -#if __GLASGOW_HASKELL__ <= 710 - markExternal ls GHC.AnnVal (show src) -#else - if GHC.unLoc cconv == GHC.PrimCallConv - then markExternal ls GHC.AnnVal src - else markExternal ls GHC.AnnVal (show src) -#endif - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - -#if __GLASGOW_HASKELL__ <= 710 - markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do -#else - markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ) _ (GHC.CExport spec (GHC.L ls src))) = do -#endif - mark GHC.AnnForeign - mark GHC.AnnExport - markLocated spec - markExternal ls GHC.AnnVal (show src) - markLocated ln - mark GHC.AnnDcolon - markLocated typ - - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CExportSpec) where -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.CExportStatic _ cconv) = markAST l cconv -#else - markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv -#endif - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CCallConv) where - markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" - markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" - markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" - markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" - markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" - --- --------------------------------------------------------------------- - -instance (Annotate GHC.Safety) where - markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" - markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" - markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.DerivDecl name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.DerivDecl typ mov) = do -#else - markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do -#endif - mark GHC.AnnDeriving - mark GHC.AnnInstance - markMaybe mov - markLocated typ - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.DefaultDecl name) where - - markAST _ (GHC.DefaultDecl typs) = do - mark GHC.AnnDefault - mark GHC.AnnOpenP -- '(' - mapM_ markLocated typs - mark GHC.AnnCloseP -- ')' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.InstDecl name) where - - markAST l (GHC.ClsInstD cid) = markAST l cid - markAST l (GHC.DataFamInstD dfid) = markAST l dfid - markAST l (GHC.TyFamInstD tfid) = markAST l tfid - --- --------------------------------------------------------------------- - -instance Annotate GHC.OverlapMode where - markAST _ (GHC.NoOverlap src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlappable src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlapping src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlaps src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Incoherent src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.ClsInstDecl name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do -#else - markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do -#endif - mark GHC.AnnInstance - markMaybe mov - markLocated poly - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - - applyListAnnotations (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ++ prepareListAnnotation tyfams - ++ prepareListAnnotation datafams - ) - - mark GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.TyFamInstDecl name) where - - markAST _ (GHC.TyFamInstDecl eqn _) = do - mark GHC.AnnType - mark GHC.AnnInstance - markLocated eqn - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.DataFamInstDecl name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) defn _) = do -#else - markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats) defn _) = do -#endif - mark GHC.AnnData - mark GHC.AnnNewtype - mark GHC.AnnInstance - mark GHC.AnnOpenP - - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation pats - ) - - mark GHC.AnnCloseP -#if __GLASGOW_HASKELL__ > 710 - mark GHC.AnnDcolon - markMaybe (GHC.dd_kindSig defn) -#endif - mark GHC.AnnWhere - mark GHC.AnnEqual - markDataDefn l defn - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsBind name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.FunBind (GHC.L _ln _n) _ (GHC.MG matches _ _ _) _ _ _) = do -#else - markAST _ (GHC.FunBind (GHC.L _ln _n) (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do -#endif - mapM_ markLocated matches - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do -#else - markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do -#endif - markLocated lhs - mark GHC.AnnEqual - mapM_ markLocated grhs - mark GHC.AnnWhere - - markLocalBindsWithLayout lb - markTrailingSemi - - markAST _ (GHC.VarBind _n rhse _) = - -- Note: this bind is introduced by the typechecker - markLocated rhse - - markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do - mark GHC.AnnPattern - case args of - GHC.InfixPatSyn la lb -> do - markLocated la - markLocated ln - markLocated lb - GHC.PrefixPatSyn ns -> do - markLocated ln - mapM_ markLocated ns -#if __GLASGOW_HASKELL__ <= 710 -#else - GHC.RecordPatSyn fs -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - mapM_ (markLocated . GHC.recordPatSynSelectorId) fs - mark GHC.AnnCloseC -- '}' -#endif - mark GHC.AnnEqual - mark GHC.AnnLarrow - markLocated def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> do - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markMatchGroup l mg - mark GHC.AnnCloseC -- '}' - - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - mark GHC.AnnCloseC -- '}' - markTrailingSemi - - -- Introduced after renaming. - markAST _ (GHC.AbsBinds _ _ _ _ _) = - traceM "warning: AbsBinds introduced after renaming" - -#if __GLASGOW_HASKELL__ > 710 - -- Introduced after renaming. - markAST _ GHC.AbsBindsSig{} = - traceM "warning: AbsBindsSig introduced after renaming" -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.IPBind name) where - markAST _ (GHC.IPBind en e) = do - case en of - Left n -> markLocated n - Right _i -> return () - mark GHC.AnnEqual - markLocated e - markTrailingSemi - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsIPName where - markAST l (GHC.HsIPName n) = markExternal l (GHC.AnnVal) ("?" ++ GHC.unpackFS n) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, - Annotate body) - => Annotate (GHC.Match name (GHC.Located body)) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do -#else - markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do -#endif - let -#if __GLASGOW_HASKELL__ <= 710 - get_infix Nothing = False - get_infix (Just (_,f)) = f -#else - get_infix GHC.NonFunBindMatch = False - get_infix (GHC.FunBindMatch _ f) = f -#endif - case (get_infix mln,pats) of - (True, a:b:xs) -> do - mark GHC.AnnOpenP - markLocated a - case mln of -#if __GLASGOW_HASKELL__ <= 710 - Nothing -> return () - Just (n,_) -> markLocated n -#else - GHC.NonFunBindMatch -> return () - GHC.FunBindMatch n _ -> markLocated n -#endif - markLocated b - mark GHC.AnnCloseP - mapM_ markLocated xs - _ -> do - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] -#if __GLASGOW_HASKELL__ <= 710 - case mln of - Nothing -> mark GHC.AnnFunId - Just (n,_) -> markLocated n - mapM_ markLocated pats -#else - case mln of - GHC.NonFunBindMatch -> mark GHC.AnnFunId - GHC.FunBindMatch n _ -> markLocated n - mapM_ markLocated pats -#endif - - -- TODO: The AnnEqual annotation actually belongs in the first GRHS value - mark GHC.AnnEqual - mark GHC.AnnRarrow -- For HsLam - - mapM_ markLocated grhs - - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - mark GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, - Annotate name, Annotate body) - => Annotate (GHC.GRHS name (GHC.Located body)) where - markAST _ (GHC.GRHS guards expr) = do - case guards of - [] -> return () - (_:_) -> mark GHC.AnnVbar >> mapM_ markLocated guards - mark GHC.AnnEqual - cntL <- countAnns GHC.AnnLam - cntP <- countAnns GHC.AnnProc - when (cntL == 0 && cntP == 0) $ mark GHC.AnnRarrow -- For HsLam - markLocated expr - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.Sig name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TypeSig lns typ _) = do -#else - markAST _ (GHC.TypeSig lns st) = do -#endif - mapM_ markLocated lns - mark GHC.AnnDcolon -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigWcType st -#endif - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.PatSynSig ln (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do - mark GHC.AnnPattern - markLocated ln - mark GHC.AnnDcolon - - -- Note: The 'forall' bndrs '.' may occur multiple times - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - markLocated ctx1 - markOffset GHC.AnnDarrow 0 - markLocated ctx2 - markOffset GHC.AnnDarrow 1 - markLocated typ - markTrailingSemi -#else - markAST _ (GHC.PatSynSig ln (GHC.HsIB _ typ)) = do - mark GHC.AnnPattern - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.GenericSig ns typ) = do -#else - markAST _ (GHC.ClassOpSig _ ns (GHC.HsIB _ typ)) = do -#endif - mark GHC.AnnDefault - mapM_ markLocated ns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.IdSig _) = - traceM "warning: Introduced after renaming" - - -- FixSig (FixitySig name) -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do -#else - markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src _v fdir))) = do -#endif - let fixstr = case fdir of - GHC.InfixL -> "infixl" - GHC.InfixR -> "infixr" - GHC.InfixN -> "infix" - markWithString GHC.AnnInfix fixstr -#if __GLASGOW_HASKELL__ <= 710 - markWithString GHC.AnnVal (show v) -#else - markWithString GHC.AnnVal src -#endif - mapM_ markLocated lns - markTrailingSemi - - -- InlineSig (Located name) InlinePragma - -- '{-# INLINE' activation qvar '#-}' - markAST _ (GHC.InlineSig ln inl) = do - markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' - markActivation (GHC.inl_act inl) - markLocated ln - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.SpecSig ln typs inl) = do -#else - markAST _ (GHC.SpecSig ln typs inl) = do -{- - | SpecSig (Located name) -- Specialise a function or datatype ... - [LHsSigType name] -- ... to these types - InlinePragma -- The pragma on SPECIALISE_INLINE form. - -- If it's just defaultInlinePragma, then we said - -- SPECIALISE, not SPECIALISE_INLINE - --} -#endif - markWithString GHC.AnnOpen (GHC.inl_src inl) - markActivation (GHC.inl_act inl) - markLocated ln - mark GHC.AnnDcolon -- '::' -#if __GLASGOW_HASKELL__ <= 710 - mapM_ markLocated typs -#else - mapM_ markLHsSigType typs -#endif - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - -- '{-# SPECIALISE' 'instance' inst_type '#-}' - markAST _ (GHC.SpecInstSig src typ) = do - markWithString GHC.AnnOpen src - mark GHC.AnnInstance -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigType typ -#endif - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - - -- MinimalSig (BooleanFormula (Located name)) - markAST l (GHC.MinimalSig src formula) = do - markWithString GHC.AnnOpen src - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar] -#if __GLASGOW_HASKELL__ <= 710 - markAST l formula -#else - markLocated formula -#endif - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- -------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -#else -markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsSigType name -> Annotated () -markLHsSigType (GHC.HsIB _ typ) = markLocated typ - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.LHsSigType name] where - markAST l ls = do - mark GHC.AnnDeriving - markMany GHC.AnnOpenP - mapM_ markLHsSigType ls - markMany GHC.AnnCloseP -#endif - --- -------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 --- In practice, due to the way the BooleanFormula is constructed in the parser, --- we will get the following variants --- a | b : Or [a,b] --- a , b : And [a,b] --- ( a ) : a --- A bottom level Located RdrName is captured in a Var. This is the only part --- with a location in it. --- --- So the best strategy might be to convert all the annotations into comments, --- and then just print the names. DONE -instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where - markAST _ (GHC.Var x) = markLocated x - markAST l (GHC.Or ls) = mapM_ (markAST l) ls - markAST l (GHC.And ls) = mapM_ (markAST l) ls -#else -instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where - markAST _ (GHC.Var x) = do - markLocated x - mark GHC.AnnVbar -- '|' - markAST l (GHC.Or ls) = mapM_ markLocated ls - markAST l (GHC.And ls) = do - mapM_ markLocated ls - mark GHC.AnnVbar -- '|' - markAST _ (GHC.Parens x) = do - mark GHC.AnnOpenP -- '(' - markLocated x - mark GHC.AnnCloseP -- ')' - mark GHC.AnnVbar -- '|' -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsTyVarBndr name) where - markAST l (GHC.UserTyVar n) = do -#if __GLASGOW_HASKELL__ <= 710 - markAST l n -#else - markLocated n -#endif - - markAST _ (GHC.KindedTyVar n ty) = do - mark GHC.AnnOpenP -- '(' - markLocated n - mark GHC.AnnDcolon -- '::' - markLocated ty - mark GHC.AnnCloseP -- '(' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsType name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do - mark GHC.AnnOpenP -- "(" - mark GHC.AnnForall - mapM_ markLocated tvs - mark GHC.AnnDot - - case mwc of - Nothing -> if lc /= GHC.noSrcSpan then markLocated ctx else return () - Just lwc -> do - let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs) - markLocated (GHC.L lc sorted) - - mark GHC.AnnDarrow - markLocated typ - mark GHC.AnnCloseP -- ")" -#else - markAST _ (GHC.HsForAllTy tvs typ) = do - mark GHC.AnnOpenP -- "(" - mark GHC.AnnForall - mapM_ markLocated tvs - mark GHC.AnnDot - markLocated typ - mark GHC.AnnCloseP -- ")" - -{- - = HsForAllTy -- See Note [HsType binders] - { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType name -- body type - } - --} -#endif - -#if __GLASGOW_HASKELL__ <= 710 -#else - markAST l (GHC.HsQualTy cxt ty) = do - mark GHC.AnnDcolon -- for HsKind, alias for HsType - markLocated cxt - mark GHC.AnnDarrow - markLocated ty -{- - | HsQualTy -- See Note [HsType binders] - { hst_ctxt :: LHsContext name -- Context C => blah - , hst_body :: LHsType name } --} -#endif - - markAST l (GHC.HsTyVar name) = do - mark GHC.AnnDcolon -- for HsKind, alias for HsType - n <- countAnns GHC.AnnSimpleQuote - case n of - 1 -> do - mark GHC.AnnSimpleQuote - mark GHC.AnnOpenC -#if __GLASGOW_HASKELL__ <= 710 - markLocatedFromKw GHC.AnnName name - _ -> markAST l name -#else - markLocatedFromKw GHC.AnnName (GHC.unLoc name) - _ -> markLocated name -#endif - -#if __GLASGOW_HASKELL__ > 710 - markAST _ (GHC.HsAppsTy ts) = do - mapM_ markLocated ts -#endif - - markAST _ (GHC.HsAppTy t1 t2) = do - mark GHC.AnnDcolon -- for HsKind, alias for HsType - markLocated t1 - markLocated t2 - - markAST _ (GHC.HsFunTy t1 t2) = do - mark GHC.AnnDcolon -- for HsKind, alias for HsType - markLocated t1 - mark GHC.AnnRarrow - markLocated t2 - - markAST _ (GHC.HsListTy t) = do - mark GHC.AnnDcolon -- for HsKind, alias for HsType - mark GHC.AnnOpenS -- '[' - markLocated t - mark GHC.AnnCloseS -- ']' - - markAST _ (GHC.HsPArrTy t) = do - markWithString GHC.AnnOpen "[:" -- '[:' - markLocated t - markWithString GHC.AnnClose ":]" -- ':]' - - markAST _ (GHC.HsTupleTy _tt ts) = do - mark GHC.AnnDcolon -- for HsKind, alias for HsType - markWithString GHC.AnnOpen "(#" -- '(#' - mark GHC.AnnOpenP -- '(' - mapM_ markLocated ts - mark GHC.AnnCloseP -- ')' - markWithString GHC.AnnClose "#)" -- '#)' - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsOpTy t1 (_,lo) t2) = do -#else - markAST _ (GHC.HsOpTy t1 lo t2) = do - -- HsOpTy (LHsType name) (Located name) (LHsType name) -#endif - markLocated t1 - mark GHC.AnnSimpleQuote - markLocated lo - markLocated t2 - - markAST _ (GHC.HsParTy t) = do - mark GHC.AnnDcolon -- for HsKind, alias for HsType - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnCloseP -- ')' --- mark GHC.AnnDarrow -- May appear after context in a ConDecl - - markAST _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do - markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) - mark GHC.AnnDcolon - markLocated t - - markAST _ (GHC.HsEqTy t1 t2) = do - markLocated t1 - mark GHC.AnnTilde - markLocated t2 - - markAST _ (GHC.HsKindSig t k) = do - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnDcolon -- '::' - markLocated k - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsSpliceTy s _) = do - mark GHC.AnnOpenPE - markAST l s - mark GHC.AnnCloseP - - markAST _ (GHC.HsDocTy t ds) = do - markLocated t - markLocated ds - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsBangTy b t) = do - case b of - (GHC.HsSrcBang ms (Just True) _) -> do - markWithString GHC.AnnOpen (maybe "{-# UNPACK" id ms) - markWithString GHC.AnnClose "#-}" - (GHC.HsSrcBang ms (Just False) _) -> do - markWithString GHC.AnnOpen (maybe "{-# NOUNPACK" id ms) - markWithString GHC.AnnClose "#-}" - _ -> return () - mark GHC.AnnBang - markLocated t -#else - markAST _ (GHC.HsBangTy (GHC.HsSrcBang mt _up _str) t) = do - case mt of - Nothing -> return () - Just src -> do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - mark GHC.AnnBang - mark GHC.AnnTilde - markLocated t -{- - | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations -data HsSrcBang = - HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes - SrcUnpackedness - SrcStrictness -data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - -data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - --} -#endif - - -- HsRecTy [LConDeclField name] - markAST _ (GHC.HsRecTy cons) = do - mark GHC.AnnOpenC -- '{' - mapM_ markLocated cons - mark GHC.AnnCloseC -- '}' - - -- HsCoreTy Type - markAST _ (GHC.HsCoreTy _t) = - traceM "warning: HsCoreTy Introduced after renaming" - - markAST _ (GHC.HsExplicitListTy _ ts) = do - mark GHC.AnnSimpleQuote - mark GHC.AnnOpenS -- "[" - mapM_ markLocated ts - mark GHC.AnnCloseS -- ']' - - markAST _ (GHC.HsExplicitTupleTy _ ts) = do - mark GHC.AnnSimpleQuote - mark GHC.AnnOpenP - mapM_ markLocated ts - mark GHC.AnnCloseP - - -- HsTyLit HsTyLit - markAST l (GHC.HsTyLit lit) = do - case lit of - (GHC.HsNumTy s _) -> - markExternal l GHC.AnnVal s - (GHC.HsStrTy s _) -> - markExternal l GHC.AnnVal s - - -- HsWrapTy HsTyAnnotated (HsType name) -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsWrapTy _ _) = - traceM "warning: HsWrapTyy Introduced after renaming" -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.HsWildcardTy) = do - markExternal l GHC.AnnVal "_" - markAST l (GHC.HsNamedWildcardTy n) = do - markExternal l GHC.AnnVal (showGhc n) -#else - markAST l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do - markExternal l GHC.AnnVal "_" - -- markAST l (GHC.HsWildCardTy (GHC.NamedWildCard n)) = do - -- markExternal l GHC.AnnVal (showGhc n) -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.HsQuasiQuoteTy n) = do - markAST l n -#endif - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ <= 710 -#else -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsAppType name) where - markAST _ (GHC.HsAppInfix t) = do - mark GHC.AnnSimpleQuote - markLocated t - markAST _ (GHC.HsAppPrefix t) = do - mark GHC.AnnTilde - markLocated t -#endif --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsSplice name) where -#if __GLASGOW_HASKELL__ > 710 - markAST l c = - case c of - GHC.HsQuasiQuote _ n _pos fs -> do - markExternal l GHC.AnnVal - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") - -#if __GLASGOW_HASKELL__ <= 710 - GHC.HsTypedSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do -#else - GHC.HsTypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do -#endif - markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - markLocated b - GHC.HsTypedSplice _n b -> do - mark GHC.AnnOpenPTE - markLocated b - mark GHC.AnnCloseP - -#if __GLASGOW_HASKELL__ <= 710 - GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do -#else - GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do -#endif - markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - markLocated b - GHC.HsUntypedSplice _n b -> do - mark GHC.AnnThIdSplice - mark GHC.AnnOpenPE - markLocated b - mark GHC.AnnCloseP -#else - markAST _ c = - case c of - GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do - markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - markLocated b - GHC.HsSplice _n b -> do - mark GHC.AnnThIdSplice - mark GHC.AnnOpenPTE - mark GHC.AnnOpenPE - markLocated b - mark GHC.AnnCloseP -#endif - -#if __GLASGOW_HASKELL__ <= 710 -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsQuasiQuote name) where - markAST l (GHC.HsQuasiQuote n _pos fs) = do - markExternal l GHC.AnnVal - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => - Annotate (GHC.ConDeclField name) where - markAST _ (GHC.ConDeclField ns ty mdoc) = do -{- -data ConDeclField name -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_names :: [LFieldOcc name], - -- ^ See Note [ConDeclField names] - cd_fld_type :: LBangType name, - cd_fld_doc :: Maybe LHsDocString } - --} - mapM_ markLocated ns - mark GHC.AnnDcolon - markLocated ty - markMaybe mdoc - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ > 710 -instance (GHC.DataId name) - => Annotate (GHC.FieldOcc name) where - markAST l (GHC.FieldOcc rn _) = markLocated rn -#endif - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsDocString where - markAST l (GHC.HsDocString s) = do - markExternal l GHC.AnnVal (GHC.unpackFS s) - --- --------------------------------------------------------------------- -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.Pat name) where - markAST l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" - markAST l (GHC.VarPat n) = do -#if __GLASGOW_HASKELL__ <= 710 - markAST l n -#else - markAST l (GHC.unLoc n) -#endif - markAST _ (GHC.LazyPat p) = do - mark GHC.AnnTilde - markLocated p - - markAST _ (GHC.AsPat ln p) = do - markLocated ln - mark GHC.AnnAt - markLocated p - - markAST _ (GHC.ParPat p) = do - mark GHC.AnnOpenP - markLocated p - mark GHC.AnnCloseP - - markAST _ (GHC.BangPat p) = do - mark GHC.AnnBang - markLocated p - - markAST _ (GHC.ListPat ps _ _) = do - mark GHC.AnnOpenS - mapM_ markLocated ps - mark GHC.AnnCloseS - - markAST _ (GHC.TuplePat pats b _) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - mapM_ markLocated pats - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markAST _ (GHC.PArrPat ps _) = do - markWithString GHC.AnnOpen "[:" - mapM_ markLocated ps - markWithString GHC.AnnClose ":]" - - markAST _ (GHC.ConPatIn n dets) = do - markHsConPatDetails n dets - - markAST _ (GHC.ConPatOut {}) = - traceM "warning: ConPatOut Introduced after renaming" - - -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) - markAST _ (GHC.ViewPat e pat _) = do - markLocated e - mark GHC.AnnRarrow - markLocated pat - - -- SplicePat (HsSplice id) - markAST l (GHC.SplicePat s) = do - mark GHC.AnnOpenPE - markAST l s - mark GHC.AnnCloseP - - -- LitPat HsLit - markAST l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) - - -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.NPat ol _ _) = do -#else - markAST _ (GHC.NPat ol _ _ _) = do -#endif - mark GHC.AnnMinus - markLocated ol - - -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.NPlusKPat ln ol _ _) = do -#else - markAST _ (GHC.NPlusKPat ln ol _ _ _ _) = do -#endif - markLocated ln - markWithString GHC.AnnVal "+" -- "+" - markLocated ol - - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do - markLocated pat - mark GHC.AnnDcolon - markLocated ty -#else - markAST _ (GHC.SigPatIn pat ty) = do - markLocated pat - mark GHC.AnnDcolon - markLHsSigWcType ty -#endif - - markAST _ (GHC.SigPatOut {}) = - traceM "warning: SigPatOut introduced after renaming" - - -- CoPat HsAnnotated (Pat id) Type - markAST _ (GHC.CoPat {}) = - traceM "warning: CoPat introduced after renaming" - -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.QuasiQuotePat p) = markAST l p -#endif - --- --------------------------------------------------------------------- -hsLit2String :: GHC.HsLit -> GHC.SourceText -hsLit2String lit = - case lit of - GHC.HsChar src _ -> src - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - GHC.HsCharPrim src _ -> src ++ "#" - GHC.HsString src _ -> src - GHC.HsStringPrim src _ -> src - GHC.HsInt src _ -> src - GHC.HsIntPrim src _ -> src - GHC.HsWordPrim src _ -> src - GHC.HsInt64Prim src _ -> src - GHC.HsWord64Prim src _ -> src - GHC.HsInteger src _ _ -> src - GHC.HsRat (GHC.FL src _) _ -> src - GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" - GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" - -markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.Located name -> GHC.HsConPatDetails name -> Annotated () -markHsConPatDetails ln dets = do - case dets of - GHC.PrefixCon args -> do - markLocated ln - mapM_ markLocated args - GHC.RecCon (GHC.HsRecFields fs _) -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- '}' - GHC.InfixCon a1 a2 -> do - markLocated a1 - markLocated ln - markLocated a2 - -markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () -markHsConDeclDetails lns dets = do - case dets of - GHC.PrefixCon args -> mapM_ markLocated args - GHC.RecCon fs -> do - mark GHC.AnnOpenC - markLocated fs - mark GHC.AnnCloseC - GHC.InfixCon a1 a2 -> do - markLocated a1 - mapM_ markLocated lns - markLocated a2 - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.LConDeclField name] where - markAST _ fs = do - mark GHC.AnnOpenC -- '{' - mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC -- '}' - mark GHC.AnnRarrow - --- --------------------------------------------------------------------- - -instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where - markAST l ol = - let str = case GHC.ol_val ol of - GHC.HsIntegral src _ -> src - GHC.HsFractional l2 -> (GHC.fl_text l2) - GHC.HsIsString src _ -> src - in - markExternal l GHC.AnnVal str - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -instance (GHC.DataId name,Annotate arg) - => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where - markAST _ (GHC.HsWB thing _ _ _) = do - markLocated thing -#else -instance (GHC.DataId name,Annotate arg) - => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where - markAST _ (GHC.HsIB _ thing) = do - markLocated thing -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name - ,GHC.HasOccName name,Annotate body) - => Annotate (GHC.Stmt name (GHC.Located body)) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.LastStmt body _) = markLocated body -#else - markAST _ (GHC.LastStmt body _ _) = markLocated body -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.BindStmt pat body _ _) = do -#else - markAST _ (GHC.BindStmt pat body _ _ _) = do -#endif - markLocated pat - mark GHC.AnnLarrow - markLocated body - mark GHC.AnnVbar -- possible in list comprehension - markTrailingSemi - -#if __GLASGOW_HASKELL__ > 710 - markAST _ GHC.ApplicativeStmt{} - = error "ApplicativeStmt should not appear in ParsedSource" -#endif - - markAST _ (GHC.BodyStmt body _ _ _) = do - markLocated body - mark GHC.AnnVbar -- possible in list comprehension - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.LetStmt lb) = do -#else - markAST _ (GHC.LetStmt (GHC.L l lb)) = do -#endif - -- return () `debug` ("markP.LetStmt entered") - mark GHC.AnnLet - mark GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - markLocalBindsWithLayout lb - mark GHC.AnnCloseC -- '}' - -- return () `debug` ("markP.LetStmt done") - mark GHC.AnnVbar -- possible in list comprehension - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.ParStmt pbs _ _) = do -#else - markAST l (GHC.ParStmt pbs _ _ _) = do -#endif - mapM_ (markAST l) pbs - mark GHC.AnnVbar -- possible in list comprehension - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do -#else - markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do -#endif - mapM_ markLocated stmts - case form of - GHC.ThenForm -> do - mark GHC.AnnThen - markLocated using - case by of - Just b -> mark GHC.AnnBy >> markLocated b - Nothing -> return () - GHC.GroupForm -> do - mark GHC.AnnThen - mark GHC.AnnGroup - case by of - Just b -> mark GHC.AnnBy >> markLocated b - Nothing -> return () - mark GHC.AnnUsing - markLocated using - mark GHC.AnnVbar -- possible in list comprehension - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do -#else - markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do -#endif - mark GHC.AnnRec - mark GHC.AnnOpenC - markInside GHC.AnnSemi - mapM_ markLocated stmts - mark GHC.AnnCloseC - mark GHC.AnnVbar -- possible in list comprehension - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.ParStmtBlock name name) where - markAST _ (GHC.ParStmtBlock stmts _ns _) = - mapM_ markLocated stmts - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsLocalBinds name) where - markAST _ lb = markHsLocalBinds lb - --- --------------------------------------------------------------------- - -markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => (GHC.HsLocalBinds name) -> Annotated () -markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = - applyListAnnotations (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ) -markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsOut {})) - = traceM "warning: ValBindsOut introduced after renaming" - -markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ markLocated (reverse binds) -markHsLocalBinds (GHC.EmptyLocalBinds) = return () - --- --------------------------------------------------------------------- - -markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, - Annotate body) - => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) - -> Annotated () -#if __GLASGOW_HASKELL__ <= 710 -markMatchGroup _ (GHC.MG matches _ _ _) -#else -markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) -#endif - = markListWithLayout matches - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, - Annotate body) - => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsExpr name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.HsVar n) = markAST l n -#else - markAST l (GHC.HsVar n) = markAST l (GHC.unLoc n) -#endif - -#if __GLASGOW_HASKELL__ <= 710 -#else - markAST l (GHC.HsRecFld f) = markAST l f - - markAST l (GHC.HsOverLabel fs) - = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) -#endif - - markAST l (GHC.HsIPVar (GHC.HsIPName v)) = - markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) - markAST l (GHC.HsOverLit ov) = markAST l ov - markAST l (GHC.HsLit lit) = markAST l lit - - markAST _ (GHC.HsLam match) = do - mark GHC.AnnLam - -- TODO: Change this, HsLam binds do not need obey layout rules. -#if __GLASGOW_HASKELL__ <= 710 - mapM_ markLocated (GHC.mg_alts match) -#else - mapM_ markLocated (GHC.unLoc $ GHC.mg_alts match) -#endif - - markAST l (GHC.HsLamCase _ match) = do - mark GHC.AnnLam - mark GHC.AnnCase - mark GHC.AnnOpenC - markMatchGroup l match - mark GHC.AnnCloseC - - markAST _ (GHC.HsApp e1 e2) = do - markLocated e1 - markLocated e2 - - markAST _ (GHC.OpApp e1 e2 _ e3) = do - markLocated e1 - markLocated e2 - markLocated e3 - - markAST _ (GHC.NegApp e _) = do - mark GHC.AnnMinus - markLocated e - - markAST _ (GHC.HsPar e) = do - mark GHC.AnnOpenP -- '(' - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST _ (GHC.SectionL e1 e2) = do - markLocated e1 - markLocated e2 - - markAST _ (GHC.SectionR e1 e2) = do - markLocated e1 - markLocated e2 - - markAST _ (GHC.ExplicitTuple args b) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - - mapM_ markLocated args - - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - - markAST l (GHC.HsCase e1 matches) = setRigidFlag $ do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - mark GHC.AnnOpenC - markInside GHC.AnnSemi - markMatchGroup l matches - mark GHC.AnnCloseC - - -- We set the layout for HsIf even though it need not obey layout rules as - -- when moving these expressions it's useful that they maintain "internal - -- integrity", that is to say the subparts remain indented relative to each - -- other. - markAST _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do - mark GHC.AnnIf - markLocated e1 - markOffset GHC.AnnSemi 0 - mark GHC.AnnThen - markLocated e2 - markOffset GHC.AnnSemi 1 - mark GHC.AnnElse - markLocated e3 - - markAST _ (GHC.HsMultiIf _ rhs) = do - mark GHC.AnnIf - mark GHC.AnnOpenC - mapM_ markLocated rhs - mark GHC.AnnCloseC - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsLet binds e) = do -#else - markAST _ (GHC.HsLet (GHC.L _ binds) e) = do -#endif - setLayoutFlag (do -- Make sure the 'in' gets indented too - mark GHC.AnnLet - mark GHC.AnnOpenC - markInside GHC.AnnSemi - markLocalBindsWithLayout binds - mark GHC.AnnCloseC - mark GHC.AnnIn - markLocated e) - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsDo cts es _) = do -#else - markAST _ (GHC.HsDo cts (GHC.L _ es) _) = do -#endif - mark GHC.AnnDo - mark GHC.AnnMdo - let (ostr,cstr,_isComp) = - if isListComp cts - then case cts of - GHC.PArrComp -> ("[:",":]",True) - _ -> ("[", "]",True) - else ("{","}",False) - - markWithString GHC.AnnOpen ostr - mark GHC.AnnOpenS - mark GHC.AnnOpenC - markInside GHC.AnnSemi - if isListComp cts - then do - markLocated (last es) - mark GHC.AnnVbar - mapM_ markLocated (init es) - else do - markListWithLayout es - mark GHC.AnnCloseS - mark GHC.AnnCloseC - markWithString GHC.AnnClose cstr - - markAST _ (GHC.ExplicitList _ _ es) = do - mark GHC.AnnOpenS - mapM_ markLocated es - mark GHC.AnnCloseS - - markAST _ (GHC.ExplicitPArr _ es) = do - markWithString GHC.AnnOpen "[:" - mapM_ markLocated es - markWithString GHC.AnnClose ":]" - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do -#else - markAST _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs _)) = do -#endif - markLocated n - mark GHC.AnnOpenC - mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do -#else - markAST _ (GHC.RecordUpd e fs _cons _ _ _) = do -#endif - markLocated e - mark GHC.AnnOpenC - mapM_ markLocated fs - mark GHC.AnnDotdot - mark GHC.AnnCloseC - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ExprWithTySig e typ _) = do -#else - markAST _ (GHC.ExprWithTySig e typ) = do -#endif - markLocated e - mark GHC.AnnDcolon -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigWcType typ -#endif - - markAST _ (GHC.ExprWithTySigOut e typ) = do - markLocated e - mark GHC.AnnDcolon -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigWcType typ -#endif - - markAST _ (GHC.ArithSeq _ _ seqInfo) = do - mark GHC.AnnOpenS -- '[' - case seqInfo of - GHC.From e -> do - markLocated e - mark GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - markLocated e1 - mark GHC.AnnDotdot - markLocated e2 - GHC.FromThen e1 e2 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - markLocated e3 - mark GHC.AnnCloseS -- ']' - - markAST _ (GHC.PArrSeq _ seqInfo) = do - markWithString GHC.AnnOpen "[:" -- '[:' - case seqInfo of - GHC.From e -> do - markLocated e - mark GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - markLocated e1 - mark GHC.AnnDotdot - markLocated e2 - GHC.FromThen e1 e2 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - markLocated e1 - mark GHC.AnnComma - markLocated e2 - mark GHC.AnnDotdot - markLocated e3 - markWithString GHC.AnnClose ":]" -- ':]' - - markAST _ (GHC.HsSCC src csFStr e) = do - markWithString GHC.AnnOpen src -- "{-# SCC" -#if __GLASGOW_HASKELL__ <= 710 - markWithString GHC.AnnVal (GHC.unpackFS csFStr) - markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"") -#else - markWithString GHC.AnnVal (GHC.sl_st csFStr) - markWithString GHC.AnnValStr (GHC.sl_st csFStr) -#endif - markWithString GHC.AnnClose "#-}" - markLocated e - - markAST _ (GHC.HsCoreAnn src csFStr e) = do - markWithString GHC.AnnOpen src -- "{-# CORE" -#if __GLASGOW_HASKELL__ <= 710 - markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"") -#else - markWithString GHC.AnnVal (GHC.sl_st csFStr) -#endif - markWithString GHC.AnnClose "#-}" - markLocated e - -- TODO: make monomorphic - markAST _ (GHC.HsBracket (GHC.VarBr _single v)) = do - mark GHC.AnnSimpleQuote - mark GHC.AnnThTyQuote - markLocatedFromKw GHC.AnnName v - markAST _ (GHC.HsBracket (GHC.DecBrL ds)) = do - markWithString GHC.AnnOpen "[d|" - mark GHC.AnnOpenC - mapM_ markLocated ds - mark GHC.AnnCloseC - markWithString GHC.AnnClose "|]" - -- Introduced after the renamer - markAST _ (GHC.HsBracket (GHC.DecBrG _)) = - traceM "warning: DecBrG introduced after renamer" - markAST _ (GHC.HsBracket (GHC.ExpBr e)) = do -#if __GLASGOW_HASKELL__ <= 710 - -- This exists like this as the lexer collapses [e| and [| into the - -- same construtor - workOutString GHC.AnnOpen - (\ss -> if spanLength ss == 2 - then "[|" - else "[e|") -#else - markWithString GHC.AnnOpen "[|" - mark GHC.AnnOpenE -- "[e|" -#endif - markLocated e - markWithString GHC.AnnClose "|]" - markAST _ (GHC.HsBracket (GHC.TExpBr e)) = do -#if __GLASGOW_HASKELL__ <= 710 - -- This exists like this as the lexer collapses [e|| and [|| into the - -- same construtor - workOutString GHC.AnnOpen - (\ss -> if spanLength ss == 3 - then "[||" - else "[e||") -#else - markWithString GHC.AnnOpen "[||" - markWithString GHC.AnnOpenE "[e||" -#endif - markLocated e - markWithString GHC.AnnClose "||]" - markAST _ (GHC.HsBracket (GHC.TypBr e)) = do - markWithString GHC.AnnOpen "[t|" - markLocated e - markWithString GHC.AnnClose "|]" - markAST _ (GHC.HsBracket (GHC.PatBr e)) = do - markWithString GHC.AnnOpen "[p|" - markLocated e - markWithString GHC.AnnClose "|]" - - markAST _ (GHC.HsRnBracketOut _ _) = - traceM "warning: HsRnBracketOut introduced after renamer" - markAST _ (GHC.HsTcBracketOut _ _) = - traceM "warning: HsTcBracketOut introduced after renamer" - -#if __GLASGOW_HASKELL__ > 710 - markAST l (GHC.HsSpliceE e) = do - mark GHC.AnnOpenPE - markAST l e - mark GHC.AnnCloseP -#else - markAST l (GHC.HsSpliceE _ e) = do - mark GHC.AnnOpenPE - markAST l e - mark GHC.AnnCloseP - - markAST l (GHC.HsQuasiQuoteE e) = do - markAST l e -#endif - - markAST _ (GHC.HsProc p c) = do - mark GHC.AnnProc - markLocated p - mark GHC.AnnRarrow - markLocated c - - markAST _ (GHC.HsStatic e) = do - mark GHC.AnnStatic - markLocated e - - markAST _ (GHC.HsArrApp e1 e2 _ _ isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then markLocated e1 - else markLocated e2 - -- only one of the next 4 will be present - mark GHC.Annlarrowtail - mark GHC.Annrarrowtail - mark GHC.AnnLarrowtail - mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markAST _ (GHC.HsArrForm e _ cs) = do - markWithString GHC.AnnOpen "(|" - markLocated e - mapM_ markLocated cs - markWithString GHC.AnnClose "|)" - - markAST _ (GHC.HsTick _ _) = return () - markAST _ (GHC.HsBinTick _ _ _) = return () - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markWithString GHC.AnnOpen src - markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING - markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER - mark GHC.AnnMinus -- '-' - markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e -#else - markAST _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markWithString GHC.AnnOpen src - markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str) -- STRING - markOffsetWithString GHC.AnnVal 1 v1 -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOffsetWithString GHC.AnnVal 2 v2 -- INTEGER - mark GHC.AnnMinus -- '-' - markOffsetWithString GHC.AnnVal 3 v3 -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOffsetWithString GHC.AnnVal 4 v4 -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e -#endif - - markAST l (GHC.EWildPat) = do - markExternal l GHC.AnnVal "_" - - markAST _ (GHC.EAsPat ln e) = do - markLocated ln - mark GHC.AnnAt - markLocated e - - markAST _ (GHC.EViewPat e1 e2) = do - markLocated e1 - mark GHC.AnnRarrow - markLocated e2 - - markAST _ (GHC.ELazyPat e) = do - mark GHC.AnnTilde - markLocated e - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsType ty) = markLocated ty -#else - markAST _ (GHC.HsAppType e ty) = do - markLocated e - mark GHC.AnnAt - markLHsWcType ty - markAST _ (GHC.HsAppTypeOut _ _) = - traceM "warning: HsAppTypeOut introduced after renaming" -#endif - - markAST _ (GHC.HsWrap _ _) = - traceM "warning: HsWrap introduced after renaming" - markAST _ (GHC.HsUnboundVar _) = - traceM "warning: HsUnboundVar introduced after renaming" - - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 710 -markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsWcType name -> Annotated () -markLHsWcType (GHC.HsWC _ mwc ty) = do - case mwc of - Nothing -> markLocated ty - Just lwc -> do - -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty]) - -- markLocated (GHC.L lc sorted) - applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] - ++ prepareListAnnotation [ty] - ) -#endif --- --------------------------------------------------------------------- - -instance Annotate GHC.HsLit where - markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 710 -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsRecUpdField name) where - markAST _ (GHC.HsRecField lbl expr _isPun) = do - markLocated lbl - mark GHC.AnnEqual - markLocated expr -{- -type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id) - --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', --- --- For details on above see note [Api annotations] in ApiAnnotation -data HsRecField' id arg = HsRecField { - hsRecFieldLbl :: Located id, - hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning - hsRecPun :: Bool -- ^ Note [Punning] - } deriving (Data, Typeable) - --} - -instance (GHC.DataId name) - => Annotate (GHC.AmbiguousFieldOcc name) where - markAST l (GHC.Unambiguous n _) = markLocated n - markAST l (GHC.Ambiguous n _) = markLocated n -#endif --- --------------------------------------------------------------------- - --- |Used for declarations that need to be aligned together, e.g. in a --- do or let .. in statement/expr -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate ([GHC.ExprLStmt name]) where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsTupArg name) where - markAST _ (GHC.Present e) = do - markLocated e - - markAST _ (GHC.Missing _) = do - mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsCmdTop name) where - markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsCmd name) where - markAST _ (GHC.HsCmdArrApp e1 e2 _ _ isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then markLocated e1 - else markLocated e2 - -- only one of the next 4 will be present - mark GHC.Annlarrowtail - mark GHC.Annrarrowtail - mark GHC.AnnLarrowtail - mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markAST _ (GHC.HsCmdArrForm e _mf cs) = do - markWithString GHC.AnnOpen "(|" - -- This may be an infix operation - applyListAnnotations (prepareListAnnotation [e] - ++ prepareListAnnotation cs) - -- markLocated e - -- mapM_ markLocated cs - markWithString GHC.AnnClose "|)" - - markAST _ (GHC.HsCmdApp e1 e2) = do - markLocated e1 - markLocated e2 - - markAST l (GHC.HsCmdLam match) = do - mark GHC.AnnLam - markMatchGroup l match - - markAST _ (GHC.HsCmdPar e) = do - mark GHC.AnnOpenP - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsCmdCase e1 matches) = do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - mark GHC.AnnOpenC - markMatchGroup l matches - mark GHC.AnnCloseC - - markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do - mark GHC.AnnIf - markLocated e1 - markOffset GHC.AnnSemi 0 - mark GHC.AnnThen - markLocated e2 - markOffset GHC.AnnSemi 1 - mark GHC.AnnElse - markLocated e3 - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsCmdLet binds e) = do -#else - markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do -#endif - mark GHC.AnnLet - mark GHC.AnnOpenC - markLocalBindsWithLayout binds - mark GHC.AnnCloseC - mark GHC.AnnIn - markLocated e - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsCmdDo es _) = do -#else - markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do -#endif - mark GHC.AnnDo - mark GHC.AnnOpenC - markListWithLayout es - mark GHC.AnnCloseC - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsCmdCast {}) = - traceM "warning: HsCmdCast introduced after renaming" -#endif - -#if __GLASGOW_HASKELL__ > 710 - markAST _ (GHC.HsCmdWrap {}) = - traceM "warning: HsCmdWrap introduced after renaming" -{- - | HsCmdWrap HsWrapper - (HsCmd id) -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (HsCmdWrap wrap cmd) :: arg2 --> res --} -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.TyClDecl name) where - - markAST l (GHC.FamDecl famdecl) = markAST l famdecl - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do -#else - markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) typ _) = do -#endif - -- There may be arbitrary parens around parts of the constructor that are - -- infix. - -- Turn these into comments so that they feed into the right place automatically - annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] - mark GHC.AnnType - -- ln may be used infix, in which case rearrange the order. It may be - -- simplest to just sort ln:tyvars - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation tyvars) - -- markMany GHC.AnnCloseP - mark GHC.AnnEqual - markLocated typ - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) - (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _) = do -#else - markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _) - (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _ _) = do -#endif - mark GHC.AnnData - mark GHC.AnnNewtype - markMaybe mctyp - markLocated ctx - mark GHC.AnnDarrow - markTyClass ln tyVars - mark GHC.AnnDcolon - markMaybe mk - mark GHC.AnnEqual - mark GHC.AnnWhere - mark GHC.AnnOpenC - mapM_ markLocated cons - mark GHC.AnnCloseC - markMaybe mderivs - markTrailingSemi - - -- ----------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds - sigs meths ats atdefs docs _) = do -#else - markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds - sigs meths ats atdefs docs _) = do -#endif - mark GHC.AnnClass - markLocated ctx - - markTyClass ln tyVars - - mark GHC.AnnVbar - mapM_ markLocated fds - mark GHC.AnnWhere - mark GHC.AnnOpenC -- '{' - markInside GHC.AnnSemi - applyListAnnotations (prepareListAnnotation sigs - ++ prepareListAnnotation (GHC.bagToList meths) - ++ prepareListAnnotation ats - ++ prepareListAnnotation atdefs - ++ prepareListAnnotation docs - ) - mark GHC.AnnCloseC -- '}' - markTrailingSemi - --- --------------------------------------------------------------------- - -markTyClass :: (Annotate a, Annotate ast) - => GHC.Located a -> [GHC.Located ast] -> Annotated () -markTyClass ln tyVars = do - markMany GHC.AnnOpenP - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation (take 2 tyVars)) - markMany GHC.AnnCloseP - mapM_ markLocated (drop 2 tyVars) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.FamilyDecl name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do -#else - markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) rsig minj) = do -{- -data FamilyDecl name = FamilyDecl - { fdInfo :: FamilyInfo name -- type/data, closed/open - , fdLName :: Located name -- type constructor - , fdTyVars :: LHsQTyVars name -- type variables - , fdResultSig :: LFamilyResultSig name -- result signature - , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann - } --} -#endif - mark GHC.AnnType - mark GHC.AnnData - mark GHC.AnnFamily - mark GHC.AnnOpenP - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation tyvars) - mark GHC.AnnCloseP - mark GHC.AnnDcolon -#if __GLASGOW_HASKELL__ <= 710 - markMaybe mkind -#else - mark GHC.AnnEqual - markLocated rsig - mark GHC.AnnVbar - markMaybe minj -#endif - mark GHC.AnnWhere - mark GHC.AnnOpenC -- { - mark GHC.AnnDotdot - case info of -#if __GLASGOW_HASKELL__ > 710 - GHC.ClosedTypeFamily (Just eqns) -> mapM_ markLocated eqns -#else - GHC.ClosedTypeFamily eqns -> mapM_ markLocated eqns -#endif - _ -> return () - mark GHC.AnnCloseC -- } - markTrailingSemi - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -#else -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.FamilyResultSig name) where - markAST _ (GHC.NoSig) = return () - markAST _ (GHC.KindSig k) = markLocated k - markAST _ (GHC.TyVarSig ltv) = markLocated ltv -#endif - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -#else -instance (GHC.DataId name,Annotate name) - => Annotate (GHC.InjectivityAnn name) where - markAST l (GHC.InjectivityAnn ln lns) = do - mark GHC.AnnVbar - markLocated ln - mark GHC.AnnRarrow - mapM_ markLocated lns -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.TyFamInstEqn name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do -#else - markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do -#endif - mark GHC.AnnOpenP - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation pats) - mark GHC.AnnCloseP - mark GHC.AnnEqual - markLocated typ - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.TyFamDefltEqn name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do -#else - markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do -#endif - mark GHC.AnnType - mark GHC.AnnInstance - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation bndrs - ) - mark GHC.AnnEqual - markLocated typ - --- --------------------------------------------------------------------- - --- TODO: modify lexer etc, in the meantime to not set haddock flag -instance Annotate GHC.DocDecl where - markAST l v = - let str = - case v of - (GHC.DocCommentNext (GHC.HsDocString fs)) -> (GHC.unpackFS fs) - (GHC.DocCommentPrev (GHC.HsDocString fs)) -> (GHC.unpackFS fs) - (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> (GHC.unpackFS fs) - (GHC.DocGroup _i (GHC.HsDocString fs)) -> (GHC.unpackFS fs) - in - markExternal l (GHC.AnnVal) str - --- --------------------------------------------------------------------- - -markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () -markDataDefn _ (GHC.HsDataDefn _ ctx typ mk cons mderivs) = do - markLocated ctx - markMaybe typ -#if __GLASGOW_HASKELL__ <= 710 - markMaybe mk -#endif - mapM_ markLocated cons - case mderivs of - Nothing -> return () - Just d -> markLocated d - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.LHsType name] where - markAST _ ts = do -#if __GLASGOW_HASKELL__ <= 710 - mark GHC.AnnDeriving -#endif - markMany GHC.AnnOpenP -- may be nested parens around context - mapM_ markLocated ts - markMany GHC.AnnCloseP -- may be nested parens around context - markOutside GHC.AnnDarrow (G GHC.AnnDarrow) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.ConDecl name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx - dets res _ depc_syntax) = do - case res of - GHC.ResTyH98 -> do - - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - markLocated ctx - mark GHC.AnnDarrow - case dets of - GHC.InfixCon _ _ -> return () - _ -> mapM_ markLocated lns - - markHsConDeclDetails lns dets - - GHC.ResTyGADT ls ty -> do - -- only print names if not infix - case dets of - GHC.InfixCon _ _ -> return () - _ -> mapM_ markLocated lns - - if depc_syntax - then ( do - markHsConDeclDetails lns dets - mark GHC.AnnDcolon - markMany GHC.AnnOpenP - ) - - else ( do - mark GHC.AnnDcolon - markLocated (GHC.L ls (ResTyGADTHook bndrs)) - markMany GHC.AnnOpenP - markLocated ctx - mark GHC.AnnDarrow - markHsConDeclDetails lns dets ) - - markLocated ty - - markMany GHC.AnnCloseP - - - mark GHC.AnnVbar - markTrailingSemi -#else - markAST _ (GHC.ConDeclH98 ln mqtvs ctx - dets _ ) = do -{- - | ConDeclH98 - { con_name :: Located name - - , con_qvars :: Maybe (LHsQTyVars name) - -- User-written forall (if any), and its implicit - -- kind variables - -- Non-Nothing needs -XExistentialQuantification - -- e.g. data T a = forall b. MkT b (b->a) - -- con_qvars = {b} - - , con_cxt :: Maybe (LHsContext name) - -- ^ User-written context (if any) - - , con_details :: HsConDeclDetails name - -- ^ Arguments - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - --} - case mqtvs of - Nothing -> return () -#if __GLASGOW_HASKELL__ <= 710 - Just (GHC.HsQTvs _ns bndrs) -> do -#else - Just (GHC.HsQTvs _ns bndrs _) -> do -#endif - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - markMaybe ctx - mark GHC.AnnDarrow - case dets of - GHC.InfixCon _ _ -> return () - _ -> markLocated ln - - markHsConDeclDetails [ln] dets - - mark GHC.AnnVbar - markTrailingSemi - markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ) _) = do - mapM_ markLocated lns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi -#endif - --- ResTyGADT has a SrcSpan for the original sigtype, we need to create --- a type for exactPC and annotatePC -data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name] - deriving (Typeable) -deriving instance (GHC.DataId name) => Data (ResTyGADTHook name) -deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name) - -instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where - ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs - - -#if __GLASGOW_HASKELL__ > 710 --- WildCardAnon exists because the GHC anonymous wildcard type is defined as --- = AnonWildCard (PostRn name Name) --- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but --- the instance doing this is parameterised on name, so we cannot put a value in --- for the (PostRn name Name) field. This is used instead. -data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable) - -instance Annotate WildCardAnon where - markAST l WildCardAnon = do - markExternal l GHC.AnnVal "_" -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (ResTyGADTHook name) where - markAST _ (ResTyGADTHook bndrs) = do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - --- --------------------------------------------------------------------- - -instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.HsRecField name (GHC.LPat name)) where - markAST _ (GHC.HsRecField n e _) = do - markLocated n - mark GHC.AnnEqual - markLocated e - - -instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) where - markAST _ (GHC.HsRecField n e _) = do - markLocated n - mark GHC.AnnEqual - markLocated e - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name) - => Annotate (GHC.FunDep (GHC.Located name)) where - - markAST _ (ls,rs) = do - mapM_ markLocated ls - mark GHC.AnnRarrow - mapM_ markLocated rs - --- --------------------------------------------------------------------- - -instance Annotate (GHC.CType) where +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook +-- | 'annotate' is a function which given a GHC AST fragment, constructs +-- a syntax tree which indicates which annotations belong to each specific +-- part of the fragment. +-- +-- "Delta" and "Print" provide two interpreters for this structure. You +-- should probably use those unless you know what you're doing! +-- +-- The functor 'AnnotationF' has a number of constructors which correspond +-- to different sitations which annotations can arise. It is hoped that in +-- future versions of GHC these can be simplified by making suitable +-- modifications to the AST. + +module Language.Haskell.GHC.ExactPrint.Annotate + ( + annotate + , AnnotationF(..) + , Annotated + , Annotate(..) + , withSortKeyContextsHelper + ) where + +#if __GLASGOW_HASKELL__ <= 710 +import Data.Ord ( comparing ) +import Data.List ( sortBy ) +#endif + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified BooleanFormula as GHC +import qualified Class as GHC +import qualified CoAxiom as GHC +import qualified FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +#if __GLASGOW_HASKELL__ > 710 +import qualified Lexeme as GHC +#endif +import qualified Name as GHC +import qualified RdrName as GHC +import qualified Outputable as GHC + +import Control.Monad.Trans.Free +import Control.Monad.Free.TH (makeFreeCon) +import Control.Monad.Identity +import Data.Data +import Data.Maybe + +import qualified Data.Set as Set + +import Debug.Trace + + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- + +-- | ['MarkPrim'] The main constructor. Marks that a specific AnnKeywordId could +-- appear with an optional String which is used when printing. +-- ['MarkPPOptional'] Used to flag elements, such as optional braces, that are +-- not used in the pretty printer. This functions identically to 'MarkPrim' +-- for the other interpreters. +-- ['MarkEOF'] +-- Special constructor which marks the end of file marker. +-- ['MarkExternal'] TODO +-- ['MarkOutside'] A @AnnKeywordId@ which is precisely located but not inside the +-- current context. This is usually used to reassociated located +-- @RdrName@ which are more naturally associated with their parent than +-- in their own annotation. +-- ['MarkInside'] +-- The dual of MarkOutside. If we wish to mark a non-separating comma +-- or semi-colon then we must use this constructor. +-- ['MarkMany'] Some syntax elements allow an arbritary number of puncuation marks +-- without reflection in the AST. This construction greedily takes all of +-- the specified @AnnKeywordId@. +-- ['MarkOffsetPrim'] Some syntax elements have repeated @AnnKeywordId@ which are +-- seperated by different @AnnKeywordId@. Thus using MarkMany is +-- unsuitable and instead we provide an index to specify which specific +-- instance to choose each time. +-- ['WithAST'] TODO +-- ['CountAnns'] Sometimes the AST does not reflect the concrete source code and the +-- only way to tell what the concrete source was is to count a certain +-- kind of @AnnKeywordId@. +-- ['WithSortKey'] There are many places where the syntactic ordering of elements is +-- thrown away by the AST. This constructor captures the original +-- ordering and reflects any changes in ordered as specified by the +-- @annSortKey@ field in @Annotation@. +-- ['SetLayoutFlag'] It is important to know precisely where layout rules apply. This +-- constructor wraps a computation to indicate that LayoutRules apply to +-- the corresponding construct. +-- ['StoreOriginalSrcSpan'] TODO +-- ['GetSrcSpanFromKw'] TODO +-- ['StoreString'] TODO +-- ['AnnotationsToComments'] Used when the AST is sufficiently vague that there is no other +-- option but to convert a fragment of source code into a comment. This +-- means it is impossible to edit such a fragment but means that +-- processing files with such fragments is still possible. +data AnnotationF next where + MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next + MarkPPOptional :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next + MarkEOF :: next -> AnnotationF next + MarkExternal :: GHC.SrcSpan -> GHC.AnnKeywordId -> String -> next -> AnnotationF next + MarkOutside :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next + MarkInside :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkManyOptional :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next + MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next + WithAST :: Data a => GHC.Located a + -> Annotated b -> next -> AnnotationF next + CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next + WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next + + SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next + + -- Required to work around deficiencies in the GHC AST + StoreOriginalSrcSpan :: GHC.SrcSpan -> AnnKey -> (AnnKey -> next) -> AnnotationF next + GetSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next +#if __GLASGOW_HASKELL__ <= 710 + StoreString :: String -> GHC.SrcSpan -> next -> AnnotationF next +#endif + AnnotationsToComments :: [GHC.AnnKeywordId] -> next -> AnnotationF next +#if __GLASGOW_HASKELL__ <= 710 + AnnotationsToCommentsBF :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> next -> AnnotationF next + FinalizeBF :: GHC.SrcSpan -> next -> AnnotationF next +#endif + + -- AZ experimenting with pretty printing + -- Set the context for child element + SetContextLevel :: Set.Set AstContext -> Int -> Annotated () -> next -> AnnotationF next + UnsetContext :: AstContext -> Annotated () -> next -> AnnotationF next + -- Query the context while in a child element + IfInContext :: Set.Set AstContext -> Annotated () -> Annotated () -> next -> AnnotationF next + WithSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next + -- + TellContext :: Set.Set AstContext -> next -> AnnotationF next + +deriving instance Functor AnnotationF + +type Annotated = FreeT AnnotationF Identity + + +-- --------------------------------------------------------------------- + +makeFreeCon 'MarkEOF +makeFreeCon 'MarkPrim +makeFreeCon 'MarkPPOptional +makeFreeCon 'MarkOutside +makeFreeCon 'MarkInside +makeFreeCon 'MarkExternal +makeFreeCon 'MarkMany +makeFreeCon 'MarkManyOptional +makeFreeCon 'MarkOffsetPrim +makeFreeCon 'MarkOffsetPrimOptional +makeFreeCon 'CountAnns +makeFreeCon 'StoreOriginalSrcSpan +makeFreeCon 'GetSrcSpanForKw +#if __GLASGOW_HASKELL__ <= 710 +makeFreeCon 'StoreString +#endif +makeFreeCon 'AnnotationsToComments +#if __GLASGOW_HASKELL__ <= 710 +makeFreeCon 'AnnotationsToCommentsBF +makeFreeCon 'FinalizeBF +#endif +makeFreeCon 'WithSortKey +makeFreeCon 'SetContextLevel +makeFreeCon 'UnsetContext +makeFreeCon 'IfInContext +makeFreeCon 'WithSortKeyContexts +makeFreeCon 'TellContext + +-- --------------------------------------------------------------------- + +setContext :: Set.Set AstContext -> Annotated () -> Annotated () +setContext ctxt action = liftF (SetContextLevel ctxt 3 action ()) + +setLayoutFlag :: Annotated () -> Annotated () +setLayoutFlag action = liftF (SetLayoutFlag NormalLayout action ()) + +setRigidFlag :: Annotated () -> Annotated () +setRigidFlag action = liftF (SetLayoutFlag RigidLayout action ()) + +-- | Construct a syntax tree which represent which KeywordIds must appear +-- where. +annotate :: (Annotate ast) => GHC.Located ast -> Annotated () +annotate = markLocated + +inContext :: Set.Set AstContext -> Annotated () -> Annotated () +inContext ctxt action = liftF (IfInContext ctxt action (return ()) ()) + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +workOutString :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated () +workOutString l kw f = do + ss <- getSrcSpanForKw l kw + storeString (f ss) ss +#endif + +-- --------------------------------------------------------------------- + +-- |Main driver point for annotations. +withAST :: Data a => GHC.Located a -> Annotated () -> Annotated () +withAST lss action = liftF (WithAST lss action ()) + +-- --------------------------------------------------------------------- +-- Additional smart constructors + +mark :: GHC.AnnKeywordId -> Annotated () +mark kwid = markPrim kwid Nothing + +markOptional :: GHC.AnnKeywordId -> Annotated () +markOptional kwid = markPPOptional kwid Nothing + +markWithString :: GHC.AnnKeywordId -> String -> Annotated () +markWithString kwid s = markPrim kwid (Just s) + +markWithStringOptional :: GHC.AnnKeywordId -> String -> Annotated () +markWithStringOptional kwid s = markPPOptional kwid (Just s) + +markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated () +markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s) + +markOffset :: GHC.AnnKeywordId -> Int -> Annotated () +markOffset kwid n = markOffsetPrim kwid n Nothing + +markOffsetOptional :: GHC.AnnKeywordId -> Int -> Annotated () +markOffsetOptional kwid n = markOffsetPrimOptional kwid n Nothing + +markTrailingSemi :: Annotated () +markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep + +-- --------------------------------------------------------------------- + +-- | Constructs a syntax tree which contains information about which +-- annotations are required by each element. +markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () +markLocated ast = + case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) of + Just d -> markLHsDecl d + Nothing -> withLocated ast markAST + +withLocated :: Data a + => GHC.Located a + -> (GHC.SrcSpan -> a -> Annotated ()) + -> Annotated () +withLocated a@(GHC.L l ast) action = + withAST a (action l ast) + +-- --------------------------------------------------------------------- + +-- |When adding missing annotations, do not put a preceding space in front of a list +markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () +markListNoPrecedingSpace intercal ls = + case ls of + [] -> return () + (l:ls') -> do + if intercal + then do + if null ls' + then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l + else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l + markListIntercalate ls' + else do + setContext (Set.singleton NoPrecedingSpace) $ markLocated l + mapM_ markLocated ls' + +-- --------------------------------------------------------------------- + + +-- |Mark a list, with the given keyword as a list item separator +markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () +markListIntercalate ls = markListIntercalateWithFun markLocated ls + +markListIntercalateWithFun :: (t -> Annotated ()) -> [t] -> Annotated () +markListIntercalateWithFun f ls = markListIntercalateWithFunLevel f 2 ls + +markListIntercalateWithFunLevel :: (t -> Annotated ()) -> Int -> [t] -> Annotated () +markListIntercalateWithFunLevel f level ls = markListIntercalateWithFunLevelCtx f level Intercalate ls + +markListIntercalateWithFunLevelCtx :: (t -> Annotated ()) -> Int -> AstContext -> [t] -> Annotated () +markListIntercalateWithFunLevelCtx f level ctx ls = go ls + where + go [] = return () + go [x] = f x + go (x:xs) = do + setContextLevel (Set.singleton ctx) level $ f x + go xs + +-- --------------------------------------------------------------------- + +markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () +markListWithContexts ctxInitial ctxRest ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxInitial 2 $ markLocated x + (x:xs) -> do + setContextLevel ctxInitial 2 $ markLocated x + setContextLevel ctxRest 2 $ mapM_ markLocated xs + +-- --------------------------------------------------------------------- + +-- Context for only if just one, else first item, middle ones, and last one +markListWithContexts' :: Annotate ast + => ListContexts + -> [GHC.Located ast] -> Annotated () +markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxOnly level $ markLocated x + (x:xs) -> do + setContextLevel ctxInitial level $ markLocated x + go xs + where + level = 2 + go [] = return () + go [x] = setContextLevel ctxLast level $ markLocated x + go (x:xs) = do + setContextLevel ctxMiddle level $ markLocated x + go xs + + +markListWithContextsFunction :: + ListContexts + -> (t -> Annotated ()) + -> [t] -> Annotated () +markListWithContextsFunction (LC ctxOnly ctxInitial ctxMiddle ctxLast) f ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxOnly level $ f x + (x:xs) -> do + setContextLevel ctxInitial level $ f x + go xs + where + level = 2 + go [] = return () + go [x] = setContextLevel ctxLast level $ f x + go (x:xs) = do + setContextLevel ctxMiddle level $ f x + go xs + +-- --------------------------------------------------------------------- + + +-- Expects the kws to be ordered already +withSortKeyContextsHelper :: (Monad m) => (Annotated () -> m ()) -> ListContexts -> [(GHC.SrcSpan, Annotated ())] -> m () +withSortKeyContextsHelper interpret (LC ctxOnly ctxInitial ctxMiddle ctxLast) kws = do + case kws of + [] -> return () + [x] -> interpret (setContextLevel (Set.insert (CtxPos 0) ctxOnly) level $ snd x) + (x:xs) -> do + interpret (setContextLevel (Set.insert (CtxPos 0) ctxInitial) level $ snd x) + go 1 xs + where + level = 2 + go _ [] = return () + go n [x] = interpret (setContextLevel (Set.insert (CtxPos n) ctxLast) level $ snd x) + go n (x:xs) = do + interpret (setContextLevel (Set.insert (CtxPos n) ctxMiddle) level $ snd x) + go (n+1) xs + +-- --------------------------------------------------------------------- + +markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () +markListWithLayout ls = + setLayoutFlag $ markList ls + +-- --------------------------------------------------------------------- + +markList :: Annotate ast => [GHC.Located ast] -> Annotated () +markList ls = + setContext (Set.singleton NoPrecedingSpace) + $ markListWithContexts' listContexts' ls + +markLocalBindsWithLayout :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.HsLocalBinds name -> Annotated () +markLocalBindsWithLayout binds = + markHsLocalBinds binds + +-- --------------------------------------------------------------------- + +-- |This function is used to get around shortcomings in the GHC AST for 7.10.1 +markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () +markLocatedFromKw kw (GHC.L l a) = do + -- Note: l is needed so that the pretty printer can make something up + ss <- getSrcSpanForKw l kw + AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) + markLocated (GHC.L ss' a) + +-- --------------------------------------------------------------------- + +markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () +markMaybe Nothing = return () +markMaybe (Just ast) = markLocated ast + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] +prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls + +-- prepareListAnnotationWithContext :: Annotate a => Set.Set AstContext +-- -> [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] +-- prepareListAnnotationWithContext ctx ls = map (\b -> (GHC.getLoc b,setContext ctx (markLocated b))) ls + +applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotations ls = withSortKey ls + +applyListAnnotationsContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotationsContexts ctxt ls = withSortKeyContexts ctxt ls + +#if __GLASGOW_HASKELL__ <= 710 +lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a] +lexicalSortLocated = sortBy (comparing GHC.getLoc) +#endif + +applyListAnnotationsLayout :: [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotationsLayout ls = setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) + $ withSortKeyContexts listContexts ls + +listContexts :: ListContexts +listContexts = LC (Set.fromList [CtxOnly,ListStart]) + (Set.fromList [CtxFirst,ListStart,Intercalate]) + (Set.fromList [CtxMiddle,ListItem,Intercalate]) + (Set.fromList [CtxLast,ListItem]) + +listContexts' :: ListContexts +listContexts' = LC (Set.fromList [CtxOnly, ListStart]) + (Set.fromList [CtxFirst, ListStart]) + (Set.fromList [CtxMiddle,ListItem]) + (Set.fromList [CtxLast, ListItem]) + +-- --------------------------------------------------------------------- + +class Data ast => Annotate ast where + markAST :: GHC.SrcSpan -> ast -> Annotated () + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsModule GHC.RdrName) where + markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do + + case mmn of + Nothing -> return () + Just (GHC.L ln mn) -> do + mark GHC.AnnModule + markExternal ln GHC.AnnVal (GHC.moduleNameString mn) + + forM_ mdepr markLocated + forM_ mexp markLocated + + mark GHC.AnnWhere + + markOptional GHC.AnnOpenC -- Possible '{' + markManyOptional GHC.AnnSemi -- possible leading semis + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps + + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs + + markOptional GHC.AnnCloseC -- Possible '}' + + markEOF + +-- --------------------------------------------------------------------- + +instance Annotate GHC.WarningTxt where + markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 710 +instance Annotate GHC.StringLiteral where + markAST l (GHC.StringLiteral src _) = do + markExternal l GHC.AnnVal src + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma +#endif + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.SourceText,GHC.FastString) where + markAST l (src,_fs) = do + markExternal l GHC.AnnVal src + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LIE name] where + markAST _ ls = do + inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl + mark GHC.AnnOpenP -- '(' + -- Can't use markListIntercalate, there can be trailing commas, but only in imports. + markListIntercalateWithFunLevel markLocated 2 ls + + mark GHC.AnnCloseP -- ')' + +instance (GHC.DataId name,GHC.HasOccName name, Annotate name) + => Annotate (GHC.IE name) where + markAST _ ie = do + + case ie of + (GHC.IEVar ln) -> do + -- TODO: I am pretty sure this criterion is inadequate + if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln + then mark GHC.AnnPattern + else markOptional GHC.AnnPattern + setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln + + (GHC.IEThingAbs ln@(GHC.L _ n)) -> do + {- + At the moment (7.10.2) GHC does not cleanly represent an export of the form + "type Foo" + and it only captures the name "Foo". + + The Api Annotations workaround is to have the IEThingAbs SrcSpan + extend across both the "type" and "Foo", and then to capture the + individual item locations in an AnnType and AnnVal annotation. + + This need to be fixed for 7.12. + + -} + +#if __GLASGOW_HASKELL__ <= 710 + if GHC.isTcOcc (GHC.occName n) && GHC.isSymOcc (GHC.occName n) +#else + if ((GHC.isTcOcc $ GHC.occName n) && (GHC.isSymOcc $ GHC.occName n)) + && (not $ GHC.isLexConSym $ GHC.occNameFS $ GHC.occName n) -- rule out (:-$) etc +#endif + then do + mark GHC.AnnType + setContext (Set.singleton PrefixOp) $ markLocatedFromKw GHC.AnnVal ln + else setContext (Set.singleton PrefixOp) $ markLocated ln + +#if __GLASGOW_HASKELL__ <= 710 + (GHC.IEThingWith ln ns) -> do +#else + (GHC.IEThingWith ln wc ns _lfs) -> do +{- + | IEThingWith (Located name) + IEWildcard + [Located name] + [Located (FieldLbl name)] + -- ^ Class/Type plus some methods/constructors + -- and record fields; see Note [IEThingWith] + +-} +#endif + setContext (Set.singleton PrefixOp) $ markLocated ln + mark GHC.AnnOpenP +#if __GLASGOW_HASKELL__ <= 710 + setContext (Set.singleton PrefixOp) $ markListIntercalate ns +#else + case wc of + GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns + GHC.IEWildcard n -> do + setContext (Set.fromList [PrefixOp,Intercalate]) $ mapM_ markLocated (take n ns) + mark GHC.AnnDotdot + case drop n ns of + [] -> return () + ns' -> do + mark GHC.AnnComma + setContext (Set.singleton PrefixOp) $ mapM_ markLocated ns' +#endif + mark GHC.AnnCloseP + + (GHC.IEThingAll ln) -> do + setContext (Set.fromList [PrefixOp]) $ markLocated ln + mark GHC.AnnOpenP + mark GHC.AnnDotdot + mark GHC.AnnCloseP + + (GHC.IEModuleContents (GHC.L lm mn)) -> do + mark GHC.AnnModule + markExternal lm GHC.AnnVal (GHC.moduleNameString mn) + + -- Only used in Haddock mode so we can ignore them. + (GHC.IEGroup _ _) -> return () + + (GHC.IEDoc _) -> return () + + (GHC.IEDocNamed _) -> return () + ifInContext (Set.fromList [Intercalate]) + (mark GHC.AnnComma) + (markOptional GHC.AnnComma) + +-- --------------------------------------------------------------------- +{- +-- For details on above see note [Api annotations] in ApiAnnotation +data RdrName + = Unqual OccName + -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving (Data, Typeable) +-} + +isSymRdr :: GHC.RdrName -> Bool +isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." + +instance Annotate GHC.RdrName where + markAST l n = do + let + str = rdrName2String n + isSym = isSymRdr n + canParen = isSym && rdrName2String n /= "$" + doNormalRdrName = do + let str' = case str of + -- TODO: unicode support? + "forall" -> if spanLength l == 1 then "∀" else str + _ -> str + when (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) $ inContext (Set.singleton InIE) $ mark GHC.AnnType + markOptional GHC.AnnType + let str'' = if isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) + then -- Horrible hack until GHC 8.2 with https://phabricator.haskell.org/D3016 + if spanLength l - length str' > 6 -- length of "type" + 2 parens + then "(" ++ str' ++ ")" + else str' + else str' + + let + markParen :: GHC.AnnKeywordId -> Annotated () + markParen pa = do + if canParen + then ifInContext (Set.singleton PrefixOp) + (mark pa) -- '(' + (markOptional pa) + else if isSym + then ifInContext (Set.singleton PrefixOpDollar) + (mark pa) + (markOptional pa) + else markOptional pa + + markParen GHC.AnnOpenP + unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 + cnt <- countAnns GHC.AnnVal + case cnt of + 0 -> markExternal l GHC.AnnVal str' + 1 -> markWithString GHC.AnnVal str'' + _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) + unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 + markParen GHC.AnnCloseP + + case n of + GHC.Unqual _ -> doNormalRdrName + GHC.Qual _ _ -> doNormalRdrName +#if __GLASGOW_HASKELL__ <= 710 + GHC.Orig _ _ -> markExternal l GHC.AnnVal str +#else + GHC.Orig _ _ -> if str == "~" + then doNormalRdrName + else markExternal l GHC.AnnVal str +#endif + GHC.Exact n' -> do + case str of + -- Special handling for Exact RdrNames, which are built-in Names + "[]" -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnCloseS -- ']' + "()" -> do + mark GHC.AnnOpenP -- '(' + mark GHC.AnnCloseP -- ')' + ('(':'#':_) -> do + markWithString GHC.AnnOpen "(#" -- '(#' + let cnt = length $ filter (==',') str + replicateM_ cnt (mark GHC.AnnCommaTuple) + markWithString GHC.AnnClose "#)"-- '#)' + "[::]" -> do + markWithString GHC.AnnOpen "[:" -- '[:' + markWithString GHC.AnnClose ":]" -- ':]' + "(->)" -> do + mark GHC.AnnOpenP -- '(' + mark GHC.AnnRarrow + mark GHC.AnnCloseP -- ')' + "~#" -> do + mark GHC.AnnOpenP -- '(' + mark GHC.AnnTildehsh + mark GHC.AnnCloseP + "*" -> do + markExternal l GHC.AnnVal str + "★" -> do -- Note: unicode star + markExternal l GHC.AnnVal str + ":" -> do + -- Note: The OccName for ":" has the following attributes (via occAttributes) + -- (d, Data DataSym Sym Val ) + -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + doNormalRdrName + -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName + ('(':',':_) -> do + mark GHC.AnnOpenP + let cnt = length $ filter (==',') str + replicateM_ cnt (mark GHC.AnnCommaTuple) + mark GHC.AnnCloseP -- ')' +#if __GLASGOW_HASKELL__ <= 710 + "~" -> do + mark GHC.AnnOpenP + mark GHC.AnnTilde + mark GHC.AnnCloseP +#endif + _ -> do + let isSym' = isSymRdr (GHC.nameRdrName n') + when isSym' $ mark GHC.AnnOpenP -- '(' + markWithString GHC.AnnVal str + when isSym $ mark GHC.AnnCloseP -- ')' + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") + +-- --------------------------------------------------------------------- + +-- TODO: What is this used for? Not in ExactPrint +instance Annotate GHC.Name where + markAST l n = do + markExternal l GHC.AnnVal (showGhc n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ImportDecl name) where + markAST _ imp@(GHC.ImportDecl msrc modname mpkg src safeflag qualFlag _impl _as hiding) = do + + -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + mark GHC.AnnImport + + -- "{-# SOURCE" and "#-}" + when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) + >> markWithString GHC.AnnClose "#-}") + when safeflag (mark GHC.AnnSafe) + when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) + case mpkg of + Nothing -> return () +#if __GLASGOW_HASKELL__ <= 710 + Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg)) +#else + Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg +#endif + + markLocated modname + + case GHC.ideclAs imp of + Nothing -> return () + Just mn -> do + mark GHC.AnnAs + markWithString GHC.AnnVal (GHC.moduleNameString mn) + + case hiding of + Nothing -> return () + Just (isHiding,lie) -> do + if isHiding + then setContext (Set.singleton HasHiding) $ + markLocated lie + else markLocated lie + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate GHC.ModuleName where + markAST l mname = + markExternal l GHC.AnnVal (GHC.moduleNameString mname) + +-- --------------------------------------------------------------------- + +markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsDecl name -> Annotated () +markLHsDecl (GHC.L l decl) = + case decl of + GHC.TyClD d -> markLocated (GHC.L l d) + GHC.InstD d -> markLocated (GHC.L l d) + GHC.DerivD d -> markLocated (GHC.L l d) + GHC.ValD d -> markLocated (GHC.L l d) + GHC.SigD d -> markLocated (GHC.L l d) + GHC.DefD d -> markLocated (GHC.L l d) + GHC.ForD d -> markLocated (GHC.L l d) + GHC.WarningD d -> markLocated (GHC.L l d) + GHC.AnnD d -> markLocated (GHC.L l d) + GHC.RuleD d -> markLocated (GHC.L l d) + GHC.VectD d -> markLocated (GHC.L l d) + GHC.SpliceD d -> markLocated (GHC.L l d) + GHC.DocD d -> markLocated (GHC.L l d) + GHC.RoleAnnotD d -> markLocated (GHC.L l d) +#if __GLASGOW_HASKELL__ < 711 + GHC.QuasiQuoteD d -> markLocated (GHC.L l d) +#endif + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsDecl name) where + markAST l d = markLHsDecl (GHC.L l d) + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.RoleAnnotDecl name) where + markAST _ (GHC.RoleAnnotDecl ln mr) = do + mark GHC.AnnType + mark GHC.AnnRole + markLocated ln + mapM_ markLocated mr + +instance Annotate (Maybe GHC.Role) where + markAST l Nothing = markExternal l GHC.AnnVal "_" + markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.SpliceDecl name) where +#if __GLASGOW_HASKELL__ > 710 + markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do + setContext (Set.singleton InSpliceDecl) $ markLocated e + markTrailingSemi +#endif + markAST _ (GHC.SpliceDecl e flag) = do + case flag of + GHC.ExplicitSplice -> mark GHC.AnnOpenPE + GHC.ImplicitSplice -> return () + + setContext (Set.singleton InSpliceDecl) $ markLocated e + + case flag of + GHC.ExplicitSplice -> mark GHC.AnnCloseP + GHC.ImplicitSplice -> return () + + markTrailingSemi + +{- +- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) +- ImplicitSplice -- <=> f x y, i.e. a naked +- top level expression +- +-} + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.VectDecl name) where + markAST _ (GHC.HsVect src ln e) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + markLocated ln + mark GHC.AnnEqual + markLocated e + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsNoVect src ln) = do + markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsVectTypeIn src _b ln mln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" + mark GHC.AnnType + markLocated ln + case mln of + Nothing -> return () + Just lnn -> do + mark GHC.AnnEqual + markLocated lnn + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectTypeOut {} = + traceM "warning: HsVectTypeOut appears after renaming" + + markAST _ (GHC.HsVectClassIn src ln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + mark GHC.AnnClass + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectClassOut {} = + traceM "warning: HsVecClassOut appears after renaming" + markAST _ GHC.HsVectInstIn {} = + traceM "warning: HsVecInstsIn appears after renaming" + markAST _ GHC.HsVectInstOut {} = + traceM "warning: HsVecInstOut appears after renaming" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleDecls name) where + markAST _ (GHC.HsRules src rules) = do + markWithString GHC.AnnOpen src + setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleDecl name) where + markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do + markLocated ln + setContext (Set.singleton ExplicitNeverActive) $ markActivation act + + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated lhs + mark GHC.AnnEqual + markLocated rhs + inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + markTrailingSemi + +-- --------------------------------------------------------------------- + +markActivation :: GHC.Activation -> Annotated () +markActivation act = do +#if __GLASGOW_HASKELL__ <= 710 + case act of + GHC.ActiveBefore n -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + markWithString GHC.AnnVal (show n) + mark GHC.AnnCloseS -- ']' + GHC.ActiveAfter n -> do + mark GHC.AnnOpenS -- '[' + markWithString GHC.AnnVal (show n) + mark GHC.AnnCloseS -- ']' + GHC.NeverActive -> do + inContext (Set.singleton ExplicitNeverActive) $ do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + mark GHC.AnnCloseS -- ']' + _ -> return () +#else + case act of + GHC.ActiveBefore src _ -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + markWithString GHC.AnnVal src + mark GHC.AnnCloseS -- ']' + GHC.ActiveAfter src _ -> do + mark GHC.AnnOpenS -- '[' + markWithString GHC.AnnVal src + mark GHC.AnnCloseS -- ']' + GHC.NeverActive -> do + inContext (Set.singleton ExplicitNeverActive) $ do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + mark GHC.AnnCloseS -- ']' + _ -> return () +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleBndr name) where + markAST _ (GHC.RuleBndr ln) = markLocated ln +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLocated thing + mark GHC.AnnCloseP -- ")" +#else + markAST _ (GHC.RuleBndrSig ln st) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLHsSigWcType st + mark GHC.AnnCloseP -- ")" +#endif +-- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 710 +markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsSigWcType name -> Annotated () +markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do + case mwc of + Nothing -> markLocated ty + Just lwc -> do + applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] + ++ prepareListAnnotation [ty] + ) +#endif +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.AnnDecl name) where + markAST _ (GHC.HsAnnotation src prov e) = do + markWithString GHC.AnnOpen src + case prov of + (GHC.ValueAnnProvenance n) -> markLocated n + (GHC.TypeAnnProvenance n) -> do + mark GHC.AnnType + markLocated n + GHC.ModuleAnnProvenance -> mark GHC.AnnModule + + markLocated e + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate name => Annotate (GHC.WarnDecls name) where + markAST _ (GHC.Warnings src warns) = do + markWithString GHC.AnnOpen src + mapM_ markLocated warns + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.WarnDecl name) where + markAST _ (GHC.Warning lns txt) = do + markListIntercalate lns + mark GHC.AnnOpenS -- "[" + case txt of + GHC.WarningTxt _src ls -> markListIntercalate ls + GHC.DeprecatedTxt _src ls -> markListIntercalate ls + mark GHC.AnnCloseS -- "]" + +instance Annotate GHC.FastString where + -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. + markAST l fs = do + markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ForeignDecl name) where +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.ForeignImport ln typ _ + (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do +#else + markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _ + (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do +{- + = ForeignImport + { fd_name :: Located name -- defines this name + , fd_sig_ty :: LHsSigType name -- sig_ty + , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + , fd_fi :: ForeignImport } + +-} +#endif + mark GHC.AnnForeign + mark GHC.AnnImport + markLocated cconv + unless (ll == GHC.noSrcSpan) $ markLocated safety +#if __GLASGOW_HASKELL__ <= 710 + markExternal ls GHC.AnnVal (show src) +#else + if GHC.unLoc cconv == GHC.PrimCallConv + then markExternal ls GHC.AnnVal src +#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) + else markExternal ls GHC.AnnVal src +#else + else markExternal ls GHC.AnnVal (show src) +#endif +#endif + markLocated ln + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + +#if __GLASGOW_HASKELL__ <= 710 + markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do +#else + markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ) _ (GHC.CExport spec (GHC.L ls src))) = do +#endif + mark GHC.AnnForeign + mark GHC.AnnExport + markLocated spec + markExternal ls GHC.AnnVal (show src) + setContext (Set.singleton PrefixOp) $ markLocated ln + mark GHC.AnnDcolon + markLocated typ + + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.CExportSpec) where +#if __GLASGOW_HASKELL__ <= 710 + markAST l (GHC.CExportStatic _ cconv) = markAST l cconv +#else + markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv +#endif + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.CCallConv) where + markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" + markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" + markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" + markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" + markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.Safety) where + markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" + markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" + markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DerivDecl name) where + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.DerivDecl typ mov) = do +#else + markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do +#endif + mark GHC.AnnDeriving + mark GHC.AnnInstance + markMaybe mov + markLocated typ + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DefaultDecl name) where + + markAST _ (GHC.DefaultDecl typs) = do + mark GHC.AnnDefault + mark GHC.AnnOpenP -- '(' + markListIntercalate typs + mark GHC.AnnCloseP -- ')' + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.InstDecl name) where + + markAST l (GHC.ClsInstD cid) = markAST l cid + markAST l (GHC.DataFamInstD dfid) = markAST l dfid + markAST l (GHC.TyFamInstD tfid) = markAST l tfid + +-- --------------------------------------------------------------------- + +instance Annotate GHC.OverlapMode where + markAST _ (GHC.NoOverlap src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlappable src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlapping src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlaps src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Incoherent src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ClsInstDecl name) where + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do +#else + markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do +#endif + mark GHC.AnnInstance + markMaybe mov + markLocated poly + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + + applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ++ prepareListAnnotation tyfams + ++ prepareListAnnotation datafams + ) + + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.TyFamInstDecl name) where + + markAST _ (GHC.TyFamInstDecl eqn _) = do + mark GHC.AnnType + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional + markLocated eqn + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DataFamInstDecl name) where + +#if __GLASGOW_HASKELL__ <= 710 + markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) + defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do +#else + markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats) + defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do +#endif + case GHC.dd_ND defn of + GHC.NewType -> mark GHC.AnnNewtype + GHC.DataType -> mark GHC.AnnData + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance + + markLocated ctx + + markTyClass ln pats + +#if __GLASGOW_HASKELL__ > 710 + case (GHC.dd_kindSig defn) of + Just s -> do + mark GHC.AnnDcolon + markLocated s + Nothing -> return () +#endif + if isGadt $ GHC.dd_cons defn + then mark GHC.AnnWhere + else mark GHC.AnnEqual + markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsBind name) where +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _) = do +#else + markAST _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do +#endif + -- Note: from a layout perspective a FunBind should not exist, so the + -- current context is passed through unchanged to the matches. + -- TODO: perhaps bring the edp from the first match up to the annotation for + -- the FunBind. + let + tlFun = + ifInContext (Set.fromList [CtxOnly,CtxFirst]) + (markListWithContexts' listContexts matches) + (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) + ifInContext (Set.singleton TopLevel) + (setContextLevel (Set.singleton TopLevel) 2 tlFun) + tlFun + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do +#else + markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do +#endif + markLocated lhs + case grhs of + (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards + _ -> return () + markListIntercalateWithFunLevel markLocated 2 grhs + unless (GHC.isEmptyLocalBinds lb) $ mark GHC.AnnWhere + markOptional GHC.AnnWhere + + markLocalBindsWithLayout lb + markTrailingSemi + + markAST _ (GHC.VarBind _n rhse _) = + -- Note: this bind is introduced by the typechecker + markLocated rhse + + markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do + mark GHC.AnnPattern + case args of + GHC.InfixPatSyn la lb -> do + markLocated la + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated lb + GHC.PrefixPatSyn ns -> do + markLocated ln + mapM_ markLocated ns +#if __GLASGOW_HASKELL__ > 710 + GHC.RecordPatSyn fs -> do + markLocated ln + mark GHC.AnnOpenC -- '{' + markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs + mark GHC.AnnCloseC -- '}' +#endif + case dir of + GHC.ImplicitBidirectional -> mark GHC.AnnEqual + _ -> mark GHC.AnnLarrow + + markLocated def + case dir of + GHC.Unidirectional -> return () + GHC.ImplicitBidirectional -> return () + GHC.ExplicitBidirectional mg -> do + mark GHC.AnnWhere + mark GHC.AnnOpenC -- '{' + markMatchGroup l mg + mark GHC.AnnCloseC -- '}' + + markTrailingSemi + + -- Introduced after renaming. + markAST _ (GHC.AbsBinds _ _ _ _ _) = + traceM "warning: AbsBinds introduced after renaming" + +#if __GLASGOW_HASKELL__ > 710 + -- Introduced after renaming. + markAST _ GHC.AbsBindsSig{} = + traceM "warning: AbsBindsSig introduced after renaming" +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.IPBind name) where + markAST _ (GHC.IPBind en e) = do + case en of + Left n -> markLocated n + Right _i -> return () + mark GHC.AnnEqual + markLocated e + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsIPName where + markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => Annotate (GHC.Match name (GHC.Located body)) where + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do +#else + markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do +#endif + let +#if __GLASGOW_HASKELL__ <= 710 + get_infix Nothing = False + get_infix (Just (_,f)) = f +#else + get_infix GHC.NonFunBindMatch = False + get_infix (GHC.FunBindMatch _ f) = f +#endif +#if __GLASGOW_HASKELL__ <= 710 + isFunBind = isJust +#else + isFunBind GHC.NonFunBindMatch = False + isFunBind GHC.FunBindMatch{} = True +#endif + case (get_infix mln,pats) of + (True, a:b:xs) -> do + if null xs + then markOptional GHC.AnnOpenP + else mark GHC.AnnOpenP + markLocated a + case mln of +#if __GLASGOW_HASKELL__ <= 710 + Nothing -> return () + Just (n,_) -> setContext (Set.singleton InfixOp) $ markLocated n +#else + GHC.NonFunBindMatch -> return () + GHC.FunBindMatch n _ -> setContext (Set.singleton InfixOp) $ markLocated n +#endif + markLocated b + if null xs + then markOptional GHC.AnnCloseP + else mark GHC.AnnCloseP + mapM_ markLocated xs + _ -> do + annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam +#if __GLASGOW_HASKELL__ <= 710 + case mln of + -- Nothing -> mark GHC.AnnFunId + Nothing -> markListNoPrecedingSpace False pats + Just (n,_) -> do + setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n + mapM_ markLocated pats + -- markListNoPrecedingSpace pats +#else + case mln of + -- GHC.NonFunBindMatch -> mark GHC.AnnFunId + GHC.NonFunBindMatch -> markListNoPrecedingSpace False pats + GHC.FunBindMatch n _ -> do + -- setContext (Set.singleton NoPrecedingSpace) $ markLocated n + setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n + mapM_ markLocated pats +#endif + + -- TODO: The AnnEqual annotation actually belongs in the first GRHS value + case grhs of + (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards + _ -> return () + inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam + mapM_ markLocated grhs + + case lb of + GHC.EmptyLocalBinds -> return () + _ -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, + Annotate name, Annotate body) + => Annotate (GHC.GRHS name (GHC.Located body)) where + markAST _ (GHC.GRHS guards expr) = do + case guards of + [] -> return () + (_:_) -> do + mark GHC.AnnVbar + unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards + ifInContext (Set.fromList [CaseAlt]) + (return ()) + (mark GHC.AnnEqual) + + markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test + + inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam + setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.Sig name) where + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.TypeSig lns typ _) = do +#else + markAST _ (GHC.TypeSig lns st) = do +#endif + setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns + mark GHC.AnnDcolon +#if __GLASGOW_HASKELL__ <= 710 + markLocated typ +#else + markLHsSigWcType st +#endif + markTrailingSemi + tellContext (Set.singleton FollowingLine) + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do + mark GHC.AnnPattern + markLocated ln + mark GHC.AnnDcolon + + -- Note: The 'forall' bndrs '.' may occur multiple times + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + when (GHC.getLoc ctx1 /= GHC.noSrcSpan) $ do + setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx1 + markOffset GHC.AnnDarrow 0 + when (GHC.getLoc ctx2 /= GHC.noSrcSpan) $ do + setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx2 + markOffset GHC.AnnDarrow 1 + markLocated typ + markTrailingSemi +#else + markAST _ (GHC.PatSynSig ln (GHC.HsIB _ typ)) = do + mark GHC.AnnPattern + markLocated ln + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi +#endif + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.GenericSig ns typ) = do + mark GHC.AnnDefault +#else + markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ)) = do + when isDefault $ mark GHC.AnnDefault +#endif + -- markListIntercalate ns + setContext (Set.singleton PrefixOp) $ markListIntercalate ns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.IdSig _) = + traceM "warning: Introduced after renaming" + + -- FixSig (FixitySig name) +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do +#else + markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src _v fdir))) = do +#endif + let fixstr = case fdir of + GHC.InfixL -> "infixl" + GHC.InfixR -> "infixr" + GHC.InfixN -> "infix" + markWithString GHC.AnnInfix fixstr +#if __GLASGOW_HASKELL__ <= 710 + markWithString GHC.AnnVal (show v) +#else + markWithString GHC.AnnVal src +#endif + setContext (Set.singleton InfixOp) $ markListIntercalate lns + markTrailingSemi + + -- InlineSig (Located name) InlinePragma + -- '{-# INLINE' activation qvar '#-}' + markAST _ (GHC.InlineSig ln inl) = do + markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' + markActivation (GHC.inl_act inl) + setContext (Set.singleton PrefixOp) $ markLocated ln + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.SpecSig ln typs inl) = do +#else + markAST _ (GHC.SpecSig ln typs inl) = do +{- + | SpecSig (Located name) -- Specialise a function or datatype ... + [LHsSigType name] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE + +-} +#endif + markWithString GHC.AnnOpen (GHC.inl_src inl) + markActivation (GHC.inl_act inl) + markLocated ln + mark GHC.AnnDcolon -- '::' +#if __GLASGOW_HASKELL__ <= 710 + markListIntercalate typs +#else + markListIntercalateWithFunLevel markLHsSigType 2 typs +#endif + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + -- '{-# SPECIALISE' 'instance' inst_type '#-}' + markAST _ (GHC.SpecInstSig src typ) = do + markWithString GHC.AnnOpen src + mark GHC.AnnInstance +#if __GLASGOW_HASKELL__ <= 710 + markLocated typ +#else + markLHsSigType typ +#endif + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + + -- MinimalSig (BooleanFormula (Located name)) + markAST _l (GHC.MinimalSig src formula) = do + markWithString GHC.AnnOpen src +#if __GLASGOW_HASKELL__ <= 710 + annotationsToCommentsBF formula [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar] + markAST _l formula + finalizeBF _l +#else + markLocated formula +#endif + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- -------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ > 710 +markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsSigType name -> Annotated () +markLHsSigType (GHC.HsIB _ typ) = markLocated typ + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LHsSigType name] where + markAST _ ls = do + mark GHC.AnnDeriving + -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it + -- is a HsTyVar. So for round trip pretty printing we need to take this into + -- account. + case ls of + [] -> markManyOptional GHC.AnnOpenP + [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnOpenP + [_] -> markManyOptional GHC.AnnOpenP + _ -> markMany GHC.AnnOpenP + markListIntercalateWithFun markLHsSigType ls + case ls of + [] -> markManyOptional GHC.AnnCloseP + [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnCloseP + [_] -> markManyOptional GHC.AnnCloseP + _ -> markMany GHC.AnnCloseP +#endif + +-- -------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +-- In practice, due to the way the BooleanFormula is constructed in the parser, +-- we will get the following variants +-- a | b : Or [a,b] +-- a , b : And [a,b] +-- ( a ) : a +-- A bottom level Located RdrName is captured in a Var. This is the only part +-- with a location in it. +-- +-- So the best strategy might be to convert all the annotations into comments, +-- and then just print the names. DONE +instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where + -- markAST _ (GHC.Var x) = markLocated x + markAST _ (GHC.Var x) = setContext (Set.singleton PrefixOp) $ markLocated x + markAST l (GHC.Or ls) = mapM_ (markAST l) ls + markAST l (GHC.And ls) = mapM_ (markAST l) ls +#else +instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where + markAST _ (GHC.Var x) = do + setContext (Set.singleton PrefixOp) $ markLocated x + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + -- markAST l (GHC.Or ls) = mapM_ markLocated ls + markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls + markAST _ (GHC.And ls) = do + markListIntercalateWithFunLevel markLocated 2 ls + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + markAST _ (GHC.Parens x) = do + mark GHC.AnnOpenP -- '(' + markLocated x + mark GHC.AnnCloseP -- ')' + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsTyVarBndr name) where + markAST _l (GHC.UserTyVar n) = do +#if __GLASGOW_HASKELL__ <= 710 + markAST _l n +#else + markLocated n +#endif + + markAST _ (GHC.KindedTyVar n ty) = do + mark GHC.AnnOpenP -- '(' + markLocated n + mark GHC.AnnDcolon -- '::' + markLocated ty + mark GHC.AnnCloseP -- '(' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsType name) where + markAST loc ty = do + markType loc ty + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where + + -- markType :: GHC.SrcSpan -> ast -> Annotated () +#if __GLASGOW_HASKELL__ <= 710 + markType _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do + unless (null tvs) $ do + mark GHC.AnnForall + mapM_ markLocated tvs + mark GHC.AnnDot + + case mwc of + Nothing -> when (lc /= GHC.noSrcSpan) $ markLocated ctx + Just lwc -> do + let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs) + markLocated (GHC.L lc sorted) + + markLocated typ + -- mark GHC.AnnCloseP -- ")" +#else + markType _ (GHC.HsForAllTy tvs typ) = do + mark GHC.AnnForall + mapM_ markLocated tvs + mark GHC.AnnDot + markLocated typ + + {- + = HsForAllTy -- See Note [HsType binders] + { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' + , hst_body :: LHsType name -- body type + } + + -} +#endif + +#if __GLASGOW_HASKELL__ > 710 + markType _ (GHC.HsQualTy cxt typ) = do + markLocated cxt + markLocated typ + {- + | HsQualTy -- See Note [HsType binders] + { hst_ctxt :: LHsContext name -- Context C => blah + , hst_body :: LHsType name } + -} +#endif + + markType _l (GHC.HsTyVar name) = do +#if __GLASGOW_HASKELL__ <= 710 + if GHC.isDataOcc $ GHC.occName name + then do + mark GHC.AnnSimpleQuote + markLocatedFromKw GHC.AnnName (GHC.L _l name) + else unsetContext Intercalate $ markAST _l name +#else + -- TODO: Should the isExactName test move into the RdrName Annotate instanced? + if ((GHC.isDataOcc $ GHC.occName $ GHC.unLoc name) && ((not $ isExactName $ GHC.unLoc name))) + || (showGhc name == "()") + then do + mark GHC.AnnSimpleQuote + markLocatedFromKw GHC.AnnName name + else markLocated name +#endif + +#if __GLASGOW_HASKELL__ > 710 + markType _ (GHC.HsAppsTy ts) = do + mapM_ markLocated ts +#endif + + markType _ (GHC.HsAppTy t1 t2) = do + setContext (Set.singleton PrefixOp) $ markLocated t1 + markLocated t2 + + markType _ (GHC.HsFunTy t1 t2) = do + markLocated t1 + mark GHC.AnnRarrow + markLocated t2 + + markType _ (GHC.HsListTy t) = do + mark GHC.AnnOpenS -- '[' + markLocated t + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsPArrTy t) = do + markWithString GHC.AnnOpen "[:" -- '[:' + markLocated t + markWithString GHC.AnnClose ":]" -- ':]' + + markType _ (GHC.HsTupleTy tt ts) = do + case tt of + GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' + _ -> markWithString GHC.AnnOpen "(#" -- '(#' + markListIntercalateWithFunLevel markLocated 2 ts + case tt of + GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' + _ -> markWithString GHC.AnnClose "#)" -- '#)' + +#if __GLASGOW_HASKELL__ <= 710 + markType _ (GHC.HsOpTy t1 (_,lo) t2) = do +#else + markType _ (GHC.HsOpTy t1 lo t2) = do + -- HsOpTy (LHsType name) (Located name) (LHsType name) +#endif + markLocated t1 + if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) + then do + markOptional GHC.AnnSimpleQuote + else do + mark GHC.AnnSimpleQuote + unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo + markLocated t2 + + markType _ (GHC.HsParTy t) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnCloseP -- ')' + + markType _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do + markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) + mark GHC.AnnDcolon + markLocated t + + markType _ (GHC.HsEqTy t1 t2) = do + markLocated t1 + mark GHC.AnnTilde + markLocated t2 + + markType _ (GHC.HsKindSig t k) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnDcolon -- '::' + markLocated k + mark GHC.AnnCloseP -- ')' + + markType l (GHC.HsSpliceTy s _) = do +#if __GLASGOW_HASKELL__ <= 710 + mark GHC.AnnOpenPE + markAST l s + mark GHC.AnnCloseP +#else + markAST l s +#endif + + markType _ (GHC.HsDocTy t ds) = do + markLocated t + markLocated ds + +#if __GLASGOW_HASKELL__ <= 710 + markType _ (GHC.HsBangTy b t) = do + case b of + (GHC.HsSrcBang ms (Just True) _) -> do + markWithString GHC.AnnOpen (fromMaybe "{-# UNPACK" ms) + markWithString GHC.AnnClose "#-}" + (GHC.HsSrcBang ms (Just False) _) -> do + markWithString GHC.AnnOpen (fromMaybe "{-# NOUNPACK" ms) + markWithString GHC.AnnClose "#-}" + _ -> return () + mark GHC.AnnBang + markLocated t +#else + markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do + case mt of + Nothing -> return () + Just src -> do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + case str of + GHC.SrcLazy -> mark GHC.AnnTilde + GHC.SrcStrict -> mark GHC.AnnBang + GHC.NoSrcStrict -> return () + + markLocated t + {- + | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations + data HsSrcBang = + HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes + SrcUnpackedness + SrcStrictness + data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + + data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + + -} +#endif + + markType _ (GHC.HsRecTy cons) = do + mark GHC.AnnOpenC -- '{' + markListIntercalate cons + mark GHC.AnnCloseC -- '}' + + -- HsCoreTy Type + markType _ (GHC.HsCoreTy _t) = + traceM "warning: HsCoreTy Introduced after renaming" + + markType _ (GHC.HsExplicitListTy _ ts) = do + mark GHC.AnnSimpleQuote + mark GHC.AnnOpenS -- "[" + markListIntercalate ts + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsExplicitTupleTy _ ts) = do + mark GHC.AnnSimpleQuote + mark GHC.AnnOpenP + markListIntercalate ts + mark GHC.AnnCloseP + + -- HsTyLit HsTyLit + markType l (GHC.HsTyLit lit) = do + case lit of + (GHC.HsNumTy s _) -> + markExternal l GHC.AnnVal s + (GHC.HsStrTy s _) -> + markExternal l GHC.AnnVal s + + -- HsWrapTy HsTyAnnotated (HsType name) +#if __GLASGOW_HASKELL__ <= 710 + markType _ (GHC.HsWrapTy _ _) = + traceM "warning: HsWrapTyy Introduced after renaming" +#endif + +#if __GLASGOW_HASKELL__ <= 710 + markType l GHC.HsWildcardTy = do + markExternal l GHC.AnnVal "_" + markType l (GHC.HsNamedWildcardTy n) = do + markExternal l GHC.AnnVal (showGhc n) +#else + markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do + markExternal l GHC.AnnVal "_" +#endif + +#if __GLASGOW_HASKELL__ <= 710 + markType l (GHC.HsQuasiQuoteTy n) = do + markAST l n +#endif + +-- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 710 +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsAppType name) where + markAST _ (GHC.HsAppInfix n) = do + when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote + setContext (Set.singleton InfixOp) $ markLocated n + markAST _ (GHC.HsAppPrefix t) = do + markOptional GHC.AnnTilde + setContext (Set.singleton PrefixOp) $ markLocated t +#endif +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsSplice name) where +#if __GLASGOW_HASKELL__ > 710 + markAST l c = + case c of + GHC.HsQuasiQuote _ n _pos fs -> do + markExternal l GHC.AnnVal + ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") + + GHC.HsTypedSplice _n (GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do + markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) + GHC.HsTypedSplice _n b -> do + mark GHC.AnnOpenPTE + markLocated b + mark GHC.AnnCloseP + + GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnOpenPE) + -- TODO: We do not seem to have any way to distinguish between which of + -- the next two lines will emit output. If AnnThIdSplice is there, the + -- markLocated b ends up with a negative offset so emits nothing. + markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + markLocated b + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnCloseP) + GHC.HsUntypedSplice _n b -> do + -- TODO: when is this not optional? + markOptional GHC.AnnThIdSplice + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnOpenPE) + markLocated b + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnCloseP) +#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) + GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" +#endif +#else + markAST _ c = + case c of + GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do + -- TODO: We do not seem to have any way to distinguish between which of + -- the next two lines will emit output. If AnnThIdSplice is there, the + markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + markLocated b + GHC.HsSplice _n b@(GHC.L _ (GHC.HsBracket _)) -> do + markLocated b + GHC.HsSplice _n b -> do + markLocated b +#endif + +#if __GLASGOW_HASKELL__ <= 710 +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsQuasiQuote name) where + markAST l (GHC.HsQuasiQuote n _pos fs) = do + markExternal l GHC.AnnVal + ("[" ++ showGhc n ++ "|" ++ GHC.unpackFS fs ++ "|]") +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => + Annotate (GHC.ConDeclField name) where + markAST _ (GHC.ConDeclField ns ty mdoc) = do +{- +data ConDeclField name -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_names :: [LFieldOcc name], + -- ^ See Note [ConDeclField names] + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } + +-} + unsetContext Intercalate $ do + markListIntercalate ns + mark GHC.AnnDcolon + markLocated ty + markMaybe mdoc + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ > 710 +instance (GHC.DataId name) + => Annotate (GHC.FieldOcc name) where + markAST _ (GHC.FieldOcc rn _) = do + markLocated rn + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma +#endif + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsDocString where + markAST l (GHC.HsDocString s) = do + markExternal l GHC.AnnVal (GHC.unpackFS s) + +-- --------------------------------------------------------------------- +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.Pat name) where + markAST loc typ = do + markPat loc typ + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") + where + markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" + markPat l (GHC.VarPat n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is + -- resolved, particularly for pretty printing where annotations are added. + let pun_RDR = "pun-right-hand-side" + when (showGhc n /= pun_RDR) $ +#if __GLASGOW_HASKELL__ <= 710 + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l n +#else + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) +#endif + markPat _ (GHC.LazyPat p) = do + mark GHC.AnnTilde + markLocated p + + markPat _ (GHC.AsPat ln p) = do + markLocated ln + mark GHC.AnnAt + markLocated p + + markPat _ (GHC.ParPat p) = do + mark GHC.AnnOpenP + markLocated p + mark GHC.AnnCloseP + + markPat _ (GHC.BangPat p) = do + mark GHC.AnnBang + markLocated p + + markPat _ (GHC.ListPat ps _ _) = do + mark GHC.AnnOpenS + markListIntercalateWithFunLevel markLocated 2 ps + mark GHC.AnnCloseS + + markPat _ (GHC.TuplePat pats b _) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + markListIntercalateWithFunLevel markLocated 2 pats + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markPat _ (GHC.PArrPat ps _) = do + markWithString GHC.AnnOpen "[:" + mapM_ markLocated ps + markWithString GHC.AnnClose ":]" + + markPat _ (GHC.ConPatIn n dets) = do + markHsConPatDetails n dets + + markPat _ GHC.ConPatOut {} = + traceM "warning: ConPatOut Introduced after renaming" + + -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) + markPat _ (GHC.ViewPat e pat _) = do + markLocated e + mark GHC.AnnRarrow + markLocated pat + + -- SplicePat (HsSplice id) + markPat l (GHC.SplicePat s) = do +#if __GLASGOW_HASKELL__ <= 710 + mark GHC.AnnOpenPE + markAST l s + mark GHC.AnnCloseP +#else + markAST l s +#endif + + -- LitPat HsLit + markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) + + -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) +#if __GLASGOW_HASKELL__ <= 710 + markPat _ (GHC.NPat ol mn _) = do +#else + markPat _ (GHC.NPat ol mn _ _) = do +#endif + -- markOptional GHC.AnnMinus + when (isJust mn) $ mark GHC.AnnMinus + markLocated ol + + -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) +#if __GLASGOW_HASKELL__ <= 710 + markPat _ (GHC.NPlusKPat ln ol _ _) = do +#else + markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do +#endif + markLocated ln + markWithString GHC.AnnVal "+" -- "+" + markLocated ol + + +#if __GLASGOW_HASKELL__ <= 710 + markPat _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do + markLocated pat + mark GHC.AnnDcolon + markLocated ty +#else + markPat _ (GHC.SigPatIn pat ty) = do + markLocated pat + mark GHC.AnnDcolon + markLHsSigWcType ty +#endif + + markPat _ GHC.SigPatOut {} = + traceM "warning: SigPatOut introduced after renaming" + + -- CoPat HsAnnotated (Pat id) Type + markPat _ GHC.CoPat {} = + traceM "warning: CoPat introduced after renaming" + +#if __GLASGOW_HASKELL__ <= 710 + markPat l (GHC.QuasiQuotePat p) = markAST l p +#endif + +-- --------------------------------------------------------------------- +hsLit2String :: GHC.HsLit -> GHC.SourceText +hsLit2String lit = + case lit of + GHC.HsChar src _ -> src + -- It should be included here + -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 + GHC.HsCharPrim src _ -> src ++ "#" + GHC.HsString src _ -> src + GHC.HsStringPrim src _ -> src + GHC.HsInt src _ -> src + GHC.HsIntPrim src _ -> src + GHC.HsWordPrim src _ -> src + GHC.HsInt64Prim src _ -> src + GHC.HsWord64Prim src _ -> src + GHC.HsInteger src _ _ -> src + GHC.HsRat (GHC.FL src _) _ -> src + GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" + GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" + +markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.Located name -> GHC.HsConPatDetails name -> Annotated () +markHsConPatDetails ln dets = do + case dets of + GHC.PrefixCon args -> do + setContext (Set.singleton PrefixOp) $ markLocated ln + mapM_ markLocated args + GHC.RecCon (GHC.HsRecFields fs dd) -> do + markLocated ln + mark GHC.AnnOpenC -- '{' + case dd of + Nothing -> markListIntercalateWithFunLevel markLocated 2 fs + Just _ -> do + setContext (Set.singleton Intercalate) $ mapM_ markLocated fs + mark GHC.AnnDotdot + mark GHC.AnnCloseC -- '}' + GHC.InfixCon a1 a2 -> do + markLocated a1 + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated a2 + +markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () + +markHsConDeclDetails isDeprecated inGadt lns dets = do + case dets of + GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args + GHC.RecCon fs -> do + mark GHC.AnnOpenC + if inGadt + then do + if isDeprecated + then setContext (Set.fromList [InGadt]) $ markLocated fs + else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs + else do + if isDeprecated + then markLocated fs + else setContext (Set.fromList [InRecCon]) $ markLocated fs + GHC.InfixCon a1 a2 -> do + markLocated a1 + setContext (Set.singleton InfixOp) $ mapM_ markLocated lns + markLocated a2 + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LConDeclField name] where + markAST _ fs = do + markOptional GHC.AnnOpenC -- '{' + markListIntercalate fs + markOptional GHC.AnnDotdot + inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' + inContext (Set.singleton InGadt) $ do + mark GHC.AnnRarrow + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where + markAST l ol = + let str = case GHC.ol_val ol of + GHC.HsIntegral src _ -> src + GHC.HsFractional l2 -> GHC.fl_text l2 + GHC.HsIsString src _ -> src + in + markExternal l GHC.AnnVal str + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +instance (GHC.DataId name,Annotate arg) + => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where + markAST _ (GHC.HsWB thing _ _ _) = do + markLocated thing +#else +instance (GHC.DataId name,Annotate arg) + => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where + markAST _ (GHC.HsIB _ thing) = do + markLocated thing +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name + ,GHC.HasOccName name,Annotate body) + => Annotate (GHC.Stmt name (GHC.Located body)) where + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.LastStmt body _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body +#else + markAST _ (GHC.LastStmt body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body +#endif + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.BindStmt pat body _ _) = do +#else + markAST _ (GHC.BindStmt pat body _ _ _) = do +#endif + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat + mark GHC.AnnLarrow + unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body + + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + +#if __GLASGOW_HASKELL__ > 710 + markAST _ GHC.ApplicativeStmt{} + = error "ApplicativeStmt should not appear in ParsedSource" +#endif + + markAST _ (GHC.BodyStmt body _ _ _) = do + unsetContext Intercalate $ markLocated body + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.LetStmt lb) = do +#else + markAST _ (GHC.LetStmt (GHC.L _ lb)) = do +#endif + mark GHC.AnnLet + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + +#if __GLASGOW_HASKELL__ <= 710 + markAST l (GHC.ParStmt pbs _ _) = do +#else + markAST l (GHC.ParStmt pbs _ _ _) = do +#endif + -- Within a given parallel list comprehension,one of the sections to be done + -- in parallel. It is a normal list comprehension, so has a list of + -- ParStmtBlock, one for each part of the sub- list comprehension + + + ifInContext (Set.singleton Intercalate) + ( + + unsetContext Intercalate $ + markListWithContextsFunction + (LC (Set.singleton Intercalate) -- only + Set.empty -- first + Set.empty -- middle + (Set.singleton Intercalate) -- last + ) (markAST l) pbs + ) + ( + unsetContext Intercalate $ + markListWithContextsFunction + (LC Set.empty -- only + (Set.fromList [AddVbar]) -- first + (Set.fromList [AddVbar]) -- middle + Set.empty -- last + ) (markAST l) pbs + ) + markTrailingSemi + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do +#else + markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do +#endif + setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts + case form of + GHC.ThenForm -> do + mark GHC.AnnThen + unsetContext Intercalate $ markLocated using + case by of + Just b -> do + mark GHC.AnnBy + unsetContext Intercalate $ markLocated b + Nothing -> return () + GHC.GroupForm -> do + mark GHC.AnnThen + mark GHC.AnnGroup + case by of + Just b -> mark GHC.AnnBy >> markLocated b + Nothing -> return () + mark GHC.AnnUsing + markLocated using + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do +#else + markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do +#endif + mark GHC.AnnRec + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + mapM_ markLocated stmts + markOptional GHC.AnnCloseC + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + +-- --------------------------------------------------------------------- + +-- Note: We never have a located ParStmtBlock, so have nothing to hang the +-- annotation on. This means there is no pushing of context from the parent ParStmt. +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ParStmtBlock name name) where + markAST _ (GHC.ParStmtBlock stmts _ns _) = do + markListIntercalate stmts + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsLocalBinds name) where + markAST _ lb = markHsLocalBinds lb + +-- --------------------------------------------------------------------- + +markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.HsLocalBinds name -> Annotated () +markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = + applyListAnnotationsLayout + (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ) +markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) + = traceM "warning: ValBindsOut introduced after renaming" + +markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds) +markHsLocalBinds GHC.EmptyLocalBinds = return () + +-- --------------------------------------------------------------------- + +markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) + -> Annotated () +#if __GLASGOW_HASKELL__ <= 710 +markMatchGroup _ (GHC.MG matches _ _ _) +#else +markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) +#endif + = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsExpr name) where + markAST loc expr = do + markExpr loc expr + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + -- TODO: If the AnnComma is not needed, revert to markAST + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where +#if __GLASGOW_HASKELL__ <= 710 + markExpr l (GHC.HsVar n) = unsetContext Intercalate $ markAST l n +#else + markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do + ifInContext (Set.singleton PrefixOp) + (setContext (Set.singleton PrefixOp) $ markLocated n) + (ifInContext (Set.singleton InfixOp) + (setContext (Set.singleton InfixOp) $ markLocated n) + (markLocated n) + ) +#endif + +#if __GLASGOW_HASKELL__ <= 710 +#else + markExpr l (GHC.HsRecFld f) = markAST l f + + markExpr l (GHC.HsOverLabel fs) + = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) +#endif + + markExpr l (GHC.HsIPVar (GHC.HsIPName v)) = + markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) + markExpr l (GHC.HsOverLit ov) = markAST l ov + markExpr l (GHC.HsLit lit) = markAST l lit + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.HsLam (GHC.MG [match] _ _ _)) = do +#else + markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do +#endif + setContext (Set.singleton LambdaExpr) $ do + -- TODO: Change this, HsLam binds do not need obey layout rules. + -- And will only ever have a single match + markLocated match + markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" + + markExpr l (GHC.HsLamCase _ match) = do + mark GHC.AnnLam + mark GHC.AnnCase + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l match + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsApp e1 e2) = do + -- markLocated e1 + setContext (Set.singleton PrefixOp) $ markLocated e1 + -- markLocated e2 + setContext (Set.singleton PrefixOp) $ markLocated e2 + + markExpr _ (GHC.OpApp e1 e2 _ e3) = do + let + isInfix = case e2 of + -- TODO: generalise this. Is it a fixity thing? + GHC.L _ (GHC.HsVar _) -> True + _ -> False + + normal = + -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context + ifInContext (Set.singleton LeftMost) + (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) + (markLocated e1) + + if isInfix + then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + else normal + + unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 + + if isInfix + then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 + else markLocated e3 + + markExpr _ (GHC.NegApp e _) = do + mark GHC.AnnMinus + markLocated e + + markExpr _ (GHC.HsPar e) = do + mark GHC.AnnOpenP -- '(' + markLocated e + mark GHC.AnnCloseP -- ')' + + markExpr _ (GHC.SectionL e1 e2) = do + markLocated e1 + setContext (Set.singleton InfixOp) $ markLocated e2 + + markExpr _ (GHC.SectionR e1 e2) = do + setContext (Set.singleton InfixOp) $ markLocated e1 + markLocated e2 + + markExpr _ (GHC.ExplicitTuple args b) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + + setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args + + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + + markExpr l (GHC.HsCase e1 matches) = setRigidFlag $ do + mark GHC.AnnCase + setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + setContext (Set.singleton CaseAlt) $ markMatchGroup l matches + markOptional GHC.AnnCloseC + + -- We set the layout for HsIf even though it need not obey layout rules as + -- when moving these expressions it's useful that they maintain "internal + -- integrity", that is to say the subparts remain indented relative to each + -- other. + markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do + -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do + mark GHC.AnnIf + markLocated e1 + markOffsetOptional GHC.AnnSemi 0 + mark GHC.AnnThen + setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 + markOffsetOptional GHC.AnnSemi 1 + mark GHC.AnnElse + setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 + + markExpr _ (GHC.HsMultiIf _ rhs) = do + mark GHC.AnnIf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + -- mapM_ markLocated rhs + markListWithLayout rhs + markOptional GHC.AnnCloseC + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.HsLet binds e) = do +#else + markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do +#endif + setLayoutFlag (do -- Make sure the 'in' gets indented too + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e) + + -- ------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.HsDo cts es _) = do +#else + markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do +#endif + case cts of + GHC.DoExpr -> mark GHC.AnnDo + GHC.MDoExpr -> mark GHC.AnnMdo + _ -> return () + let (ostr,cstr) = + if isListComp cts + then case cts of + GHC.PArrComp -> ("[:",":]") + _ -> ("[", "]") + else ("{","}") + + when (isListComp cts) $ markWithString GHC.AnnOpen ostr + markOptional GHC.AnnOpenS + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + if isListComp cts + then do + markLocated (last es) + mark GHC.AnnVbar + setLayoutFlag (markListIntercalate (init es)) + else do + markListWithLayout es + markOptional GHC.AnnCloseS + markOptional GHC.AnnCloseC + when (isListComp cts) $ markWithString GHC.AnnClose cstr + + -- ------------------------------- + + markExpr _ (GHC.ExplicitList _ _ es) = do + mark GHC.AnnOpenS + setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es + mark GHC.AnnCloseS + + markExpr _ (GHC.ExplicitPArr _ es) = do + markWithString GHC.AnnOpen "[:" + mapM_ markLocated es + markWithString GHC.AnnClose ":]" + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.RecordCon n _ (GHC.HsRecFields fs dd)) = do +#else + markExpr _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs dd)) = do +#endif + markLocated n + mark GHC.AnnOpenC + case dd of + Nothing -> markListIntercalate fs + Just _ -> do + setContext (Set.singleton Intercalate) $ mapM_ markLocated fs + mark GHC.AnnDotdot + mark GHC.AnnCloseC + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do +#else + markExpr _ (GHC.RecordUpd e fs _cons _ _ _) = do +#endif + markLocated e + mark GHC.AnnOpenC + markListIntercalate fs + mark GHC.AnnCloseC + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.ExprWithTySig e typ _) = do +#else + markExpr _ (GHC.ExprWithTySig e typ) = do +#endif + setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e + mark GHC.AnnDcolon +#if __GLASGOW_HASKELL__ <= 710 + markLocated typ +#else + markLHsSigWcType typ +#endif + + markExpr _ (GHC.ExprWithTySigOut e typ) = do + markLocated e + mark GHC.AnnDcolon +#if __GLASGOW_HASKELL__ <= 710 + markLocated typ +#else + markLHsSigWcType typ +#endif + + markExpr _ (GHC.ArithSeq _ _ seqInfo) = do + mark GHC.AnnOpenS -- '[' + case seqInfo of + GHC.From e -> do + markLocated e + mark GHC.AnnDotdot + GHC.FromTo e1 e2 -> do + markLocated e1 + mark GHC.AnnDotdot + markLocated e2 + GHC.FromThen e1 e2 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + GHC.FromThenTo e1 e2 e3 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + markLocated e3 + mark GHC.AnnCloseS -- ']' + + markExpr _ (GHC.PArrSeq _ seqInfo) = do + markWithString GHC.AnnOpen "[:" -- '[:' + case seqInfo of + GHC.From e -> do + markLocated e + mark GHC.AnnDotdot + GHC.FromTo e1 e2 -> do + markLocated e1 + mark GHC.AnnDotdot + markLocated e2 + GHC.FromThen e1 e2 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + GHC.FromThenTo e1 e2 e3 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + markLocated e3 + markWithString GHC.AnnClose ":]" -- ':]' + + markExpr _ (GHC.HsSCC src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# SCC" +#if __GLASGOW_HASKELL__ <= 710 + markWithStringOptional GHC.AnnVal (GHC.unpackFS csFStr) + markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"") +#else + markWithStringOptional GHC.AnnVal (GHC.sl_st csFStr) + markWithString GHC.AnnValStr (GHC.sl_st csFStr) +#endif + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr _ (GHC.HsCoreAnn src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# CORE" +#if __GLASGOW_HASKELL__ <= 710 + markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"") +#else + markWithString GHC.AnnVal (GHC.sl_st csFStr) +#endif + markWithString GHC.AnnClose "#-}" + markLocated e + -- TODO: make monomorphic + markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do + mark GHC.AnnSimpleQuote + setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) + markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do + mark GHC.AnnThTyQuote + markLocatedFromKw GHC.AnnName (GHC.L l v) + markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do + markWithString GHC.AnnOpen "[d|" + markOptional GHC.AnnOpenC + setContext (Set.singleton NoAdvanceLine) + $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds + markOptional GHC.AnnCloseC + markWithString GHC.AnnClose "|]" + -- Introduced after the renamer + markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = + traceM "warning: DecBrG introduced after renamer" + markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do +#if __GLASGOW_HASKELL__ <= 710 + -- This exists like this as the lexer collapses [e| and [| into the + -- same construtor + workOutString _l GHC.AnnOpen + (\ss -> if spanLength ss == 2 + then "[|" + else "[e|") +#else + markWithString GHC.AnnOpen "[|" + markOptional GHC.AnnOpenE -- "[e|" +#endif + markLocated e + markWithString GHC.AnnClose "|]" + markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do +#if __GLASGOW_HASKELL__ <= 710 + -- This exists like this as the lexer collapses [e|| and [|| into the + -- same construtor + workOutString _l GHC.AnnOpen + (\ss -> if spanLength ss == 3 + then "[||" + else "[e||") +#else + markWithString GHC.AnnOpen "[||" + markWithStringOptional GHC.AnnOpenE "[e||" +#endif + markLocated e + markWithString GHC.AnnClose "||]" + markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do + markWithString GHC.AnnOpen "[t|" + markLocated e + markWithString GHC.AnnClose "|]" + markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do + markWithString GHC.AnnOpen "[p|" + markLocated e + markWithString GHC.AnnClose "|]" + + markExpr _ (GHC.HsRnBracketOut _ _) = + traceM "warning: HsRnBracketOut introduced after renamer" + markExpr _ (GHC.HsTcBracketOut _ _) = + traceM "warning: HsTcBracketOut introduced after renamer" + +#if __GLASGOW_HASKELL__ > 710 + markExpr l (GHC.HsSpliceE e) = do + markOptional GHC.AnnOpenPE + markAST l e + markOptional GHC.AnnCloseP +#else + markExpr _ (GHC.HsSpliceE isTyped e) = do + case e of + GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do + if isTyped + then do + mark GHC.AnnOpenPTE + markWithStringOptional GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) + else do + mark GHC.AnnOpenPE + markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + markLocated b + mark GHC.AnnCloseP + GHC.HsSplice _n b -> do + if isTyped + then do + markOptional GHC.AnnThIdSplice + mark GHC.AnnOpenPTE + else mark GHC.AnnOpenPE + markLocated b + mark GHC.AnnCloseP + + markExpr l (GHC.HsQuasiQuoteE e) = do + markAST l e +#endif + + markExpr _ (GHC.HsProc p c) = do + mark GHC.AnnProc + markLocated p + mark GHC.AnnRarrow + markLocated c + + markExpr _ (GHC.HsStatic e) = do + mark GHC.AnnStatic + markLocated e + + markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markExpr _ (GHC.HsArrForm e _ cs) = do + markWithString GHC.AnnOpen "(|" + markLocated e + mapM_ markLocated cs + markWithString GHC.AnnClose "|)" + + markExpr _ (GHC.HsTick _ _) = return () + markExpr _ (GHC.HsBinTick _ _ _) = return () + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do + -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + markWithString GHC.AnnOpen src + markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING + markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER + markOffset GHC.AnnColon 0 -- ':' + markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER + mark GHC.AnnMinus -- '-' + markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER + markOffset GHC.AnnColon 1 -- ':' + markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER + markWithString GHC.AnnClose "#-}" + markLocated e +#else + markExpr _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do + -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + markWithString GHC.AnnOpen src + markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str) -- STRING + markOffsetWithString GHC.AnnVal 1 v1 -- INTEGER + markOffset GHC.AnnColon 0 -- ':' + markOffsetWithString GHC.AnnVal 2 v2 -- INTEGER + mark GHC.AnnMinus -- '-' + markOffsetWithString GHC.AnnVal 3 v3 -- INTEGER + markOffset GHC.AnnColon 1 -- ':' + markOffsetWithString GHC.AnnVal 4 v4 -- INTEGER + markWithString GHC.AnnClose "#-}" + markLocated e +#endif + + markExpr l GHC.EWildPat = do + markExternal l GHC.AnnVal "_" + + markExpr _ (GHC.EAsPat ln e) = do + markLocated ln + mark GHC.AnnAt + markLocated e + + markExpr _ (GHC.EViewPat e1 e2) = do + markLocated e1 + mark GHC.AnnRarrow + markLocated e2 + + markExpr _ (GHC.ELazyPat e) = do + mark GHC.AnnTilde + markLocated e + +#if __GLASGOW_HASKELL__ <= 710 + markExpr _ (GHC.HsType ty) = markLocated ty +#else + markExpr _ (GHC.HsAppType e ty) = do + markLocated e + mark GHC.AnnAt + markLHsWcType ty + markExpr _ (GHC.HsAppTypeOut _ _) = + traceM "warning: HsAppTypeOut introduced after renaming" +#endif + + markExpr _ (GHC.HsWrap _ _) = + traceM "warning: HsWrap introduced after renaming" + markExpr _ (GHC.HsUnboundVar _) = + traceM "warning: HsUnboundVar introduced after renaming" + + +-- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 710 +markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsWcType name -> Annotated () +markLHsWcType (GHC.HsWC _ mwc ty) = do + case mwc of + Nothing -> markLocated ty + Just lwc -> do + -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty]) + -- markLocated (GHC.L lc sorted) + applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] + ++ prepareListAnnotation [ty] + ) +#endif +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsLit where + markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) + +-- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 710 +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsRecUpdField name) where + markAST _ (GHC.HsRecField lbl expr punFlag) = do + unsetContext Intercalate $ markLocated lbl + when (punFlag == False) $ do + mark GHC.AnnEqual + unsetContext Intercalate $ markLocated expr + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma +{- +type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id) + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', +-- +-- For details on above see note [Api annotations] in ApiAnnotation +data HsRecField' id arg = HsRecField { + hsRecFieldLbl :: Located id, + hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning + hsRecPun :: Bool -- ^ Note [Punning] + } deriving (Data, Typeable) + +-} + +instance (GHC.DataId name) + => Annotate (GHC.AmbiguousFieldOcc name) where + markAST _ (GHC.Unambiguous n _) = markLocated n + markAST _ (GHC.Ambiguous n _) = markLocated n +#endif +-- --------------------------------------------------------------------- + +-- |Used for declarations that need to be aligned together, e.g. in a +-- do or let .. in statement/expr +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.ExprLStmt name] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsTupArg name) where + markAST _ (GHC.Present (GHC.L l e)) = do + markLocated (GHC.L l e) + inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) + + markAST _ (GHC.Missing _) = do + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsCmdTop name) where + markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsCmd name) where + markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markAST _ (GHC.HsCmdArrForm e _mf cs) = do + -- The AnnOpen should be marked for a prefix usage, not for a postfix one, + -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm + + -- TODO: This test assumes no auto-generated SrcSpans + let isPrefixOp = case cs of + [] -> True + (GHC.L h _:_) -> GHC.getLoc e < h + when isPrefixOp $ markWithString GHC.AnnOpen "(|" + -- This may be an infix operation + applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) + (Set.singleton InfixOp) (Set.singleton InfixOp)) + (prepareListAnnotation [e] + ++ prepareListAnnotation cs) + when isPrefixOp $ markWithString GHC.AnnClose "|)" + + markAST _ (GHC.HsCmdApp e1 e2) = do + markLocated e1 + markLocated e2 + + markAST l (GHC.HsCmdLam match) = do + setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match + + markAST _ (GHC.HsCmdPar e) = do + mark GHC.AnnOpenP + markLocated e + mark GHC.AnnCloseP -- ')' + + markAST l (GHC.HsCmdCase e1 matches) = do + mark GHC.AnnCase + markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l matches + markOptional GHC.AnnCloseC + + markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do + mark GHC.AnnIf + markLocated e1 + markOffset GHC.AnnSemi 0 + mark GHC.AnnThen + markLocated e2 + markOffset GHC.AnnSemi 1 + mark GHC.AnnElse + markLocated e3 + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.HsCmdLet binds e) = do +#else + markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do +#endif + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.HsCmdDo es _) = do +#else + markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do +#endif + mark GHC.AnnDo + markOptional GHC.AnnOpenC + markListWithLayout es + markOptional GHC.AnnCloseC + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ GHC.HsCmdCast {} = + traceM "warning: HsCmdCast introduced after renaming" +#endif + +#if __GLASGOW_HASKELL__ > 710 + markAST _ (GHC.HsCmdWrap {}) = + traceM "warning: HsCmdWrap introduced after renaming" +{- + | HsCmdWrap HsWrapper + (HsCmd id) -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (HsCmdWrap wrap cmd) :: arg2 --> res +-} +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.TyClDecl name) where + + markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do +#else + markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) typ _) = do +#endif + -- There may be arbitrary parens around parts of the constructor that are + -- infix. + -- Turn these into comments so that they feed into the right place automatically + -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + mark GHC.AnnType + + markTyClass ln tyvars + mark GHC.AnnEqual + markLocated typ + markTrailingSemi + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) + (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _) = do +#else + markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _) + (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _ _) = do +#endif + if nd == GHC.DataType + then mark GHC.AnnData + else mark GHC.AnnNewtype + markMaybe mctyp + if null (GHC.unLoc ctx) + then markOptional GHC.AnnDarrow + else markLocated ctx + markTyClass ln tyVars + case mk of + Nothing -> return () + Just k -> do + mark GHC.AnnDcolon + markLocated k + if isGadt cons + then mark GHC.AnnWhere + else unless (null cons) $ mark GHC.AnnEqual + markOptional GHC.AnnWhere + markOptional GHC.AnnOpenC + setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) + $ markListWithContexts' listContexts cons + markOptional GHC.AnnCloseC + setContext (Set.fromList [Deriving,NoDarrow]) $ markMaybe mderivs + markTrailingSemi + + -- ----------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds + sigs meths ats atdefs docs _) = do +#else + markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds + sigs meths ats atdefs docs _) = do +#endif + mark GHC.AnnClass + unless (null $ GHC.unLoc ctx) $ markLocated ctx + + markTyClass ln tyVars + + unless (null fds) $ do + mark GHC.AnnVbar + markListIntercalateWithFunLevel markLocated 2 fds + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + -- AZ:TODO: we end up with both the tyVars and the following body of the + -- class defn in annSortKey for the class. This could cause problems when + -- changing things. + setContext (Set.singleton InClassDecl) $ + applyListAnnotationsLayout + (prepareListAnnotation sigs + ++ prepareListAnnotation (GHC.bagToList meths) + ++ prepareListAnnotation ats + ++ prepareListAnnotation atdefs + ++ prepareListAnnotation docs + ) + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi + +-- --------------------------------------------------------------------- + +markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) + => GHC.Located a -> [GHC.Located ast] -> Annotated () +markTyClass ln tyVars = do + markManyOptional GHC.AnnOpenP + + let + parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2 + lnFun = do + ifInContext (Set.singleton CtxMiddle) + (setContext (Set.singleton InfixOp) $ markLocated ln) + (markLocated ln) + listFun b = do + if parensNeeded + then ifInContext (Set.singleton (CtxPos 0)) + (markMany GHC.AnnOpenP) + (return ()) + else ifInContext (Set.singleton (CtxPos 0)) + (markManyOptional GHC.AnnOpenP) + (return ()) + + markLocated b + + if parensNeeded + then ifInContext (Set.singleton (CtxPos 2)) + (markMany GHC.AnnCloseP) + (return ()) + else ifInContext (Set.singleton (CtxPos 2)) + (markManyOptional GHC.AnnCloseP) + (return ()) + + prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls + + unsetContext CtxMiddle $ + applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp]) + (Set.singleton CtxMiddle) (Set.singleton CtxLast)) + ([(GHC.getLoc ln,lnFun)] + ++ prepareListFun tyVars) + markManyOptional GHC.AnnCloseP + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.FamilyDecl name) where +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do +#else + markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) rsig minj) = do +{- +data FamilyDecl name = FamilyDecl + { fdInfo :: FamilyInfo name -- type/data, closed/open + , fdLName :: Located name -- type constructor + , fdTyVars :: LHsQTyVars name -- type variables + , fdResultSig :: LFamilyResultSig name -- result signature + , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann + } +-} +#endif + case info of + GHC.DataFamily -> mark GHC.AnnData + _ -> mark GHC.AnnType + +#if __GLASGOW_HASKELL__ <= 710 + mark GHC.AnnFamily +#else + -- ifInContext (Set.singleton InClassDecl) (return ()) (mark GHC.AnnFamily) + mark GHC.AnnFamily +#endif + + markTyClass ln tyvars +#if __GLASGOW_HASKELL__ <= 710 + case mkind of + Nothing -> return () + Just k -> do + mark GHC.AnnDcolon + markLocated k +#else + case GHC.unLoc rsig of + GHC.NoSig -> return () + GHC.KindSig _ -> do + mark GHC.AnnDcolon + markLocated rsig + GHC.TyVarSig _ -> do + mark GHC.AnnEqual + markLocated rsig + case minj of + Nothing -> return () + Just inj -> do + mark GHC.AnnVbar + markLocated inj +#endif + case info of +#if __GLASGOW_HASKELL__ > 710 + GHC.ClosedTypeFamily (Just eqns) -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- { + markListWithLayout eqns + markOptional GHC.AnnCloseC -- } + GHC.ClosedTypeFamily Nothing -> do + mark GHC.AnnWhere + mark GHC.AnnOpenC -- { + mark GHC.AnnDotdot + mark GHC.AnnCloseC -- } +#else + GHC.ClosedTypeFamily eqns -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- { + markListWithLayout eqns + markOptional GHC.AnnCloseC -- } +#endif + _ -> return () + markTrailingSemi + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +#else +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.FamilyResultSig name) where + markAST _ (GHC.NoSig) = return () + markAST _ (GHC.KindSig k) = markLocated k + markAST _ (GHC.TyVarSig ltv) = markLocated ltv +#endif + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ > 710 +instance (GHC.DataId name,Annotate name) + => Annotate (GHC.InjectivityAnn name) where + markAST _ (GHC.InjectivityAnn ln lns) = do + markLocated ln + mark GHC.AnnRarrow + mapM_ markLocated lns +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.TyFamInstEqn name) where +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do +#else + markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do +#endif + markTyClass ln pats + -- let + -- fun = ifInContext (Set.singleton (CtxPos 0)) + -- (setContext (Set.singleton PrefixOp) $ markLocated ln) + -- (markLocated ln) + -- markOptional GHC.AnnOpenP + -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty) + -- ([(GHC.getLoc ln, fun)] + -- ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats) + -- markOptional GHC.AnnCloseP + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.TyFamDefltEqn name) where +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do +#else + markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do +#endif + mark GHC.AnnType + mark GHC.AnnInstance + applyListAnnotations (prepareListAnnotation [ln] + ++ prepareListAnnotation bndrs + ) + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +-- TODO: modify lexer etc, in the meantime to not set haddock flag +instance Annotate GHC.DocDecl where + markAST l v = + let str = + case v of + (GHC.DocCommentNext (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs + in + markExternal l GHC.AnnVal str >> markTrailingSemi + +-- --------------------------------------------------------------------- + +markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () +markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do + markLocated ctx + markMaybe typ +#if __GLASGOW_HASKELL__ <= 710 + markMaybe _mk +#endif + if isGadt cons + then markListWithLayout cons + else markListIntercalateWithFunLevel markLocated 2 cons + case mderivs of + Nothing -> return () + Just d -> setContext (Set.singleton Deriving) $ markLocated d + +-- --------------------------------------------------------------------- + +-- Note: GHC.HsContext name aliases to here too +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LHsType name] where + markAST l ts = do +#if __GLASGOW_HASKELL__ <= 710 + inContext (Set.singleton Deriving) $ mark GHC.AnnDeriving +#endif + -- Mote: A single item in parens in a deriving clause is parsed as a + -- HsSigType, which is always a HsForAllTy. Without parens it is always a + -- HsVar. So for round trip pretty printing we need to take this into + -- account. + let + parenIfNeeded' pa = + case ts of + [] -> if l == GHC.noSrcSpan + then markManyOptional pa + else markMany pa + [GHC.L _ GHC.HsForAllTy{}] -> markMany pa + [_] -> markManyOptional pa + _ -> markMany pa + + parenIfNeeded'' pa = + ifInContext (Set.singleton Parens) + (markMany pa) + (parenIfNeeded' pa) + + parenIfNeeded pa = + case ts of + [GHC.L _ GHC.HsParTy{}] -> markOptional pa + _ -> parenIfNeeded'' pa + + -- ------------- + + parenIfNeeded GHC.AnnOpenP + + unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts + + parenIfNeeded GHC.AnnCloseP + + ifInContext (Set.singleton NoDarrow) + (return ()) + (if null ts && (l == GHC.noSrcSpan) + then markOptional GHC.AnnDarrow + else mark GHC.AnnDarrow) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.ConDecl name) where +#if __GLASGOW_HASKELL__ <= 710 + markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx + dets res _ depc_syntax) = do + case res of + GHC.ResTyH98 -> do + + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + unless (null $ GHC.unLoc ctx) $ do + setContext (Set.fromList [NoDarrow]) $ markLocated ctx + mark GHC.AnnDarrow + case dets of + GHC.InfixCon _ _ -> return () + _ -> setContext (Set.singleton PrefixOp) $ markListIntercalate lns + + markHsConDeclDetails False False lns dets + + GHC.ResTyGADT ls ty -> do + -- only print names if not infix + case dets of + GHC.InfixCon _ _ -> return () + _ -> markListIntercalate lns + + if depc_syntax + then do + markHsConDeclDetails True False lns dets + mark GHC.AnnCloseC + mark GHC.AnnDcolon + markManyOptional GHC.AnnOpenP + + else do + mark GHC.AnnDcolon + markLocated (GHC.L ls (ResTyGADTHook bndrs)) + markManyOptional GHC.AnnOpenP + unless (null $ GHC.unLoc ctx) $ do + markLocated ctx + markHsConDeclDetails False True lns dets + + markLocated ty + + markManyOptional GHC.AnnCloseP + + + case res of + GHC.ResTyH98 -> inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar + _ -> return () + markTrailingSemi +#else + markAST _ (GHC.ConDeclH98 ln mqtvs mctx + dets _ ) = do +{- + | ConDeclH98 + { con_name :: Located name + + , con_qvars :: Maybe (LHsQTyVars name) + -- User-written forall (if any), and its implicit + -- kind variables + -- Non-Nothing needs -XExistentialQuantification + -- e.g. data T a = forall b. MkT b (b->a) + -- con_qvars = {b} + + , con_cxt :: Maybe (LHsContext name) + -- ^ User-written context (if any) + + , con_details :: HsConDeclDetails name + -- ^ Arguments + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + +-} + case mqtvs of + Nothing -> return () + Just (GHC.HsQTvs _ns bndrs _) -> do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + case mctx of + Just ctx -> do + setContext (Set.fromList [NoDarrow]) $ markLocated ctx + unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow + Nothing -> return () + + case dets of + GHC.InfixCon _ _ -> return () + _ -> setContext (Set.singleton PrefixOp) $ markLocated ln + + markHsConDeclDetails False False [ln] dets + + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar + markTrailingSemi + markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ) _) = do + setContext (Set.singleton PrefixOp) $ markListIntercalate lns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi +#endif + +-- ResTyGADT has a SrcSpan for the original sigtype, we need to create +-- a type for exactPC and annotatePC +data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name] + deriving (Typeable) +deriving instance (GHC.DataId name) => Data (ResTyGADTHook name) +deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name) + +instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where + ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs + + +#if __GLASGOW_HASKELL__ > 710 +-- WildCardAnon exists because the GHC anonymous wildcard type is defined as +-- = AnonWildCard (PostRn name Name) +-- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but +-- the instance doing this is parameterised on name, so we cannot put a value in +-- for the (PostRn name Name) field. This is used instead. +data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable) + +instance Annotate WildCardAnon where + markAST l WildCardAnon = do + markExternal l GHC.AnnVal "_" +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (ResTyGADTHook name) where + markAST _ (ResTyGADTHook bndrs) = do + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + +-- --------------------------------------------------------------------- + +instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.HsRecField name (GHC.LPat name)) where + markAST _ (GHC.HsRecField n e punFlag) = do + unsetContext Intercalate $ markLocated n + unless punFlag $ do + mark GHC.AnnEqual + unsetContext Intercalate $ markLocated e + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + + +instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) where + markAST _ (GHC.HsRecField n e punFlag) = do + unsetContext Intercalate $ markLocated n + unless punFlag $ do + mark GHC.AnnEqual + unsetContext Intercalate $ markLocated e + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name) + => Annotate (GHC.FunDep (GHC.Located name)) where + + markAST _ (ls,rs) = do + mapM_ markLocated ls + mark GHC.AnnRarrow + mapM_ markLocated rs + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do markWithString GHC.AnnOpen src case mh of diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs --- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE BangPatterns #-} -- | This module converts 'GHC.ApiAnns' into 'Anns' by traversing a -- structure created by the "Annotate" modue. -- @@ -60,6 +59,7 @@ , normalLayout ) where +-- import Control.Exception import Control.Monad.RWS import Control.Monad.Trans.Free @@ -73,19 +73,18 @@ import Language.Haskell.GHC.ExactPrint.Lookup #endif import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated - , annotate, Annotate(..)) +import Language.Haskell.GHC.ExactPrint.Annotate import qualified GHC -import qualified SrcLoc as GHC import qualified Data.Map as Map -#if __GLASGOW_HASKELL__ <= 710 import qualified Data.Set as Set -#endif -- import Debug.Trace +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- | Transform concrete annotations into relative annotations which are @@ -139,17 +138,21 @@ -- --------------------------------------------------------------------- +-- TODO: rename this, it is the R part of the RWS data DeltaOptions = DeltaOptions { -- | Current `SrcSpan, part of current AnnKey` - curSrcSpan :: !GHC.SrcSpan + curSrcSpan :: !GHC.SrcSpan -- | Constuctor of current AST element, part of current AnnKey - , annConName :: !AnnConName + , annConName :: !AnnConName -- | Whether to use rigid or normal layout rules - , drRigidity :: Rigidity + , drRigidity :: !Rigidity + -- | Current higher level context. e.g. whether a Match is part of a + -- LambdaExpr or a FunBind + , drContext :: !AstContextSet } data DeltaWriter = DeltaWriter @@ -186,6 +189,7 @@ { curSrcSpan = GHC.noSrcSpan , annConName = annGetConstr () , drRigidity = ridigity + , drContext = defaultACS } normalLayout :: DeltaOptions @@ -202,11 +206,7 @@ } where cs :: [Comment] - cs = flattenedComments ga - - flattenedComments :: GHC.ApiAnns -> [Comment] - flattenedComments (_,cm) = - map tokComment . GHC.sortLocated . concat $ Map.elems cm + cs = extractComments ga -- Writer helpers @@ -239,25 +239,38 @@ go :: AnnotationF (Delta a) -> Delta a go (MarkEOF next) = addEofAnnotation >> next go (MarkPrim kwid _ next) = addDeltaAnnotation kwid >> next + go (MarkPPOptional kwid _ next) = addDeltaAnnotation kwid >> next go (MarkOutside akwid kwid next) = addDeltaAnnotationsOutside akwid kwid >> next go (MarkInside akwid next) = addDeltaAnnotationsInside akwid >> next go (MarkMany akwid next) = addDeltaAnnotations akwid >> next + go (MarkManyOptional akwid next) = addDeltaAnnotations akwid >> next go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next + go (MarkOffsetPrimOptional akwid n _ next) = addDeltaAnnotationLs akwid n >> next go (WithAST lss prog next) = withAST lss (deltaInterpret prog) >> next go (CountAnns kwid next) = countAnnsDelta kwid >>= next go (SetLayoutFlag r action next) = do rigidity <- asks drRigidity - (if (r <= rigidity) then setLayoutFlag else id) (deltaInterpret action) + (if r <= rigidity then setLayoutFlag else id) (deltaInterpret action) next go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next - go (StoreOriginalSrcSpan key next) = storeOriginalSrcSpanDelta key >>= next - go (GetSrcSpanForKw kw next) = getSrcSpanForKw kw >>= next + go (StoreOriginalSrcSpan _ key next) = storeOriginalSrcSpanDelta key >>= next + go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next #if __GLASGOW_HASKELL__ <= 710 go (StoreString s ss next) = storeString s ss >> next #endif - go (AnnotationsToComments kws next) = annotationsToCommentsDelta kws >> next - go (WithSortKey kws next) = withSortKey kws >> next + go (AnnotationsToComments kws next) = annotationsToCommentsDelta kws >> next +#if __GLASGOW_HASKELL__ <= 710 + go (AnnotationsToCommentsBF _ kws next) = annotationsToCommentsDelta kws >> next + go (FinalizeBF _ next) = next +#endif + go (WithSortKey kws next) = withSortKey kws >> next + go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next + go (SetContextLevel ctxt lvl action next) = setContextDelta ctxt lvl (deltaInterpret action) >> next + go (UnsetContext _ctxt action next) = deltaInterpret action >> next + go (IfInContext ctxt ifAction elseAction next) = ifInContextDelta ctxt ifAction elseAction >> next + go (TellContext _ next) = next + withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Delta () withSortKey kws = let order = sortBy (comparing fst) kws @@ -266,6 +279,14 @@ mapM_ (deltaInterpret . snd) order +withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Delta () +withSortKeyContexts ctxts kws = do + tellSortKey (map fst order) + withSortKeyContextsHelper deltaInterpret ctxts order + where + order = sortBy (comparing fst) kws + + setLayoutFlag :: Delta () -> Delta () setLayoutFlag action = do oldLay <- gets apLayoutStart @@ -275,7 +296,20 @@ , apLayoutStart = oldLay }) action <* reset +-- --------------------------------------------------------------------- +setContextDelta :: Set.Set AstContext -> Int -> Delta () -> Delta () +setContextDelta ctxt lvl = + local (\s -> s { drContext = setAcsWithLevel ctxt lvl (drContext s) } ) + +ifInContextDelta :: Set.Set AstContext -> Annotated () -> Annotated () -> Delta () +ifInContextDelta ctxt ifAction elseAction = do + cur <- asks drContext + let inContext = inAcs ctxt cur + if inContext + then deltaInterpret ifAction + else deltaInterpret elseAction + -- --------------------------------------------------------------------- storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey @@ -311,8 +345,8 @@ -- --------------------------------------------------------------------- -- | This function exists to overcome a shortcoming in the GHC AST for 7.10.1 -getSrcSpanForKw :: GHC.AnnKeywordId -> Delta GHC.SrcSpan -getSrcSpanForKw kw = do +getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta GHC.SrcSpan +getSrcSpanForKw _ kw = do ga <- gets apAnns ss <- getSrcSpan case GHC.getAnnotation ga ss kw of @@ -328,6 +362,8 @@ withSrcSpanDelta (GHC.L l a) = local (\s -> s { curSrcSpan = l , annConName = annGetConstr a + , drContext = pushAcs (drContext s) + `debug` ("withSrcSpanDelta: (l,annConName,drContext)=" ++ showGhc (l,annGetConstr a, pushAcs (drContext s))) }) @@ -360,7 +396,7 @@ setPriorEndAST :: GHC.SrcSpan -> Delta () setPriorEndAST pe = do setLayoutStart (snd (ss2pos pe)) - modify (\s -> s { priorEndPosition = (ss2posEnd pe) } ) + modify (\s -> s { priorEndPosition = ss2posEnd pe } ) setLayoutStart :: Int -> Delta () setLayoutStart p = do @@ -382,6 +418,7 @@ let unicodeAnns = case unicodeEquivalent an of [] -> [] [kw] -> GHC.getAnnotation ga ss kw + (kw:_) -> GHC.getAnnotation ga ss kw -- Keep exhaustiveness checker happy return $ unicodeAnns ++ GHC.getAnnotation ga ss an #endif @@ -485,17 +522,17 @@ off (ss2delta priorEndAfterComments ss) -- Preparation complete, perform the action when (GHC.isGoodSrcSpan ss && priorEndAfterComments < ss2pos ss) (do - modify (\s -> s { priorEndPosition = (ss2pos ss) } )) + modify (\s -> s { priorEndPosition = ss2pos ss } )) (res, w) <- censor maskWriter (listen action) let kds = annKds w an = Ann - { annEntryDelta = edp - , annPriorComments = cs + { annEntryDelta = edp + , annPriorComments = cs , annFollowingComments = [] -- only used in Transform and Print - , annsDP = kds - , annSortKey = sortKeys w - , annCapturedSpan = getFirst $ dwCapturedSpan w } + , annsDP = kds + , annSortKey = sortKeys w + , annCapturedSpan = getFirst $ dwCapturedSpan w } addAnnotationsDelta an `debug` ("leaveAST:(annkey,an)=" ++ show (mkAnnKey lss,an)) @@ -553,7 +590,7 @@ if kw `Set.member` unicodeSyntax then let s = keywordToString gkw in - if (length s /= spanLength ss) + if length s /= spanLength ss then AnnUnicode kw else gkw else @@ -610,7 +647,7 @@ let p = ss2delta pe pa p' <- adjustDeltaForOffsetM p setPriorEnd (ss2posEnd pa) - return $ (c, p') + return (c, p') addDeltaComment :: Comment -> DeltaPos -> Delta () addDeltaComment d p = do @@ -635,7 +672,7 @@ addDeltaAnnotationLs ann off = do ss <- getSrcSpan ma <- peekAnnotationDelta ann - let ma' = filter (\s -> (GHC.isSubspanOf s ss)) ma + let ma' = filter (\s -> GHC.isSubspanOf s ss) ma case drop off ma' of [] -> return () `debug` ("addDeltaAnnotationLs:missed:(off,ann,ma)=" ++ showGhc (off,ss,ann)) @@ -695,6 +732,7 @@ addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1)) setPriorEndAST pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss) +-- --------------------------------------------------------------------- countAnnsDelta :: GHC.AnnKeywordId -> Delta Int countAnnsDelta ann = do 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 @@ -33,7 +33,13 @@ -- * Internal + , ghcWrapper + + , initDynFlags + , initDynFlagsPure , parseModuleApiAnnsWithCpp + , parseModuleApiAnnsWithCppInternal + , postParseTransform ) where import Language.Haskell.GHC.ExactPrint.Annotate @@ -65,6 +71,9 @@ import qualified Data.Map as Map +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- | Wrapper function which returns Annotations along with the parsed @@ -99,12 +108,10 @@ -- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr) -- @ withDynFlags :: (GHC.DynFlags -> a) -> IO a -withDynFlags action = - GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ - GHC.runGhc (Just libdir) $ do - dflags <- GHC.getSessionDynFlags - void $ GHC.setSessionDynFlags dflags - return (action dflags) +withDynFlags action = ghcWrapper $ do + dflags <- GHC.getSessionDynFlags + void $ GHC.setSessionDynFlags dflags + return (action dflags) -- --------------------------------------------------------------------- @@ -151,25 +158,23 @@ -- @ -- -- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GHC.RdrName') -parseModule :: FilePath - -> IO (Either (GHC.SrcSpan, String) - (Anns, GHC.ParsedSource)) +parseModule + :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModule = parseModuleWithCpp defaultCppOptions normalLayout + -- | This entry point will work out which language extensions are -- required but will _not_ perform CPP processing. -- In contrast to `parseModoule` the input source is read from the provided -- string; the `FilePath` parameter solely exists to provide a name -- in source location annotations. -parseModuleFromString :: FilePath - -> String - -> IO (Either (GHC.SrcSpan, String) - (Anns, GHC.ParsedSource)) -parseModuleFromString fp s = do - GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ - GHC.runGhc (Just libdir) $ do - dflags <- initDynFlagsPure fp s - return $ parseWith dflags fp GHC.parseModule s +parseModuleFromString + :: FilePath + -> String + -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) +parseModuleFromString fp s = ghcWrapper $ do + dflags <- initDynFlagsPure fp s + return $ parseWith dflags fp GHC.parseModule s parseModuleWithOptions :: DeltaOptions -> FilePath @@ -180,57 +185,89 @@ -- | Parse a module with specific instructions for the C pre-processor. -parseModuleWithCpp :: CppOptions - -> DeltaOptions - -> FilePath - -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) +parseModuleWithCpp + :: CppOptions + -> DeltaOptions + -> FilePath + -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModuleWithCpp cpp opts fp = do res <- parseModuleApiAnnsWithCpp cpp fp - return (either Left mkAnns res) - where - mkAnns (apianns, cs, _, m) = - Right (relativiseApiAnnsWithOptions opts cs m apianns, m) + return $ postParseTransform res opts +-- --------------------------------------------------------------------- + -- | Low level function which is used in the internal tests. -- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of -- this function. -parseModuleApiAnnsWithCpp :: CppOptions - -> FilePath - -> IO (Either (GHC.SrcSpan, String) - (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)) -parseModuleApiAnnsWithCpp cppOptions file = - GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ - GHC.runGhc (Just libdir) $ do - dflags <- initDynFlags file +parseModuleApiAnnsWithCpp + :: CppOptions + -> FilePath + -> IO + ( Either + (GHC.SrcSpan, String) + (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ) +parseModuleApiAnnsWithCpp cppOptions file = ghcWrapper $ do + dflags <- initDynFlags file + parseModuleApiAnnsWithCppInternal cppOptions dflags file + +-- | Internal function. Default runner of GHC.Ghc action in IO. +ghcWrapper :: GHC.Ghc a -> IO a +ghcWrapper = + GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut + . GHC.runGhc (Just libdir) + +-- | Internal function. Exposed if you want to muck with DynFlags +-- before parsing. +parseModuleApiAnnsWithCppInternal + :: GHC.GhcMonad m + => CppOptions + -> GHC.DynFlags + -> FilePath + -> m + ( Either + (GHC.SrcSpan, String) + (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ) +parseModuleApiAnnsWithCppInternal cppOptions dflags file = do #if __GLASGOW_HASKELL__ <= 710 - let useCpp = GHC.xopt GHC.Opt_Cpp dflags + let useCpp = GHC.xopt GHC.Opt_Cpp dflags #else - let useCpp = GHC.xopt LangExt.Cpp dflags + let useCpp = GHC.xopt LangExt.Cpp dflags #endif - (fileContents, injectedComments, dflags') <- - if useCpp - then do - (contents,dflags1) <- getPreprocessedSrcDirect cppOptions file - cppComments <- getCppTokensAsComments cppOptions file - return (contents,cppComments,dflags1) - else do - txt <- GHC.liftIO $ readFileGhc file - let (contents1,lp) = stripLinePragmas txt - return (contents1,lp,dflags) - return $ - case parseFile dflags' file fileContents of - GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m)) - GHC.POk (mkApiAnns -> apianns) pmod -> - Right $ (apianns, injectedComments, dflags', pmod) + (fileContents, injectedComments, dflags') <- + if useCpp + then do + (contents,dflags1) <- getPreprocessedSrcDirect cppOptions file + cppComments <- getCppTokensAsComments cppOptions file + return (contents,cppComments,dflags1) + else do + txt <- GHC.liftIO $ readFileGhc file + let (contents1,lp) = stripLinePragmas txt + return (contents1,lp,dflags) + return $ + case parseFile dflags' file fileContents of + GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m)) + GHC.POk (mkApiAnns -> apianns) pmod -> + Right $ (apianns, injectedComments, dflags', pmod) --- --------------------------------------------------------------------- +-- | Internal function. Exposed if you want to much with DynFlags +-- before parsing. Or after parsing. +postParseTransform + :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + -> DeltaOptions + -> Either a (Anns, GHC.ParsedSource) +postParseTransform parseRes opts = either Left mkAnns parseRes + where + mkAnns (apianns, cs, _, m) = + Right (relativiseApiAnnsWithOptions opts cs m apianns, m) +-- | Internal function. Initializes DynFlags value for parsing. initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags initDynFlags file = do - dflags0 <- GHC.getSessionDynFlags - src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file - (dflags1, _, _) - <- GHC.parseDynamicFilePragma dflags0 src_opts + dflags0 <- GHC.getSessionDynFlags + src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file + (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream void $ GHC.setSessionDynFlags dflags2 @@ -246,12 +283,8 @@ -- as long as `parseDynamicFilePragma` is impure there seems to be -- no reason to use it. dflags0 <- GHC.getSessionDynFlags - let pragmaInfo = GHC.getOptions - dflags0 - (GHC.stringToStringBuffer $ s) - fp - (dflags1, _, _) - <- GHC.parseDynamicFilePragma dflags0 pragmaInfo + let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer $ s) fp + (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream void $ GHC.setSessionDynFlags dflags2 @@ -262,4 +295,4 @@ mkApiAnns :: GHC.PState -> GHC.ApiAnns mkApiAnns pstate = ( Map.fromListWith (++) . GHC.annotations $ pstate - , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : (GHC.annotations_comments pstate))) + , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate)) 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 @@ -40,6 +40,12 @@ -- import Debug.Trace -- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +-- --------------------------------------------------------------------- + data CppOptions = CppOptions { cppDefine :: [String] -- ^ CPP #define macros , cppInclude :: [FilePath] -- ^ CPP Includes directory @@ -106,9 +112,14 @@ do let toks = GHC.addSourceToTokens startLoc source ts cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks - return $ map (tokComment . commentToAnnotation . fst) cppCommentToks + return $ filter goodComment + $ map (tokComment . commentToAnnotation . fst) cppCommentToks GHC.PFailed sspan err -> parseError flags2 sspan err +goodComment :: Comment -> Bool +goodComment (Comment "" _ _) = False +goodComment _ = True + -- --------------------------------------------------------------------- -- | Combine the three sets of tokens to produce a single set that @@ -137,7 +148,7 @@ -- GHC.Token does not have Ord, can't use a set directly origSpans = map (\(GHC.L l _,_) -> l) origSrcToks m1Spans = map (\(GHC.L l _,_) -> l) m1Toks - missingSpans = (Set.fromList origSpans) Set.\\ (Set.fromList m1Spans) + missingSpans = Set.fromList origSpans Set.\\ Set.fromList m1Spans missingToks = filter (\(GHC.L l _,_) -> Set.member l missingSpans) origSrcToks diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.GHC.ExactPrint.Pretty +-- +-- This module adds default annotations to an AST fragment that does not have +-- them, to be able to exactprint it in a way that preserves the orginal AST +-- when re-parsed. +-- +----------------------------------------------------------------------------- + +module Language.Haskell.GHC.ExactPrint.Pretty + ( + addAnnotationsForPretty + ) where + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Annotate + +import Control.Monad.RWS +import Control.Monad.Trans.Free +import Data.Generics +import Data.List +import Data.Ord (comparing) + + +#if __GLASGOW_HASKELL__ <= 710 +import qualified BooleanFormula as GHC +import qualified Outputable as GHC +#endif +import qualified GHC + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Debug.Trace + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} + +-- --------------------------------------------------------------------- + +-- |Add any missing annotations so that the full AST element will exactprint +-- properly when done. +addAnnotationsForPretty :: (Annotate a) => [Comment] -> GHC.Located a -> Anns -> Anns +addAnnotationsForPretty cs ast ans + = runPrettyWithComments opts cs (annotate ast) ans (0,0) + where + opts = prettyOptions NormalLayout + +-- --------------------------------------------------------------------- +-- +-- | Type used in the Pretty Monad. +type Pretty a = RWS PrettyOptions PrettyWriter PrettyState a + +runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns +runPrettyWithComments opts cs action ans priorEnd = + mkAnns . snd + . (\next -> execRWS next opts (defaultPrettyState cs priorEnd ans)) + . prettyInterpret $ action + where + mkAnns :: PrettyWriter -> Anns + mkAnns = f . dwAnns + f :: Monoid a => Endo a -> a + f = ($ mempty) . appEndo + +-- --------------------------------------------------------------------- + +-- TODO: rename this, it is the R part of the RWS +data PrettyOptions = PrettyOptions + { + -- | Current `SrcSpan, part of current AnnKey` + curSrcSpan :: !GHC.SrcSpan + + -- | Constuctor of current AST element, part of current AnnKey + , annConName :: !AnnConName + + -- | Whether to use rigid or normal layout rules + , drRigidity :: !Rigidity + + -- | Current higher level context. e.g. whether a Match is part of a + -- LambdaExpr or a FunBind + , prContext :: !AstContextSet + } deriving Show + +data PrettyWriter = PrettyWriter + { -- | Final list of annotations, and sort keys + dwAnns :: Endo (Map.Map AnnKey Annotation) + + -- | Used locally to pass Keywords, delta pairs relevant to a specific + -- subtree to the parent. + , annKds :: ![(KeywordId, DeltaPos)] + , sortKeys :: !(Maybe [GHC.SrcSpan]) + , dwCapturedSpan :: !(First AnnKey) + , prLayoutContext :: !(ACS' AstContext) + } + +data PrettyState = PrettyState + { -- | Position reached when processing the last element + priorEndPosition :: !Pos + + -- | Ordered list of comments still to be allocated + , apComments :: ![Comment] + + , apMarkLayout :: Bool + , apLayoutStart :: LayoutStartCol + + , apNoPrecedingSpace :: Bool + + } + +instance Monoid PrettyWriter where + mempty = PrettyWriter mempty mempty mempty mempty mempty + (PrettyWriter a b e g i) `mappend` (PrettyWriter c d f h j) + = PrettyWriter (a <> c) (b <> d) (e <> f) (g <> h) (i <> j) + +-- --------------------------------------------------------------------- + +prettyOptions :: Rigidity -> PrettyOptions +prettyOptions ridigity = + PrettyOptions + { curSrcSpan = GHC.noSrcSpan + , annConName = annGetConstr () + , drRigidity = ridigity + , prContext = defaultACS + } + +defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState +defaultPrettyState injectedComments priorEnd _ans = + PrettyState + { priorEndPosition = priorEnd + , apComments = cs ++ injectedComments + , apLayoutStart = 1 + , apMarkLayout = False + , apNoPrecedingSpace = False + } + where + cs :: [Comment] + cs = [] + +-- --------------------------------------------------------------------- +-- Free Monad Interpretation code + +prettyInterpret :: Annotated a -> Pretty a +prettyInterpret = iterTM go + where + go :: AnnotationF (Pretty a) -> Pretty a + go (MarkPrim kwid _ next) = addPrettyAnnotation (G kwid) >> next + go (MarkPPOptional _kwid _ next) = next + go (MarkEOF next) = addEofAnnotation >> next + go (MarkExternal _ss akwid _ next) = addPrettyAnnotation (G akwid) >> next + go (MarkOutside akwid kwid next) = addPrettyAnnotationsOutside akwid kwid >> next + -- go (MarkOutside akwid kwid next) = addPrettyAnnotation kwid >> next + go (MarkInside akwid next) = addPrettyAnnotationsInside akwid >> next + go (MarkMany akwid next) = addPrettyAnnotation (G akwid) >> next + go (MarkManyOptional _akwid next) = next + go (MarkOffsetPrim akwid n _ next) = addPrettyAnnotationLs akwid n >> next + go (MarkOffsetPrimOptional _akwid _n _ next) = next + go (WithAST lss prog next) = withAST lss (prettyInterpret prog) >> next + go (CountAnns kwid next) = countAnnsPretty kwid >>= next + go (WithSortKey kws next) = withSortKey kws >> next + go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next + go (SetLayoutFlag r action next) = do + rigidity <- asks drRigidity + (if r <= rigidity then setLayoutFlag else id) (prettyInterpret action) + next + go (StoreOriginalSrcSpan l key next) = storeOriginalSrcSpanPretty l key >>= next + go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next +#if __GLASGOW_HASKELL__ <= 710 + go (StoreString s ss next) = storeString s ss >> next +#endif + go (AnnotationsToComments kws next) = annotationsToCommentsPretty kws >> next +#if __GLASGOW_HASKELL__ <= 710 + go (AnnotationsToCommentsBF bf kws next) = annotationsToCommentsBFPretty bf kws >> next + go (FinalizeBF l next) = finalizeBFPretty l >> next +#endif + + go (SetContextLevel ctxt lvl action next) = setContextPretty ctxt lvl (prettyInterpret action) >> next + go (UnsetContext ctxt action next) = unsetContextPretty ctxt (prettyInterpret action) >> next + go (IfInContext ctxt ia ea next) = ifInContextPretty ctxt ia ea >> next + go (TellContext c next) = tellContext c >> next + +-- --------------------------------------------------------------------- + +addEofAnnotation :: Pretty () +addEofAnnotation = do + tellKd (G GHC.AnnEofPos, DP (1,0)) + +-- --------------------------------------------------------------------- + +addPrettyAnnotation :: KeywordId -> Pretty () +addPrettyAnnotation ann = do + noPrec <- gets apNoPrecedingSpace + ctx <- asks prContext + _ <- trace ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext + let + dp = case ann of + (G GHC.AnnAs) -> tellKd (ann,DP (0,1)) + (G GHC.AnnAt) -> tellKd (ann,DP (0,1)) + (G GHC.AnnBang) -> tellKd (ann,DP (0,1)) + (G GHC.AnnBy) -> tellKd (ann,DP (0,1)) + (G GHC.AnnCase ) -> tellKd (ann,DP (0,1)) + (G GHC.AnnClass) -> tellKd (ann,DP (0,1)) + (G GHC.AnnClose) -> tellKd (ann,DP (0,1)) + (G GHC.AnnCloseC) -> tellKd (ann,DP (0,0)) + (G GHC.AnnDcolon) -> tellKd (ann,DP (0,1)) + (G GHC.AnnDeriving) -> tellKd (ann,DP (0,1)) + (G GHC.AnnDo) -> tellKd (ann,DP (0,1)) + (G GHC.AnnElse) -> tellKd (ann,DP (1,2)) + (G GHC.AnnEqual) -> tellKd (ann,DP (0,1)) + (G GHC.AnnExport) -> tellKd (ann,DP (0,1)) + (G GHC.AnnFamily) -> tellKd (ann,DP (0,1)) + (G GHC.AnnForall) -> tellKd (ann,DP (0,1)) + (G GHC.AnnGroup) -> tellKd (ann,DP (0,1)) + (G GHC.AnnHiding) -> tellKd (ann,DP (0,1)) + (G GHC.AnnImport) -> tellKd (ann,DP (0,1)) + (G GHC.AnnIn) -> tellKd (ann,DP (1,0)) + (G GHC.AnnInstance) -> tellKd (ann,DP (0,1)) + (G GHC.AnnLam) -> tellKd (ann,DP (0,1)) + (G GHC.AnnMinus) -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator + (G GHC.AnnModule) -> tellKd (ann,DP (0,1)) + (G GHC.AnnOf) -> tellKd (ann,DP (0,1)) + (G GHC.AnnOpenC) -> tellKd (ann,DP (0,0)) + (G GHC.AnnOpenPE) -> tellKd (ann,DP (0,1)) + (G GHC.AnnQualified) -> tellKd (ann,DP (0,1)) + (G GHC.AnnRarrow) -> tellKd (ann,DP (0,1)) + (G GHC.AnnRole) -> tellKd (ann,DP (0,1)) + (G GHC.AnnSafe) -> tellKd (ann,DP (0,1)) + (G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1)) + (G GHC.AnnThTyQuote) -> tellKd (ann,DP (0,1)) + (G GHC.AnnThen) -> tellKd (ann,DP (1,2)) + (G GHC.AnnTilde) -> tellKd (ann,DP (0,1)) + (G GHC.AnnType) -> tellKd (ann,DP (0,1)) + (G GHC.AnnUsing) -> tellKd (ann,DP (0,1)) + (G GHC.AnnVal) -> tellKd (ann,DP (0,1)) + (G GHC.AnnValStr) -> tellKd (ann,DP (0,1)) + (G GHC.AnnVbar) -> tellKd (ann,DP (0,1)) + -- (G GHC.AnnWhere) -> tellKd (ann,DP (0,1)) + (G GHC.AnnWhere) -> tellKd (ann,DP (1,2)) + _ -> tellKd (ann,DP (0,0)) + fromNoPrecedingSpace (tellKd (ann,DP (0,0))) dp + +-- --------------------------------------------------------------------- + +addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty () +addPrettyAnnotationsOutside _akwid _kwid = return () + +-- --------------------------------------------------------------------- + +addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty () +addPrettyAnnotationsInside _ann = return () + +-- --------------------------------------------------------------------- + +addPrettyAnnotationLs :: GHC.AnnKeywordId -> Int -> Pretty () +addPrettyAnnotationLs ann _off = addPrettyAnnotation (G ann) + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +getUnallocatedComments :: Pretty [Comment] +getUnallocatedComments = gets apComments + +putUnallocatedComments :: [Comment] -> Pretty () +putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) +#endif + +-- --------------------------------------------------------------------- + +withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b +withSrcSpanPretty (GHC.L l a) action = do + -- peek into the current state of the output, to extract the layout context + -- flags passed up from subelements of the AST. + (_,w) <- listen (return () :: Pretty ()) + + _ <- trace ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ()) + + local (\s -> s { curSrcSpan = l + , annConName = annGetConstr a + -- , prContext = pushAcs (prContext s) + , prContext = (pushAcs (prContext s)) <> (prLayoutContext w) + }) + action + +-- --------------------------------------------------------------------- + +-- | Enter a new AST element. Maintain SrcSpan stack +withAST :: Data a + => GHC.Located a + -> Pretty b -> Pretty b +withAST lss@(GHC.L ss t) action = do + return () `debug` ("Pretty.withAST:enter 1:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) + -- Calculate offset required to get to the start of the SrcSPan + -- off <- gets apLayoutStart + withSrcSpanPretty lss $ do + return () `debug` ("Pretty.withAST:enter:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) + + let maskWriter s = s { annKds = [] + , sortKeys = Nothing + , dwCapturedSpan = mempty + -- , prLayoutContext = pushAcs (prLayoutContext s) + } + +#if __GLASGOW_HASKELL__ <= 710 + let spanStart = ss2pos ss + cs <- do + if GHC.isGoodSrcSpan ss + then + commentAllocation (priorComment spanStart) return + else + return [] +#else + let cs = [] +#endif + + -- uncs <- getUnallocatedComments + -- ctx <- trace ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext + ctx <- asks prContext + + noPrec <- gets apNoPrecedingSpace + edp <- trace ("Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" ++ showGhc (ss,showConstr (toConstr t),noPrec,ctx)) $ entryDpFor ctx t + -- edp <- entryDpFor ctx t + + let ctx1 = trace ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx + (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1 + then + -- trace ("Pretty.withAST:setNoPrecedingSpace") $ + censor maskWriter (listen (setNoPrecedingSpace action)) + else + -- trace ("Pretty.withAST:setNoPrecedingSpace") $ + censor maskWriter (listen action) + + let kds = annKds w + an = Ann + { annEntryDelta = edp + , annPriorComments = cs + , annFollowingComments = [] -- only used in Transform and Print + , annsDP = kds + , annSortKey = sortKeys w + , annCapturedSpan = getFirst $ dwCapturedSpan w + } + + addAnnotationsPretty an + `debug` ("Pretty.withAST:(annkey,an)=" ++ show (mkAnnKey lss,an)) + return res + +-- --------------------------------------------------------------------- + +entryDpFor :: Typeable a => AstContextSet -> a -> Pretty DeltaPos +entryDpFor ctx a = (def `extQ` grhs) a + where + lineDefault = if inAcs (Set.singleton AdvanceLine) ctx + then 1 else 0 + noAdvanceLine = inAcs (Set.singleton NoAdvanceLine) ctx && + inAcs (Set.singleton ListStart) ctx + + def :: a -> Pretty DeltaPos + def _ = + trace ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $ + if noAdvanceLine + then return (DP (0,1)) + else + if listStart + then return (DP (1,2)) + else if inList + then if topLevel then return (DP (2,0)) else return (DP (1,0)) + else if topLevel then return (DP (2,0)) else return (DP (lineDefault,0)) + + topLevel = inAcs (Set.singleton TopLevel) ctx + listStart = inAcs (Set.singleton ListStart) ctx + && not (inAcs (Set.singleton TopLevel) ctx) + inList = inAcs (Set.singleton ListItem) ctx + inLambda = inAcs (Set.singleton LambdaExpr) ctx + + + grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos + grhs _ = do + if inLambda + then return (DP (0,1)) + else return (DP (1,2)) + +-- --------------------------------------------------------------------- + +fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a +fromNoPrecedingSpace def lay = do + PrettyState{apNoPrecedingSpace} <- get + -- ctx <- asks prContext + if apNoPrecedingSpace + then do + modify (\s -> s { apNoPrecedingSpace = False + }) + trace ("fromNoPrecedingSpace:def") def + -- def + else + -- lay + trace ("fromNoPrecedingSpace:lay") lay + + +-- --------------------------------------------------------------------- + +-- |Add some annotation to the currently active SrcSpan +addAnnotationsPretty :: Annotation -> Pretty () +addAnnotationsPretty ann = do + l <- ask + return () `debug` ("addAnnotationsPretty:=" ++ showGhc (curSrcSpan l,prContext l)) + tellFinalAnn (getAnnKey l,ann) + +getAnnKey :: PrettyOptions -> AnnKey +getAnnKey PrettyOptions {curSrcSpan, annConName} + = AnnKey curSrcSpan annConName + +-- --------------------------------------------------------------------- + +countAnnsPretty :: GHC.AnnKeywordId -> Pretty Int +countAnnsPretty _ann = return 0 + +-- --------------------------------------------------------------------- + +withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Pretty () +withSortKey kws = + let order = sortBy (comparing fst) kws + in do + tellSortKey (map fst order) + mapM_ (prettyInterpret . snd) order + +withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Pretty () +withSortKeyContexts ctxts kws = + let order = sortBy (comparing fst) kws + in do + tellSortKey (map fst order) + withSortKeyContextsHelper prettyInterpret ctxts order + +-- --------------------------------------------------------------------- + +storeOriginalSrcSpanPretty :: GHC.SrcSpan -> AnnKey -> Pretty AnnKey +storeOriginalSrcSpanPretty _s key = do + tellCapturedSpan key + return key + +-- --------------------------------------------------------------------- + +getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Pretty GHC.SrcSpan +getSrcSpanForKw ss _kw = return ss + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +storeString :: String -> GHC.SrcSpan -> Pretty () +storeString s _ss = addPrettyAnnotation (AnnString s) +#endif + +-- --------------------------------------------------------------------- + +setLayoutFlag :: Pretty () -> Pretty () +setLayoutFlag action = do + oldLay <- gets apLayoutStart + modify (\s -> s { apMarkLayout = True } ) + let reset = modify (\s -> s { apMarkLayout = False + , apLayoutStart = oldLay }) + action <* reset + +-- --------------------------------------------------------------------- + +setNoPrecedingSpace :: Pretty a -> Pretty a +setNoPrecedingSpace action = do + oldVal <- gets apNoPrecedingSpace + modify (\s -> s { apNoPrecedingSpace = True } ) + let reset = modify (\s -> s { apNoPrecedingSpace = oldVal }) + action <* reset + +-- --------------------------------------------------------------------- + +setContextPretty :: Set.Set AstContext -> Int -> Pretty () -> Pretty () +setContextPretty ctxt lvl = + local (\s -> s { prContext = setAcsWithLevel ctxt lvl (prContext s) } ) + +unsetContextPretty :: AstContext -> Pretty () -> Pretty () +unsetContextPretty ctxt = + local (\s -> s { prContext = unsetAcs ctxt (prContext s) } ) + + +ifInContextPretty :: Set.Set AstContext -> Annotated () -> Annotated () -> Pretty () +ifInContextPretty ctxt ifAction elseAction = do + cur <- asks prContext + let inContext = inAcs ctxt cur + if inContext + then prettyInterpret ifAction + else prettyInterpret elseAction + +-- --------------------------------------------------------------------- + +annotationsToCommentsPretty :: [GHC.AnnKeywordId] -> Pretty () +annotationsToCommentsPretty _kws = return () + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty () +annotationsToCommentsBFPretty bf _kws = do + -- cs <- gets apComments + cs <- trace ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments + -- return$ trace ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) () + -- error ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) + let + kws = makeBooleanFormulaAnns bf + newComments = map (uncurry mkKWComment ) kws + putUnallocatedComments (cs ++ newComments) + + +finalizeBFPretty :: GHC.SrcSpan -> Pretty () +finalizeBFPretty _ss = do + commentAllocation (const True) (mapM_ (uncurry addPrettyComment)) + return () +#endif + +-- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ <= 710 +-- |Split the ordered list of comments into ones that occur prior to +-- the give SrcSpan and the rest +priorComment :: Pos -> Comment -> Bool +priorComment start c = (ss2pos . commentIdentifier $ c) < start + +-- TODO:AZ: We scan the entire comment list here. It may be better to impose an +-- invariant that the comments are sorted, and consume them as the pos +-- advances. It then becomes a process of using `takeWhile p` rather than a full +-- partition. +allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment]) +allocateComments = partition +#endif + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +commentAllocation :: (Comment -> Bool) + -> ([(Comment, DeltaPos)] -> Pretty a) + -> Pretty a +commentAllocation p k = do + cs <- getUnallocatedComments + let (allocated,cs') = allocateComments p cs + putUnallocatedComments cs' + k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated) + +makeDeltaComment :: Comment -> Pretty (Comment, DeltaPos) +makeDeltaComment c = do + return (c, DP (0,1)) + +addPrettyComment :: Comment -> DeltaPos -> Pretty () +addPrettyComment d p = do + tellKd (AnnComment d, p) +#endif + +-- --------------------------------------------------------------------- + +-- Writer helpers + +tellFinalAnn :: (AnnKey, Annotation) -> Pretty () +tellFinalAnn (k, v) = + tell (mempty { dwAnns = Endo (Map.insert k v) }) + +tellCapturedSpan :: AnnKey -> Pretty () +tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key }) + +tellKd :: (KeywordId, DeltaPos) -> Pretty () +tellKd kd = tell (mempty { annKds = [kd] }) + +tellSortKey :: [GHC.SrcSpan] -> Pretty () +tellSortKey xs = tell (mempty { sortKeys = Just xs } ) + +tellContext :: Set.Set AstContext -> Pretty () +tellContext lc = tell (mempty { prLayoutContext = setAcsWithLevel lc 2 mempty} ) diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs --- a/src/Language/Haskell/GHC/ExactPrint/Print.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs @@ -28,9 +28,9 @@ import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Annotate - (AnnotationF(..), Annotated, Annotate(..), annotate) import Language.Haskell.GHC.ExactPrint.Lookup +-- import Control.Exception import Control.Monad.Identity import Control.Monad.RWS import Control.Monad.Trans.Free @@ -39,9 +39,14 @@ import Data.Maybe (fromMaybe) import Data.Ord (comparing) +import qualified Data.Set as Set + import qualified GHC ------------------------------------------------------------------------------- +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- -- Printing of source elements -- | Print an AST with a map of potential modified `Anns`. The usual way to @@ -73,6 +78,7 @@ , epTokenPrint :: String -> m a , epWhitespacePrint :: String -> m a , epRigidity :: Rigidity + , epContext :: !AstContextSet } -- | Helper to create a 'PrintOptions' @@ -89,6 +95,7 @@ , epWhitespacePrint = wsPrint , epTokenPrint = tokenPrint , epRigidity = rigidity + , epContext = defaultACS } -- | Options which can be used to print as a normal String. @@ -147,38 +154,49 @@ printStringAtMaybeAnn (G GHC.AnnEofPos) (Just "") >> next go (MarkPrim kwid mstr next) = markPrim (G kwid) mstr >> next - -- let annString = fromMaybe (keywordToString kwid) mstr in - -- printStringAtMaybeAnn (G kwid) annString >> next + go (MarkPPOptional kwid mstr next) = + markPrim (G kwid) mstr >> next go (MarkOutside _ kwid next) = - -- markPrim kwid Nothing >> next - -- let annString = keywordToString kwid in printStringAtMaybeAnnAll kwid Nothing >> next - -- printStringAtMaybeAnnAll kwid ";" >> next go (MarkInside akwid next) = allAnns akwid >> next go (MarkMany akwid next) = allAnns akwid >> next + go (MarkManyOptional akwid next) = + allAnns akwid >> next go (MarkOffsetPrim kwid _ mstr next) = printStringAtMaybeAnn (G kwid) mstr >> next + go (MarkOffsetPrimOptional kwid _ mstr next) = + printStringAtMaybeAnn (G kwid) mstr >> next go (WithAST lss action next) = exactPC lss (printInterpret action) >> next go (CountAnns kwid next) = countAnnsEP (G kwid) >>= next go (SetLayoutFlag r action next) = do rigidity <- asks epRigidity - (if (r <= rigidity) then setLayout else id) (printInterpret action) + (if r <= rigidity then setLayout else id) (printInterpret action) next go (MarkExternal _ akwid s next) = printStringAtMaybeAnn (G akwid) (Just s) >> next - go (StoreOriginalSrcSpan _ next) = storeOriginalSrcSpanPrint >>= next - go (GetSrcSpanForKw _ next) = return GHC.noSrcSpan >>= next + go (StoreOriginalSrcSpan _ _ next) = storeOriginalSrcSpanPrint >>= next + go (GetSrcSpanForKw _ _ next) = return GHC.noSrcSpan >>= next #if __GLASGOW_HASKELL__ <= 710 go (StoreString _ _ next) = printStoredString >> next #endif - go (AnnotationsToComments _ next) = next - go (WithSortKey ks next) = withSortKey ks >> next + go (AnnotationsToComments _ next) = next +#if __GLASGOW_HASKELL__ <= 710 + go (AnnotationsToCommentsBF _ _ next) = next + go (FinalizeBF _ next) = next +#endif + go (WithSortKey ks next) = withSortKey ks >> next + go (WithSortKeyContexts ctx ks next) = withSortKeyContexts ctx ks >> next + go (SetContextLevel ctxt lvl action next) = setContextPrint ctxt lvl (printInterpret action) >> next + go (UnsetContext _ctxt action next) = printInterpret action >> next + go (IfInContext ctxt ifAction elseAction next) = ifInContextPrint ctxt ifAction elseAction >> next + go (TellContext _ next) = next + ------------------------------------------------------------------------- storeOriginalSrcSpanPrint :: (Monad m, Monoid w) => EP w m AnnKey @@ -206,17 +224,45 @@ withSortKey xs = do Ann{..} <- asks epAnn let ordered = case annSortKey of - Nothing -> map snd xs + Nothing -> xs Just keys -> orderByKey xs keys `debug` ("withSortKey:" ++ showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), map fst xs, keys) ) - mapM_ printInterpret ordered + mapM_ (printInterpret . snd) ordered -------------------------------------------------------------------------- +withSortKeyContexts :: (Monad m, Monoid w) => ListContexts -> [(GHC.SrcSpan, Annotated ())] -> EP w m () +withSortKeyContexts ctxts xs = do + Ann{..} <- asks epAnn + let ordered = case annSortKey of + Nothing -> xs + Just keys -> orderByKey xs keys + `debug` ("withSortKey:" ++ + showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), + map fst xs, + keys) + ) + -- mapM_ printInterpret ordered + withSortKeyContextsHelper printInterpret ctxts ordered +-- --------------------------------------------------------------------- + +setContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Int -> EP w m () -> EP w m () +setContextPrint ctxt lvl = + local (\s -> s { epContext = setAcsWithLevel ctxt lvl (epContext s) } ) + +ifInContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Annotated () -> Annotated () -> EP w m () +ifInContextPrint ctxt ifAction elseAction = do + cur <- asks epContext + let inContext = inAcs ctxt cur + if inContext + then printInterpret ifAction + else printInterpret elseAction + +-- --------------------------------------------------------------------- + allAnns :: (Monad m, Monoid w) => GHC.AnnKeywordId -> EP w m () allAnns kwid = printStringAtMaybeAnnAll (G kwid) Nothing @@ -256,12 +302,10 @@ printWhitespace (undelta p cl colOffset) getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation) -getAndRemoveAnnotation a = gets ((getAnnotationEP a) . epAnns) +getAndRemoveAnnotation a = gets (getAnnotationEP a . epAnns) markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () markPrim kwid mstr = - -- let annString = fromMaybe (keywordToString kwid) mstr - -- in printStringAtMaybeAnn kwid annString printStringAtMaybeAnn kwid mstr withContext :: (Monad m, Monoid w) @@ -277,7 +321,7 @@ -- withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) withOffset a = - local (\s -> s { epAnn = a }) + local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) }) -- --------------------------------------------------------------------- @@ -403,21 +447,14 @@ isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset)) --- AZ:TODO: harvest the commonality between this and printStringAtLsDelta printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () printQueuedComment Comment{commentContents} dp = do p <- getPos colOffset <- getLayoutOffset let (dr,dc) = undelta (0,0) dp colOffset -- do not lose comments against the left margin - when (isGoodDelta (DP (dr,max 0 dc))) - (do - printCommentAt (undelta p dp colOffset) commentContents - let commentDP@(DP (cr,_cc)) = dpFromString commentContents - if cr == 0 - then setPos (undelta p (dp `addDP` commentDP) colOffset) - else setPos (undelta p (dp `addDP` commentDP) 1) - ) + when (isGoodDelta (DP (dr,max 0 dc))) $ + printCommentAt (undelta p dp colOffset) commentContents -- --------------------------------------------------------------------- @@ -438,17 +475,23 @@ printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () printString layout str = do - EPState{epPos = (l,c), epMarkLayout} <- get + EPState{epPos = (_,c), epMarkLayout} <- get PrintOptions{epTokenPrint, epWhitespacePrint} <- ask - when (epMarkLayout && layout) ( - modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } )) - setPos (l, c + length str) - -- - -- tell (mempty {output = Endo $ showString str }) + when (epMarkLayout && layout) $ + modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ) + -- Advance position, taking care of any newlines in the string + let strDP@(DP (cr,_cc)) = dpFromString str + p <- getPos + colOffset <- getLayoutOffset + if cr == 0 + then setPos (undelta p strDP colOffset) + else setPos (undelta p strDP 1) + + -- if not layout && c == 0 - then lift (epWhitespacePrint str) >>= \s -> tell (EPWriter { output = s}) - else lift (epTokenPrint str) >>= \s -> tell (EPWriter { output = s}) + then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} + else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} newLine :: (Monad m, Monoid w) => EP w m () 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 @@ -1001,7 +1001,7 @@ return decls Just keys -> do let ds = map (\s -> (GHC.getLoc s,s)) decls - ordered = orderByKey ds keys + ordered = map snd $ orderByKey ds keys return ordered -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs --- a/src/Language/Haskell/GHC/ExactPrint/Types.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} module Language.Haskell.GHC.ExactPrint.Types ( -- * Core Types Anns @@ -26,6 +28,9 @@ -- * Other , Rigidity(..) + , AstContext(..),AstContextSet,defaultACS + , ACS'(..) + , ListContexts(..) -- * Internal Types , LayoutStartCol(..) @@ -36,11 +41,12 @@ import Data.Data (Data, Typeable, toConstr,cast) -import qualified DynFlags as GHC +import qualified DynFlags as GHC import qualified GHC import qualified Outputable as GHC import qualified Data.Map as Map +import qualified Data.Set as Set -- --------------------------------------------------------------------- @@ -50,6 +56,10 @@ data Comment = Comment { commentContents :: !String -- ^ The contents of the comment including separators + + -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is + -- the thing we use to decide where in the output stream the comment should + -- go. , commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents , commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. } @@ -135,7 +145,7 @@ -- a as the key, to store the standard annotation. -- These are used to maintain context in the AP and EP monads data AnnKey = AnnKey GHC.SrcSpan AnnConName - deriving (Eq, Ord) + deriving (Eq, Ord, Data) -- More compact Show instance instance Show AnnKey where @@ -153,7 +163,7 @@ -- Holds the name of a constructor data AnnConName = CN { unConName :: String } - deriving (Eq,Ord) + deriving (Eq, Ord, Data) -- More compact show instance instance Show AnnConName where @@ -174,7 +184,7 @@ #if __GLASGOW_HASKELL__ <= 710 | AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible. #endif - deriving (Eq,Ord) + deriving (Eq, Ord, Data) instance Show KeywordId where show (G gc) = "(G " ++ show gc ++ ")" @@ -190,7 +200,7 @@ instance GHC.Outputable KeywordId where ppr k = GHC.text (show k) -instance GHC.Outputable (AnnConName) where +instance GHC.Outputable AnnConName where ppr tr = GHC.text (show tr) instance GHC.Outputable Annotation where @@ -205,7 +215,117 @@ -- --------------------------------------------------------------------- -- -- Flag used to control whether we use rigid or normal layout rules. +-- NOTE: check is done via comparison of enumeration order, be careful with any changes data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) +{- + +Rigidity logic. The same type is used for two different things + +1. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies + NormalLayout - Layout should be captured unconditionally + + RigidLayout - Layout should be captured or not depending on a parameter kept + in the interpreter Read state + +2. As the controlling parameter for the optional (Rigid) layout + +The nett effect is the following, where flag is the hard-coded flag value in +Annotate, and param is the interpreter param set when the interpreter is run + + flag | param | result + -------------+--------------+-------------------- + NormalLayout | either | layout captured + RigidLayout | NormalLayout | layout NOT captured + RigidLayout | RigidLayout | layout captured + +The flag is only used on HsIf and HsCase + +So + + state | HsCase | HsIf + ----------------------------|-----------+------ + before rigidity flag (AZ) | no layout | layout + param NormalLayout | no layout | no layout + param RigidLayout | layout | layout + ----------------------------+-----------+------- + desired future HaRe | no layout | layout + desired future apply-refact | layout | layout +-} + +-- --------------------------------------------------------------------- + +data ACS' a = ACS + { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should + -- propagate down the AST. Removed when it hits zero + } deriving (Show) + +instance Monoid (ACS' AstContext) where + mempty = ACS mempty + -- ACS a `mappend` ACS b = ACS (a `mappend` b) + ACS a `mappend` ACS b = ACS (Map.unionWith max a b) + -- For Data.Map, mappend == union, which is a left-biased replace for key collisions + +type AstContextSet = ACS' AstContext +-- data AstContextSet = ACS +-- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should +-- -- propagate down the AST. Removed when it +-- -- hits zero +-- } deriving (Show) + +defaultACS :: AstContextSet +defaultACS = ACS Map.empty + +-- instance GHC.Outputable AstContextSet where +instance (Show a) => GHC.Outputable (ACS' a) where + ppr x = GHC.text $ show x + +data AstContext = LambdaExpr + | CaseAlt + | NoPrecedingSpace + | HasHiding + | AdvanceLine + | NoAdvanceLine + | Intercalate -- This item may have a list separator following + | InIE -- possible 'type' or 'pattern' + | PrefixOp + | PrefixOpDollar + | InfixOp -- RdrName may be used as an infix operator + | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently + | ListItem -- Identifies subsequent elements of a list in layout + | TopLevel -- top level declaration + | NoDarrow + | AddVbar + | Deriving + | Parens -- TODO: Not currently used? + | ExplicitNeverActive + | InGadt + | InRecCon + | InClassDecl + | InSpliceDecl + | LeftMost -- Is this the leftmost operator in a chain of OpApps? + + -- Next four used to identify current list context + | CtxOnly + | CtxFirst + | CtxMiddle + | CtxLast + | CtxPos Int -- 0 for first, increasing for subsequent + + -- Next are used in tellContext to push context up the tree + | FollowingLine + deriving (Eq, Ord, Show) + + +data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) } + deriving (Eq,Show) + +-- --------------------------------------------------------------------- + +-- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD +-- -- should not have blank lines after it +-- deriving (Eq, Ord, Show) + +-- --------------------------------------------------------------------- declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b declFun f (GHC.L l de) = 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 @@ -20,6 +20,7 @@ , mkKWComment , dpFromString , comment2dp + , extractComments -- * GHC Functions , srcSpanStartLine @@ -30,6 +31,8 @@ , isSymbolRdrName , tokComment , isListComp + , isGadt + , isExactName -- * Manipulating Annotations @@ -42,13 +45,28 @@ , orderByKey + -- * AST Context management + , setAcs, setAcsWithLevel + , unsetAcs + , inAcs + , pushAcs + , bumpAcs + +#if __GLASGOW_HASKELL__ <= 710 + -- * for boolean formulas in GHC 7.10.3 + -- ,LBooleanFormula, BooleanFormula(..) + , makeBooleanFormulaAnns +#endif + -- * For tests , debug , debugM , warn , showGhc , showAnnData + , occAttributes + , showSDoc_, showSDocDebug_ -- AZ's baggage , ghead,glast,gtail,gfromJust ) where @@ -56,35 +74,39 @@ import Control.Monad.State import qualified Data.ByteString as B -import Data.Data (Data, toConstr, showConstr, cast) -import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) -import Data.List (intercalate, sortBy, elemIndex) +import Data.Generics import Data.Ord (comparing) import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Lookup - -import qualified GHC import qualified Bag as GHC +#if __GLASGOW_HASKELL__ <= 710 +import qualified BooleanFormula as GHC +#endif import qualified DynFlags as GHC import qualified FastString as GHC +import qualified GHC import qualified Name as GHC import qualified NameSet as GHC import qualified Outputable as GHC import qualified RdrName as GHC +import qualified SrcLoc as GHC import qualified Var as GHC -import qualified OccName(occNameString) +import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief) import Control.Arrow ---import qualified Data.Generics as SYB - import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List import Debug.Trace +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- |Global switch to enable debug tracing in ghc-exactprint @@ -214,13 +236,13 @@ -- |Given a list of items and a list of keys, returns a list of items -- ordered by their position in the list of keys. -orderByKey :: [(GHC.SrcSpan,a)] -> [GHC.SrcSpan] -> [a] +orderByKey :: [(GHC.SrcSpan,a)] -> [GHC.SrcSpan] -> [(GHC.SrcSpan,a)] orderByKey keys order -- AZ:TODO: if performance becomes a problem, consider a Map of the order -- SrcSpan to an index, and do a lookup instead of elemIndex. -- Items not in the ordering are placed to the start - = map snd (sortBy (comparing (flip elemIndex order . fst)) keys) + = sortBy (comparing (flip elemIndex order . fst)) keys -- --------------------------------------------------------------------- @@ -241,6 +263,23 @@ -- --------------------------------------------------------------------- +isGadt :: [GHC.LConDecl name] -> Bool +isGadt [] = False +#if __GLASGOW_HASKELL__ <= 710 +isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True +#else +isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True +#endif +isGadt _ = False + +-- --------------------------------------------------------------------- + +-- Is a RdrName of type Exact? SYB query, so can be extended to other types too +isExactName :: (Data name) => name -> Bool +isExactName = False `mkQ` GHC.isExact + +-- --------------------------------------------------------------------- + ghcCommentText :: GHC.Located GHC.AnnotationComment -> String ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s)) = s @@ -264,6 +303,11 @@ comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos) comment2dp = first AnnComment +extractComments :: GHC.ApiAnns -> [Comment] +extractComments (_,cm) + -- cm has type :: Map SrcSpan [Located AnnotationComment] + = map tokComment . GHC.sortLocated . concat $ Map.elems cm + getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation getAnnotationEP la as = Map.lookup (mkAnnKey la) as @@ -314,15 +358,128 @@ case r of GHC.Unqual occ -> GHC.occNameString occ GHC.Qual modname occ -> GHC.moduleNameString modname ++ "." - ++ GHC.occNameString occ - GHC.Orig _ occ -> GHC.occNameString occ - GHC.Exact _ -> error $ "GHC.Exact introduced after renaming" ++ showGhc r + ++ GHC.occNameString occ + GHC.Orig _ occ -> GHC.occNameString occ + GHC.Exact n -> GHC.getOccString n name2String :: GHC.Name -> String name2String = showGhc -- --------------------------------------------------------------------- +-- | Put the provided context elements into the existing set with fresh level +-- counts +setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet +setAcs ctxt acs = setAcsWithLevel ctxt 3 acs + +-- | Put the provided context elements into the existing set with given level +-- counts +-- setAcsWithLevel :: Set.Set AstContext -> Int -> AstContextSet -> AstContextSet +-- setAcsWithLevel ctxt level (ACS a) = ACS a' +-- where +-- upd s (k,v) = Map.insert k v s +-- a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) +setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a +setAcsWithLevel ctxt level (ACS a) = ACS a' + where + upd s (k,v) = Map.insert k v s + a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) + +-- --------------------------------------------------------------------- +-- | Remove the provided context element from the existing set +-- unsetAcs :: AstContext -> AstContextSet -> AstContextSet +unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a +unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a + +-- --------------------------------------------------------------------- + +-- | Are any of the contexts currently active? +-- inAcs :: Set.Set AstContext -> AstContextSet -> Bool +inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool +inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a) + +-- | propagate the ACS down a level, dropping all values which hit zero +-- pushAcs :: AstContextSet -> AstContextSet +pushAcs :: ACS' a -> ACS' a +pushAcs (ACS a) = ACS $ Map.mapMaybe f a + where + f n + | n <= 1 = Nothing + | otherwise = Just (n - 1) + +-- |Sometimes we have to pass the context down unchanged. Bump each count up by +-- one so that it is unchanged after a @pushAcs@ call. +-- bumpAcs :: AstContextSet -> AstContextSet +bumpAcs :: ACS' a -> ACS' a +bumpAcs (ACS a) = ACS $ Map.mapMaybe f a + where + f n = Just (n + 1) + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 + + -- to be called in annotationsToCommentsBF by the pretty printer +makeBooleanFormulaAnns :: (GHC.Outputable a) + => GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)] +makeBooleanFormulaAnns bf = go 1 bf + where + go :: (GHC.Outputable a) + => Int -> GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)] + go _ (GHC.Var _) = [] + go l v@(GHC.And [a,b]) = + go 3 a ++ + go 3 b ++ + (if l > 3 then addParensIfNeeded v else []) ++ + [(GHC.AnnComma, ssAfter (getBoolSrcSpan a))] + go l v@(GHC.Or [a,b]) = + go 2 a ++ + go 2 b ++ + (if l > 2 then addParensIfNeeded v else []) ++ + [(GHC.AnnVbar, ssAfter (getBoolSrcSpan a) )] + go _ x = error $ "makeBooleanFormulaAnns: unexpected case:" ++ showGhc x + + +addParensIfNeeded :: GHC.Outputable a + => GHC.BooleanFormula (GHC.Located a) + -> [(GHC.AnnKeywordId, GHC.SrcSpan)] +addParensIfNeeded (GHC.Var _) = [] +addParensIfNeeded a = [(GHC.AnnOpenP,opp),(GHC.AnnCloseP,cpp)] + where + ss = getBoolSrcSpan a + opp = ssBefore ss + cpp = ssAfter ss + + +-- ssFor a b = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) + +-- | Generate a SrcSpan of single char length before the given one +ssBefore :: GHC.SrcSpan -> GHC.SrcSpan +ssBefore a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e) + where + GHC.RealSrcLoc as = GHC.srcSpanStart a + s = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 2) + e = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 1) + +-- | Generate a SrcSpan of single char length after the given one +ssAfter :: GHC.SrcSpan -> GHC.SrcSpan +ssAfter a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e) + where + GHC.RealSrcLoc ae = GHC.srcSpanEnd a + s = ae + e = GHC.advanceSrcLoc s ' ' + + +getBoolSrcSpan :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> GHC.SrcSpan +getBoolSrcSpan (GHC.Var (GHC.L ss _)) = ss +getBoolSrcSpan (GHC.And [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) +getBoolSrcSpan (GHC.Or [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) +getBoolSrcSpan x = error $ "getBoolSrcSpan: unexpected case:" ++ showGhc x + +#endif + +-- --------------------------------------------------------------------- + -- | Show a GHC AST with interleaved Annotation information. showAnnData :: Data a => Anns -> Int -> a -> String showAnnData anns n = @@ -348,7 +505,8 @@ ++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]" name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String - occName = ("{OccName: "++) . (++"}") . OccName.occNameString + -- occName = ("{OccName: "++) . (++"}") . OccName.occNameString + occName o = "{OccName: "++ OccName.occNameString o ++ " " ++ occAttributes o ++ "}" moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String -- srcSpan = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String @@ -392,16 +550,27 @@ ++ showAnnData anns (n+1) a ++ ")" -{- - showWrappedDeclAnns :: (Data a) => GHC.Located a -> Maybe String - showWrappedDeclAnns t = everything mappend (Nothing `mkQ` showDecl) t - where - showDecl :: GHC.LHsDecl GHC.RdrName -> Maybe String - showDecl d = Just $ declFun doShowAnn d - doShowAnn :: (Data a) => GHC.Located a -> String - doShowAnn a = show (getAnnotationEP a anns) +occAttributes :: OccName.OccName -> String +occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" + where + ns = (GHC.showSDocUnsafe $ OccName.pprNameSpaceBrief $ GHC.occNameSpace o) ++ ", " + vo = if GHC.isVarOcc o then "Var " else "" + tv = if GHC.isTvOcc o then "Tv " else "" + tc = if GHC.isTcOcc o then "Tc " else "" + d = if GHC.isDataOcc o then "Data " else "" + ds = if GHC.isDataSymOcc o then "DataSym " else "" + s = if GHC.isSymOcc o then "Sym " else "" + v = if GHC.isValOcc o then "Val " else "" + +{- +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. -} + -- --------------------------------------------------------------------- showSDoc_ :: GHC.SDoc -> String diff --git a/tests/PrepareHackage.hs b/tests/PrepareHackage.hs --- a/tests/PrepareHackage.hs +++ b/tests/PrepareHackage.hs @@ -19,7 +19,7 @@ main = do packages <- allCabalPackages -- packages <- allCabalPackagesTest - echo (T.pack $ "number of packages:" ++ (show $ length packages)) + myecho (T.pack $ "number of packages:" ++ (show $ length packages)) packageDirsFull <- drop 2 <$> getDirectoryContents hackageWorkDir let cond c = c == '.' || c == '-' || isDigit c let packageDirs = map (T.dropWhileEnd cond . T.pack) packageDirsFull @@ -35,19 +35,19 @@ preparePackage :: Set.Set Text -> Text -> IO () preparePackage alreadyUnpacked package = do - echo $ "preparePackage:" <> package + myecho $ "preparePackage:" <> package if Set.member package alreadyUnpacked - then echo $ "already unpacked:" <> package + then myecho $ "already unpacked:" <> package else preparePackage' package preparePackage' :: Text -> IO () preparePackage' package = do (ec,dir) <- shellStrict ("cabal get --destdir=" <> T.pack hackageWorkDir <> " " <> package) empty - -- echo (T.pack $ "cabal get:" ++ show dir) - echo (T.pack $ show ec) + -- myecho (T.pack $ "cabal get:" ++ show dir) + myecho (T.pack $ show ec) when (ec == ExitSuccess) $ do let bits = T.splitOn " " (head $ T.lines dir) - echo (T.pack $ "cabal get:dir=" ++ show (last bits)) + myecho (T.pack $ "cabal get:dir=" ++ show (last bits)) cleanPackage (last bits) return () @@ -57,28 +57,25 @@ cleanPackage :: Text -> IO () cleanPackage dir = do - echo ("cleaning:" <> dir) + myecho ("cleaning:" <> dir) fs <- findSrcFiles (T.unpack dir) let doOne :: FilePath -> IO () doOne fn = do - echo ("doOne:" <> T.pack fn) + myecho ("doOne:" <> T.pack fn) let tmpFn = fn <.> "clean" clean <- cleanupWhiteSpace fn writeFile tmpFn clean - -- writeFileUtf8 tmpFn clean - -- T.writeFile tmpFn (T.pack clean) -- convert to Text to deal with encoding issues of is8859 euro symbol removeFile fn renameFile tmpFn fn return () mapM_ doOne fs - echo ("cleaned up:" <> dir) + myecho ("cleaned up:" <> dir) -- --------------------------------------------------------------------- -- | The computation 'writeFile' @file str@ function writes the string @str@, -- to the file @file@. writeFileUtf8 :: FilePath -> String -> IO () --- writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> hPutStr hdl txt) writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt) -- --------------------------------------------------------------------- @@ -95,7 +92,7 @@ let cmd = "cabal list --simple-output | awk '{ print $1 }' | sort | uniq" (_ec,r) <- shellStrict cmd empty let packages = T.lines r - echo (T.pack $ show $ take 5 packages) + myecho (T.pack $ show $ take 5 packages) return packages -- --------------------------------------------------------------------- @@ -106,13 +103,7 @@ contents <- readFileGhc file let cleaned = map cleanupOneLine (lines $ contents) return (unlines cleaned) -{- -cleanupWhiteSpace :: FilePath -> IO T.Text -cleanupWhiteSpace file = do - contents <- readFileGhc file - let cleaned = map cleanupOneLine (T.lines $ T.pack contents) - return (T.unlines cleaned) --} + tabWidth :: Int tabWidth = 8 @@ -138,28 +129,6 @@ (c:cur') ->go (col + 1) (c:res) cur' str1 = go 0 [] str str' = reverse $ dropWhile isSpace str1 -{- -cleanupOneLine :: T.Text -> T.Text -cleanupOneLine str = str' - where - numSpacesForTab n = tabWidth - (n `mod` tabWidth) - -- loop over the line, keeping current pos. Where a tab is found, insert - -- spaces until the next tab stop. Discard any trailing whitespace. - go col res cur = - if T.null cur - then res - else - case T.head cur of - '\t' -> go (col + toAdd) (res <> T.replicate toAdd " ") (T.tail cur) - where - toAdd = numSpacesForTab col - '\xa0' -> go (col + 1) (T.snoc res ' ') (T.tail cur) - -- nonBreakingSpace -> go (col + 1) (T.snoc res ' ') (T.tail cur) - c -> go (col + 1) (T.snoc res c) (T.tail cur) - str1 = go 0 T.empty str - -- str2 = T.map (\c -> if c == nonBreakingSpace then ' ' else c) str1 - str' = T.dropWhileEnd isSpace str1 --} -- --------------------------------------------------------------------- @@ -187,6 +156,11 @@ testList :: String -> [Test] -> Test testList str ts = TestLabel str (TestList ts) + +-- --------------------------------------------------------------------- + +myecho :: T.Text -> IO () +myecho t = mapM_ echo (textToLines t) -- --------------------------------------------------------------------- diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -5,13 +5,7 @@ -- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests. module Main where -import Language.Haskell.GHC.ExactPrint.Utils ( showGhc ) - --- import qualified FastString as GHC --- import qualified GHC as GHC - --- import qualified Data.Generics as SYB --- import qualified GHC.SYB.Utils as SYB +-- import Language.Haskell.GHC.ExactPrint.Utils ( showGhc ) import Control.Monad import System.Directory @@ -24,6 +18,7 @@ import System.IO.Silently import Test.Common +import Test.NoAnnotations import Test.Transform import Test.HUnit @@ -73,8 +68,19 @@ -- --------------------------------------------------------------------- findTests :: IO Test -findTests = testList "Round-trip tests" <$> mapM findTestsDir testDirs +findTests = testList "Round-trip tests" <$> mapM (findTestsDir mkParserTest) testDirs +findPrettyTests :: IO Test +findPrettyTests = testList "Default Annotations round-trip tests" <$> mapM (findTestsDir mkPrettyRoundtrip) testDirs + +findTestsDir :: (FilePath -> FilePath -> Test) -> FilePath -> IO Test +findTestsDir mkTestFn dir = do + let fp = testPrefix dir + fs <- getDirectoryContents fp + let testFiles = sort $ filter (".hs" `isSuffixOf`) fs + -- return $ testList dir (map (mkTestFn dir) testFiles) + return $ testList dir (map (\fn -> TestLabel fn (mkTestFn dir fn)) testFiles) + listTests :: IO () listTests = do let @@ -86,18 +92,15 @@ files <- mapM ftd testDirs putStrLn $ "round trip tests:" ++ show (zip testDirs files) -findTestsDir :: FilePath -> IO Test -findTestsDir dir = do - let fp = testPrefix dir - fs <- getDirectoryContents fp - let testFiles = sort $ filter (".hs" `isSuffixOf`) fs - return $ testList dir (map (mkParserTest dir) testFiles) - mkTests :: IO Test mkTests = do -- listTests roundTripTests <- findTests - return $ TestList [internalTests,roundTripTests, transformTests, failingTests] + prettyRoundTripTests <- findPrettyTests + return $ TestList [ + internalTests, roundTripTests, transformTests, failingTests, noAnnotationTests + -- , prettyRoundTripTests + ] -- Tests that will fail until https://phabricator.haskell.org/D907 lands in a -- future GHC @@ -106,9 +109,12 @@ [ -- Tests requiring future GHC modifications mkTestModBad "InfixOperator.hs" + , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.2 #if __GLASGOW_HASKELL__ > 710 , mkTestModBad "overloadedlabelsrun04.hs" + , mkTestModBad "TensorTests.hs" -- Should be fixed in GHC 8.2 + , mkTestModBad "List2.hs" -- Should be fixed in GHC 8.2 #else , mkTestModBad "UnicodeSyntax.hs" , mkTestModBad "UnicodeRules.hs" @@ -121,19 +127,7 @@ mkParserTest :: FilePath -> FilePath -> Test -mkParserTest dir fp = - let basename = testPrefix dir fp - writeFailure = writeFile (basename <.> "out") - writeHsPP = writeFile (basename <.> "hspp") - writeIncons s = writeFile (basename <.> "incons") (showGhc s) - in - TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id - <$> roundTripTest basename - writeFailure (debugTxt r) - forM_ (inconsistent r) writeIncons - forM_ (cppStatus r) writeHsPP - assertBool fp (status r == Success)) - +mkParserTest dir fp = mkParsingTest roundTripTest dir fp -- --------------------------------------------------------------------- @@ -147,29 +141,32 @@ putStrLn "Fail" mapM_ (putStrLn . fst) fs) +tr :: IO (Counts,Int) +tr = hSilence [stderr] $ do + prettyRoundTripTests <- findPrettyTests + runTestText (putTextToHandle stdout True) prettyRoundTripTests + tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ -- mkParserTest "ghc710" "Unicode.hs" - -- , mkParserTest "ghc8" "BundleExport.hs" - -- , mkParserTest "ghc8" "ExportSyntax.hs" - -- , mkParserTest "ghc8" "T10689a.hs" - -- , mkParserTest "ghc8" "Test10313.hs" - -- , mkParserTest "ghc8" "Test11018.hs" - -- , mkParserTest "ghc8" "determ004.hs" - -- , mkParserTest "ghc8" "export-class.hs" - -- , mkParserTest "ghc8" "export-syntax.hs" - -- , mkParserTest "ghc8" "export-type.hs" - -- , mkParserTest "ghc8" "overloadedlabelsrun04.hs" - -- mkParserTest "ghc710" "RdrNames.hs" - mkParserTest "ghc710" "Process1.hs" - -- mkParserTest "ghc8" "T10620.hs" - -- mkParserTest "ghc8" "Vta1.hs" - -- , mkParserTest "ghc8" "Vta2.hs" - -- , mkParserTest "failing" "Deprecation.hs" - -- , mkParserTest "failing" "MultiLineWarningPragma.hs" - -- , mkParserTest "failing" "UnicodeRules.hs" - -- , mkParserTest "failing" "UnicodeSyntax.hs" + -- mkPrettyRoundtrip "ghc8" "StringSource.hs" + -- mkPrettyRoundtrip "ghc8" "records-prov-req.hs" + -- mkPrettyRoundtrip "ghc8" "records-poly-update.hs" + -- mkPrettyRoundtrip "ghc8" "poly-export-fail2.hs" + mkPrettyRoundtrip "ghc8" "pmc007.hs" + + -- mkParserTest "ghc8" "DatatypeContexts.hs" + -- mkParserTest "ghc8" "Families.hs" + + -- Needs GHC changes + -- , mkParserTest "failing" "CtorOp.hs" + -- mkParserTest "failing" "TensorTests.hs" + -- mkParserTest "failing" "List2.hs" + + + -- mkParserTest "ghc710" "DroppedComma.hs" + ] testsTT :: Test diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -12,6 +12,7 @@ , ParseFailure(..) , ReportType(..) , roundTripTest + , mkParsingTest , getModSummaryForFile , testList @@ -19,6 +20,7 @@ , Changer , genTest , noChange + , mkDebugOutput ) where @@ -31,21 +33,22 @@ import qualified ApiAnnotation as GHC import qualified DynFlags as GHC -import qualified FastString as GHC +-- import qualified FastString as GHC import qualified GHC as GHC hiding (parseModule) -import qualified Lexer as GHC +-- import qualified Lexer as GHC import qualified MonadUtils as GHC -import qualified Parser as GHC -import qualified SrcLoc as GHC -import qualified StringBuffer as GHC +-- import qualified Parser as GHC +-- import qualified SrcLoc as GHC +-- import qualified StringBuffer as GHC #if __GLASGOW_HASKELL__ <= 710 #else import qualified GHC.LanguageExtensions as LangExt #endif -import qualified Data.Map as Map +-- import qualified Data.Map as Map +import Control.Monad import Data.List hiding (find) import System.Directory @@ -69,9 +72,9 @@ data RoundtripReport = Report - { debugTxt :: String - , status :: ReportType - , cppStatus :: Maybe String -- Result of CPP if invoked + { debugTxt :: String + , status :: ReportType + , cppStatus :: Maybe String -- Result of CPP if invoked , inconsistent :: Maybe [(GHC.SrcSpan, (GHC.AnnKeywordId, [GHC.SrcSpan]))] } @@ -81,6 +84,7 @@ Success | RoundTripFailure deriving (Eq, Show) +{- runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a runParser parser flags filename str = GHC.unP parser parseState where @@ -97,10 +101,27 @@ removeSpaces :: String -> String removeSpaces = map (\case {'\160' -> ' '; s -> s}) +-} roundTripTest :: FilePath -> IO Report roundTripTest f = genTest noChange f f + +mkParsingTest :: (FilePath -> IO Report) -> FilePath -> FilePath -> Test +mkParsingTest tester dir fp = + let basename = testPrefix dir fp + writeFailure = writeFile (basename <.> "out") + writeHsPP = writeFile (basename <.> "hspp") + writeIncons s = writeFile (basename <.> "incons") (showGhc s) + in + TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id + <$> tester basename + writeFailure (debugTxt r) + forM_ (inconsistent r) writeIncons + forM_ (cppStatus r) writeHsPP + assertBool fp (status r == Success)) + + type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) noChange :: Changer @@ -163,7 +184,8 @@ let !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns (annsMod, pmod) <- f relAnns parsedOrig let !printed = exactPrint pmod annsMod - return (printed, relAnns, pmod) + -- return (printed, relAnns, pmod) + return (printed, annsMod, pmod) -- ---------------------------------------------------------------------` diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NoAnnotations.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +module Test.NoAnnotations where + +-- import Control.Monad.State +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import Data.Data (Data, toConstr, showConstr, cast) +import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) +import Data.List +-- import Data.Ord (comparing) +import qualified Data.ByteString as B + +import Language.Haskell.GHC.ExactPrint +-- import Language.Haskell.GHC.ExactPrint.Annotate +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint.Pretty +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import qualified ApiAnnotation as GHC +import qualified Bag as GHC +-- import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified GHC as GHC hiding (parseModule) +-- import qualified Lexer as GHC +import qualified MonadUtils as GHC +-- import qualified Name as GHC +import qualified NameSet as GHC +-- import qualified OccName as GHC +import qualified Outputable as GHC +-- import qualified Parser as GHC +-- import qualified RdrName as GHC +import qualified SrcLoc as GHC +-- import qualified StringBuffer as GHC +import qualified Var as GHC + +import qualified OccName(occNameString) + +-- import qualified Data.Generics as SYB +-- import qualified GHC.SYB.Utils as SYB + + +import System.Directory +import System.FilePath +-- import System.FilePath.Posix +-- import System.IO +import qualified Data.Map as Map +-- import Data.List +-- import Data.Maybe + +import Test.Common + +import Test.HUnit + +{-# ANN module "HLint: ignore Eta reduce" #-} + +-- --------------------------------------------------------------------- + +noAnnotationTests :: Test +noAnnotationTests = TestLabel "no annotation tests" $ TestList + [ + TestLabel "no annotations" + (TestList noAnnTests) + ] + +noAnnTests :: [Test] +noAnnTests = [ + + ] + +-- --------------------------------------------------------------------- + +mkPrettyRoundtrip :: FilePath -> FilePath -> Test +mkPrettyRoundtrip dir fp = mkParsingTest prettyRoundtripTest dir fp + +prettyRoundtripTest :: FilePath -> IO Report +prettyRoundtripTest origFile = do + res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile + case res of + Left (ss, m) -> return . Left $ ParseFailure ss m + Right (apianns, injectedComments, _dflags, parsed) -> do + res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments) + case res2 of + Left (ss, m) -> return . Left $ ParseFailure ss m + Right (_anns', parsed') -> do + let + originalStructure = astStructure parsed [] + roundtripStructure = astStructure parsed' [] + (status,debugTxt') = if roundtripStructure == originalStructure + then (Success, "ok") + else (RoundTripFailure,diffText originalStructure roundtripStructure) + cppStatus = Nothing + inconsistent = Nothing + !annsOrig = relativiseApiAnnsWithComments injectedComments parsed apianns + debugTxt = intercalate sep [ debugTxt' + , originalStructure + , roundtripStructure + , showAnnData annsOrig 0 parsed + ] + sep = "\n=====================================\n" + return $ Right Report {debugTxt,status,cppStatus,inconsistent} + +-- --------------------------------------------------------------------- + +runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource + -> [Comment] + -> IO (Either (GHC.SrcSpan, String)(Anns, GHC.ParsedSource)) +runPrettyRoundTrip origFile !anns !parsedOrig _cs = do + let !newAnns = addAnnotationsForPretty [] parsedOrig mempty + let comments = case Map.lookup GHC.noSrcSpan (snd anns) of + Nothing -> [] + Just cl -> map tokComment $ GHC.sortLocated cl + let pragmas = filter (\(Comment c _ _) -> isPrefixOf "{-#" c ) comments + let pragmaStr = intercalate "\n" $ map commentContents pragmas + + let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig newAnns + -- let !printed = pragmaStr ++ "\n" ++ (showSDoc_ $ GHC.ppr parsedOrig) + + parseString origFile printed newAnns parsedOrig + + +parseString :: FilePath -> String -> Anns -> GHC.ParsedSource + -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) +parseString origFile src newAnns origParsed = do + tmpDir <- getTemporaryDirectory + let workDir = tmpDir "ghc-exactprint" "noannotations" + -- putStrLn $ "workDir=" ++ workDir + createDirectoryIfMissing True workDir + let fileName = workDir takeFileName origFile + writeFile (workDir takeFileName origFile <.> ".anns") + (showAnnData newAnns 0 origParsed) + writeFile fileName src + parseModule fileName + +-- --------------------------------------------------------------------- + +diffText :: String -> String -> String +diffText f1 f2 = diff + where + d = getGroupedDiff (lines f1) (lines f2) + diff = ppDiff d + +-- --------------------------------------------------------------------- + +-- |Convert an AST with comments into a string representing the structure only +-- (i.e. ignoring locations), to be used for comparisons between the original +-- AST and the one after pretty-print roundtripping. +-- Based on @showAnnData@ +astStructure :: GHC.ParsedSource -> [Comment] -> String +astStructure parsed _cs = r + where + r = showAstData 0 parsed + + + +-- | Show a GHC AST with interleaved Annotation information. +showAstData :: Data a => Int -> a -> String +showAstData n = + generic -- `ext1Q` located + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan + `extQ` bytestring + `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon + `extQ` overLit + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `extQ` fixity + `ext2Q` located + where generic :: Data a => a -> String + generic t = indent n ++ "(" ++ showConstr (toConstr t) + ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")" + space "" = "" + space s = ' ':s + indent i = "\n" ++ replicate i ' ' + string = show :: String -> String + fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String + bytestring = show :: B.ByteString -> String + list l = indent n ++ "[" + ++ intercalate "," (map (showAstData (n+1)) l) ++ "]" + + name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String + occName = ("{OccName: "++) . (++"}") . OccName.occNameString + moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String + + srcSpan :: GHC.SrcSpan -> String + srcSpan _ss = "{ "++ "ss" ++"}" + + var = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String + dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String + + overLit :: GHC.HsOverLit GHC.RdrName -> String + overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr + + bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String + bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList + bagName :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String + bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList + bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String + bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList + + nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems + + fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String + + located :: (Data b,Data loc) => GHC.GenLocated loc b -> String + located (GHC.L ss a) = + indent n ++ "(" + ++ case cast ss of + Just (s :: GHC.SrcSpan) -> + srcSpan s + Nothing -> "nnnnnnnn" + ++ showAstData (n+1) a + ++ ")" + +-- --------------------------------------------------------------------- diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -702,7 +702,8 @@ imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)} p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]} addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] - addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))] + addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] return (GHC.L l p') @@ -719,16 +720,16 @@ let [GHC.L li imp1] = GHC.hsmodImports p Just (_,GHC.L lh ns) = GHC.ideclHiding imp1 - (GHC.L _ (GHC.IEVar ln)) = last ns n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) v1 = GHC.L l1 (GHC.IEVar n1) v2 = GHC.L l2 (GHC.IEVar n2) imp1' = imp1 { GHC.ideclHiding = Just (True,GHC.L lh (ns ++ [v1,v2]))} p' = p { GHC.hsmodImports = [GHC.L li imp1']} - addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))] + addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] - addTrailingCommaT ln + addTrailingCommaT (last ns) return (GHC.L l p') let (lp',(ans',_),_w) = runTransform ans doTransform diff --git a/tests/examples/failing/CtorOp.hs b/tests/examples/failing/CtorOp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/CtorOp.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeOperators #-} +module Decl.CtorOp where + +data a :+: b = a :+: b + +data (a :!: b) c = a c :!: b c + +data ((:-:) a) b = a :-: b + +data (:*:) a b = a :*: b + diff --git a/tests/examples/failing/CtorOp.hs.bad b/tests/examples/failing/CtorOp.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/CtorOp.hs.bad @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeOperators #-} +module Decl.CtorOp where + +data a :+: b = a :+: b + +data (a :!: b) c = a c :!: b c + +data ((:-:) a b = a :-: b + +data (:*:) a b = a :*: b + diff --git a/tests/examples/failing/List2.hs b/tests/examples/failing/List2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/List2.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Type.Family.List +-- Copyright : Copyright (C) 2015 Kyle Carter +-- License : BSD3 +-- +-- Maintainer : Kyle Carter +-- Stability : experimental +-- Portability : RankNTypes +-- +-- Convenient aliases and type families for working with +-- type-level lists. +---------------------------------------------------------------------------- + +module Type.Family.List where + +import Type.Family.Constraint +import Type.Family.Monoid +import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) +import Type.Class.Witness + +type Ø = '[] +type (:<) = '(:) +infixr 5 :< + diff --git a/tests/examples/failing/List2.hs.bad b/tests/examples/failing/List2.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/List2.hs.bad @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Type.Family.List +-- Copyright : Copyright (C) 2015 Kyle Carter +-- License : BSD3 +-- +-- Maintainer : Kyle Carter +-- Stability : experimental +-- Portability : RankNTypes +-- +-- Convenient aliases and type families for working with +-- type-level lists. +---------------------------------------------------------------------------- + +module Type.Family.List where + +import Type.Family.Constraint +import Type.Family.Monoid +import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) +import Type.Class.Witness + +type Ø = '[] +type (:<) = (:) +infixr 5 :< + diff --git a/tests/examples/failing/TensorTests.hs b/tests/examples/failing/TensorTests.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/TensorTests.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +module TensorTests (tensorTests) where + +import Apply.Cyc +import Tests +import Utils + +import TestTypes + +import Crypto.Lol +import Crypto.Lol.CRTrans +import Crypto.Lol.Cyclotomic.Tensor +import Crypto.Lol.Types + +import Control.Applicative + +import Data.Maybe + +import Data.Singletons +import Data.Promotion.Prelude.Eq +import Data.Singletons.TypeRepStar () + +import qualified Test.Framework as TF + +type TMRParams = ( '(,) <$> Tensors) <*> MRCombos +tmrParams :: Proxy TMRParams +tmrParams = Proxy + +--type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos +type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos +tremParams :: Proxy TrEmParams +tremParams = Proxy + +type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) + +data Liftable :: TyFun (Factored, *) Bool -> * +type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) + diff --git a/tests/examples/failing/TensorTests.hs.bad b/tests/examples/failing/TensorTests.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/TensorTests.hs.bad @@ -0,0 +1,41 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +module TensorTests (tensorTests) where + +import Apply.Cyc +import Tests +import Utils + +import TestTypes + +import Crypto.Lol +import Crypto.Lol.CRTrans +import Crypto.Lol.Cyclotomic.Tensor +import Crypto.Lol.Types + +import Control.Applicative + +import Data.Maybe + +import Data.Singletons +import Data.Promotion.Prelude.Eq +import Data.Singletons.TypeRepStar () + +import qualified Test.Framework as TF + +type TMRParams = ( (,) <$> Tensors) <*> MRCombos +tmrParams :: Proxy TMRParams +tmrParams = Proxy + +--type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos +type TrEmParams = ( (,) <$> Tensors) <*> MM'RCombos +tremParams :: Proxy TrEmParams +tremParams = Proxy + +type NormParams = ( (,) <$> '[RT]) <*> (Filter Liftable MRCombos) + +data Liftable :: TyFun (Factored, *) Bool -> * +type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) + diff --git a/tests/examples/ghc710/Case.hs b/tests/examples/ghc710/Case.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Case.hs @@ -0,0 +1,5 @@ + +foo x = case x of + True -> "a" + False -> "b" + diff --git a/tests/examples/ghc710/Field1.hs b/tests/examples/ghc710/Field1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Field1.hs @@ -0,0 +1,10 @@ +module Field1 where + +--Rename field name 'pointx' to 'pointx1' + +data Point = Pt {pointx, pointy :: Float} deriving Show + +absPoint :: Point -> Float +absPoint p = sqrt (pointx p * pointx p + + pointy p * pointy p) + diff --git a/tests/examples/ghc710/Mixed.hs b/tests/examples/ghc710/Mixed.hs --- a/tests/examples/ghc710/Mixed.hs +++ b/tests/examples/ghc710/Mixed.hs @@ -17,7 +17,8 @@ g x = x + if True then 1 else 2 h x = x + 1::Int -{-# SPECIALISe j :: Int -> Int #-} +{-# SPECIALISe j :: Int -> Int + , Integer -> Integer #-} j n = n + 1 test = let k x y = x+y in 1 `k` 2 `k` 3 @@ -28,6 +29,7 @@ instance (Num a, Num b) => Num (a,b) where + {-# Specialise instance Num (Int,Int) #-} negate (a,b) = (ng 'c' a, ng1 'c' b) where ng x y = negate y diff --git a/tests/examples/ghc710/ModuleOnly.hs b/tests/examples/ghc710/ModuleOnly.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ModuleOnly.hs @@ -0,0 +1,1 @@ +module ModuleOnly where diff --git a/tests/examples/ghc710/RdrNames.hs b/tests/examples/ghc710/RdrNames.hs --- a/tests/examples/ghc710/RdrNames.hs +++ b/tests/examples/ghc710/RdrNames.hs @@ -117,6 +117,7 @@ -- The type constructor is special in that GHC pretends that it -- has kind (? -> ? -> Fact) rather than (* -> * -> *) data (~) a b = Eq# ((~#) a b) +data ( ~ ) a b = Eq# (( ~# ) a b) data Coercible a b = MkCoercible ((~#) a b) @@ -141,4 +142,8 @@ -- --------------------------------------------------------------------- - +{- From #haskell-emacs +gracjan> did you know that this is legal haskell: + (+ 1) ` fmap {- -} ` [1,2,3] +-} +xxx = (+ 1) ` fmap {- -} ` [1,2,3] diff --git a/tests/examples/ghc710/Simple.hs b/tests/examples/ghc710/Simple.hs --- a/tests/examples/ghc710/Simple.hs +++ b/tests/examples/ghc710/Simple.hs @@ -1,4 +1,12 @@ -- blah +x :: (Int) x = 1 +(y) = 1 + +z :: t +z = do + let + a = 1 + return a diff --git a/tests/examples/ghc710/Splice.hs b/tests/examples/ghc710/Splice.hs --- a/tests/examples/ghc710/Splice.hs +++ b/tests/examples/ghc710/Splice.hs @@ -31,6 +31,8 @@ class MyClass2 a b instance MyClass2 Int Bool +makeLenses '' PostscriptFont + $(return []) main = do diff --git a/tests/examples/ghc8/AddParams2.hs b/tests/examples/ghc8/AddParams2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/AddParams2.hs @@ -0,0 +1,9 @@ +module AddParams2 where + +collapse rightInner rightOuter = right + where + right = (rightInner, rightOuter) + righ2 = (rightInner, (rightOuter baz bar)) + +baz = undefined +bar = undefined diff --git a/tests/examples/ghc8/Class.hs b/tests/examples/ghc8/Class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Class.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.Class where + +import Servant.Auth +import Data.Monoid +import Servant hiding (BasicAuth) + +import Servant.Auth.Server.Internal.Types +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.JWT + +-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all +-- elements of @ctx@ to be the in the Context and whose authentication check +-- returns an @AuthCheck v@. +class IsAuth a v where + type family AuthArgs a :: [*] + runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) + diff --git a/tests/examples/ghc8/Collapse1.hs b/tests/examples/ghc8/Collapse1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Collapse1.hs @@ -0,0 +1,16 @@ +module LiftToTop3evel.Collapse1 where + +collapse' _ _ [] = [] +collapse' left space (t:ts) = new : collapse' right space rest + where + (_, leftInner) = left + rightInner = leftInner + symbolSize t + right = (rightInner, (rightOuter rightInner rights)) + (rights, rest) = span space ts + new = (t, Bounds left right) + +rightOuter rightInner rights = rightInner + symbolSize rights + +data Bounds = Bounds (Int,Int) (Int,Int) +symbolSize t = 4 + diff --git a/tests/examples/ghc8/Compare.hs b/tests/examples/ghc8/Compare.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Compare.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Trustworthy, + TypeOperators, + PolyKinds, DataKinds, + TypeFamilies, + UndecidableInstances #-} + + +module Type.Compare where + +import Data.Ord +import GHC.TypeLits + +type family (a :: Ordering) $$ (b :: Ordering) :: Ordering where + LT $$ b = LT + GT $$ b = GT + EQ $$ b = b +infixl 0 $$ + +-- | Compare two types of any (possibly different) kinds. +-- Since `Compare` itself is a closed type family, add instances to `CompareUser` if you want to compare other types. +type family Compare (a :: k) (b :: k') :: Ordering where + + Compare '() '() = EQ diff --git a/tests/examples/ghc8/DatatypeContexts.hs b/tests/examples/ghc8/DatatypeContexts.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/DatatypeContexts.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DatatypeContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- I don't know how to silence the -XDatatypeContexts warnings otherwise... +{-# OPTIONS_GHC -w #-} + +{-| +Module: Derived.DatatypeContexts +Copyright: (C) 2014-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Defines data types with DatatypeContexts (which are gross, but still possible). +-} +module Derived.DatatypeContexts where + + +data family TyFamily x y z :: * + +data instance Ord a => TyFamily a b c = TyFamily a b c + deriving Show + diff --git a/tests/examples/ghc8/Decision.hs b/tests/examples/ghc8/Decision.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Decision.hs @@ -0,0 +1,726 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Airship.Internal.Decision + ( flow + , appendRequestPath + ) where + +import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123) +import Airship.Headers (addResponseHeader) +import Airship.Types ( Response(..) + , ResponseBody(..) + , Webmachine + , etagToByteString + , getResponseBody + , getResponseHeaders + , halt + , pathInfo + , putResponseBody + , request + , requestHeaders + , requestMethod + , requestTime ) + +import Airship.Resource(Resource(..), PostResponse(..)) +import Airship.Internal.Parsers (parseEtagList) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Monad (when) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, + get, modify) +import Control.Monad.Writer.Class (tell) + +import Blaze.ByteString.Builder (toByteString) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.ByteString (ByteString, intercalate) + +import Network.HTTP.Media +import qualified Network.HTTP.Types as HTTP + +------------------------------------------------------------------------------ +-- HTTP Headers +-- These are headers not defined for us already in +-- Network.HTTP.Types +------------------------------------------------------------------------------ +-- TODO this exist in http-types-0.9, see CHANGES.txt +hAcceptCharset :: HTTP.HeaderName +hAcceptCharset = "Accept-Charset" + +hAcceptEncoding :: HTTP.HeaderName +hAcceptEncoding = "Accept-Encoding" + +hIfMatch :: HTTP.HeaderName +hIfMatch = "If-Match" + +hIfUnmodifiedSince :: HTTP.HeaderName +hIfUnmodifiedSince = "If-Unmodified-Since" + +hIfNoneMatch :: HTTP.HeaderName +hIfNoneMatch = "If-None-Match" + +------------------------------------------------------------------------------ +-- FlowState: StateT used for recording information as we walk the decision +-- tree +------------------------------------------------------------------------------ + +data FlowState m = FlowState + { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } + +type FlowStateT m a = StateT (FlowState m) (Webmachine m) a + +type Flow m = Resource m -> FlowStateT m Response + +initFlowState :: FlowState m +initFlowState = FlowState Nothing + +flow :: Monad m => Resource m -> Webmachine m Response +flow r = evalStateT (b13 r) initFlowState + +trace :: Monad m => Text -> FlowStateT m () +trace t = lift $ tell [t] + +----------------------------------------------------------------------------- +-- Header value data newtypes +------------------------------------------------------------------------------ + +newtype IfMatch = IfMatch ByteString +newtype IfNoneMatch = IfNoneMatch ByteString + +------------------------------------------------------------------------------ +-- Decision Helpers +------------------------------------------------------------------------------ + +negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () +negotiateContentTypesAccepted Resource{..} = do + req <- lift request + accepted <- lift contentTypesAccepted + let reqHeaders = requestHeaders req + result = do + cType <- lookup HTTP.hContentType reqHeaders + mapContentMedia accepted cType + case result of + (Just process) -> lift process + Nothing -> lift $ halt HTTP.status415 + +appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString +appendRequestPath ts = do + currentPath <- pathInfo <$> request + return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts)) + +requestHeaderDate :: Monad m => HTTP.HeaderName -> + Webmachine m (Maybe UTCTime) +requestHeaderDate headerName = do + req <- request + let reqHeaders = requestHeaders req + dateHeader = lookup headerName reqHeaders + parsedDate = dateHeader >>= parseRfc1123Date + return parsedDate + +writeCacheTags :: Monad m => Resource m -> FlowStateT m () +writeCacheTags Resource{..} = lift $ do + etag <- generateETag + case etag of + Nothing -> return () + Just t -> addResponseHeader ("ETag", etagToByteString t) + modified <- lastModified + case modified of + Nothing -> return () + Just d -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d) + +------------------------------------------------------------------------------ +-- Type definitions for all decision nodes +------------------------------------------------------------------------------ + +b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow m +c04, c03 :: Monad m => Flow m +d05, d04 :: Monad m => Flow m +e06, e05 :: Monad m => Flow m +f07, f06 :: Monad m => Flow m +g11, g09 :: Monad m => IfMatch -> Flow m +g08, g07 :: Monad m => Flow m +h12, h11, h10, h07 :: Monad m => Flow m +i13 :: Monad m => IfNoneMatch -> Flow m +i12, i07, i04 :: Monad m => Flow m +j18 :: Monad m => Flow m +k13 :: Monad m => IfNoneMatch -> Flow m +k07, k05 :: Monad m => Flow m +l17, l15, l14, l13, l07, l05 :: Monad m => Flow m +m20, m16, m07, m05 :: Monad m => Flow m +n16, n11, n05 :: Monad m => Flow m +o20, o18, o16, o14 :: Monad m => Flow m +p11, p03 :: Monad m => Flow m + +------------------------------------------------------------------------------ +-- B column +------------------------------------------------------------------------------ + +b13 r@Resource{..} = do + trace "b13" + available <- lift serviceAvailable + if available + then b12 r + else lift $ halt HTTP.status503 + +b12 r@Resource{..} = do + trace "b12" + -- known method + req <- lift request + let knownMethods = [ HTTP.methodGet + , HTTP.methodPost + , HTTP.methodHead + , HTTP.methodPut + , HTTP.methodDelete + , HTTP.methodTrace + , HTTP.methodConnect + , HTTP.methodOptions + , HTTP.methodPatch + ] + if requestMethod req `elem` knownMethods + then b11 r + else lift $ halt HTTP.status501 + +b11 r@Resource{..} = do + trace "b11" + long <- lift uriTooLong + if long + then lift $ halt HTTP.status414 + else b10 r + +b10 r@Resource{..} = do + trace "b10" + req <- lift request + allowed <- lift allowedMethods + if requestMethod req `elem` allowed + then b09 r + else do + lift $ addResponseHeader ("Allow", intercalate "," allowed) + lift $ halt HTTP.status405 + +b09 r@Resource{..} = do + trace "b09" + malformed <- lift malformedRequest + if malformed + then lift $ halt HTTP.status400 + else b08 r + +b08 r@Resource{..} = do + trace "b08" + authorized <- lift isAuthorized + if authorized + then b07 r + else lift $ halt HTTP.status401 + +b07 r@Resource{..} = do + trace "b07" + forbid <- lift forbidden + if forbid + then lift $ halt HTTP.status403 + else b06 r + +b06 r@Resource{..} = do + trace "b06" + validC <- lift validContentHeaders + if validC + then b05 r + else lift $ halt HTTP.status501 + +b05 r@Resource{..} = do + trace "b05" + known <- lift knownContentType + if known + then b04 r + else lift $ halt HTTP.status415 + +b04 r@Resource{..} = do + trace "b04" + large <- lift entityTooLarge + if large + then lift $ halt HTTP.status413 + else b03 r + +b03 r@Resource{..} = do + trace "b03" + req <- lift request + allowed <- lift allowedMethods + if requestMethod req == HTTP.methodOptions + then do + lift $ addResponseHeader ("Allow", intercalate "," allowed) + lift $ halt HTTP.status204 + else c03 r + +------------------------------------------------------------------------------ +-- C column +------------------------------------------------------------------------------ + +c04 r@Resource{..} = do + trace "c04" + req <- lift request + provided <- lift contentTypesProvided + let reqHeaders = requestHeaders req + result = do + acceptStr <- lookup HTTP.hAccept reqHeaders + (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr + Just (acceptTyp, resource) + where + -- this is so that in addition to getting back the resource + -- that we match, we also return the content-type provided + -- by that resource. + provided' = map dupContentType provided + dupContentType (a, b) = (a, (a, b)) + + case result of + Nothing -> lift $ halt HTTP.status406 + Just res -> do + modify (\fs -> fs { _contentType = Just res }) + d04 r + +c03 r@Resource{..} = do + trace "c03" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hAccept reqHeaders of + (Just _h) -> + c04 r + Nothing -> + d04 r + +------------------------------------------------------------------------------ +-- D column +------------------------------------------------------------------------------ + +d05 r@Resource{..} = do + trace "d05" + langAvailable <- lift languageAvailable + if langAvailable + then e05 r + else lift $ halt HTTP.status406 + +d04 r@Resource{..} = do + trace "d04" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hAcceptLanguage reqHeaders of + (Just _h) -> + d05 r + Nothing -> + e05 r + +------------------------------------------------------------------------------ +-- E column +------------------------------------------------------------------------------ + +e06 r@Resource{..} = do + trace "e06" + -- TODO: charset negotiation + f06 r + +e05 r@Resource{..} = do + trace "e05" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hAcceptCharset reqHeaders of + (Just _h) -> + e06 r + Nothing -> + f06 r + +------------------------------------------------------------------------------ +-- F column +------------------------------------------------------------------------------ + +f07 r@Resource{..} = do + trace "f07" + -- TODO: encoding negotiation + g07 r + +f06 r@Resource{..} = do + trace "f06" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hAcceptEncoding reqHeaders of + (Just _h) -> + f07 r + Nothing -> + g07 r + +------------------------------------------------------------------------------ +-- G column +------------------------------------------------------------------------------ + +g11 (IfMatch ifMatch) r@Resource{..} = do + trace "g11" + let etags = parseEtagList ifMatch + if null etags + then lift $ halt HTTP.status412 + else h10 r + +g09 ifMatch r@Resource{..} = do + trace "g09" + case ifMatch of + -- TODO: should we be stripping whitespace here? + (IfMatch "*") -> + h10 r + _ -> + g11 ifMatch r + +g08 r@Resource{..} = do + trace "g08" + req <- lift request + let reqHeaders = requestHeaders req + case IfMatch <$> lookup hIfMatch reqHeaders of + (Just h) -> + g09 h r + Nothing -> + h10 r + +g07 r@Resource{..} = do + trace "g07" + -- TODO: set Vary headers + exists <- lift resourceExists + if exists + then g08 r + else h07 r + +------------------------------------------------------------------------------ +-- H column +------------------------------------------------------------------------------ + +h12 r@Resource{..} = do + trace "h12" + modified <- lift lastModified + parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince + let maybeGreater = do + lastM <- modified + headerDate <- parsedDate + return (lastM > headerDate) + if maybeGreater == Just True + then lift $ halt HTTP.status412 + else i12 r + +h11 r@Resource{..} = do + trace "h11" + parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince + if isJust parsedDate + then h12 r + else i12 r + +h10 r@Resource{..} = do + trace "h10" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hIfUnmodifiedSince reqHeaders of + (Just _h) -> + h11 r + Nothing -> + i12 r + +h07 r@Resource {..} = do + trace "h07" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hIfMatch reqHeaders of + -- TODO: should we be stripping whitespace here? + (Just "*") -> + lift $ halt HTTP.status412 + _ -> + i07 r + +------------------------------------------------------------------------------ +-- I column +------------------------------------------------------------------------------ + +i13 ifNoneMatch r@Resource{..} = do + trace "i13" + case ifNoneMatch of + -- TODO: should we be stripping whitespace here? + (IfNoneMatch "*") -> + j18 r + _ -> + k13 ifNoneMatch r + +i12 r@Resource{..} = do + trace "i12" + req <- lift request + let reqHeaders = requestHeaders req + case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of + (Just h) -> + i13 h r + Nothing -> + l13 r + +i07 r = do + trace "i07" + req <- lift request + if requestMethod req == HTTP.methodPut + then i04 r + else k07 r + +i04 r@Resource{..} = do + trace "i04" + moved <- lift movedPermanently + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status301 + Nothing -> + p03 r + +------------------------------------------------------------------------------ +-- J column +------------------------------------------------------------------------------ + +j18 _ = do + trace "j18" + req <- lift request + let getOrHead = [ HTTP.methodGet + , HTTP.methodHead + ] + if requestMethod req `elem` getOrHead + then lift $ halt HTTP.status304 + else lift $ halt HTTP.status412 + +------------------------------------------------------------------------------ +-- K column +------------------------------------------------------------------------------ + +k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do + trace "k13" + let etags = parseEtagList ifNoneMatch + if null etags + then l13 r + else j18 r + +k07 r@Resource{..} = do + trace "k07" + prevExisted <- lift previouslyExisted + if prevExisted + then k05 r + else l07 r + +k05 r@Resource{..} = do + trace "k05" + moved <- lift movedPermanently + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status301 + Nothing -> + l05 r + +------------------------------------------------------------------------------ +-- L column +------------------------------------------------------------------------------ + +l17 r@Resource{..} = do + trace "l17" + parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince + modified <- lift lastModified + let maybeGreater = do + lastM <- modified + ifModifiedSince <- parsedDate + return (lastM > ifModifiedSince) + if maybeGreater == Just True + then m16 r + else lift $ halt HTTP.status304 + +l15 r@Resource{..} = do + trace "l15" + parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince + now <- lift requestTime + let maybeGreater = (> now) <$> parsedDate + if maybeGreater == Just True + then m16 r + else l17 r + +l14 r@Resource{..} = do + trace "l14" + req <- lift request + let reqHeaders = requestHeaders req + dateHeader = lookup HTTP.hIfModifiedSince reqHeaders + validDate = isJust (dateHeader >>= parseRfc1123Date) + if validDate + then l15 r + else m16 r + +l13 r@Resource{..} = do + trace "l13" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hIfModifiedSince reqHeaders of + (Just _h) -> + l14 r + Nothing -> + m16 r + +l07 r = do + trace "l07" + req <- lift request + if requestMethod req == HTTP.methodPost + then m07 r + else lift $ halt HTTP.status404 + +l05 r@Resource{..} = do + trace "l05" + moved <- lift movedTemporarily + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status307 + Nothing -> + m05 r + +------------------------------------------------------------------------------ +-- M column +------------------------------------------------------------------------------ + +m20 r@Resource{..} = do + trace "m20" + deleteAccepted <- lift deleteResource + if deleteAccepted + then do + completed <- lift deleteCompleted + if completed + then o20 r + else lift $ halt HTTP.status202 + else lift $ halt HTTP.status500 + +m16 r = do + trace "m16" + req <- lift request + if requestMethod req == HTTP.methodDelete + then m20 r + else n16 r + +m07 r@Resource{..} = do + trace "m07" + allowMissing <- lift allowMissingPost + if allowMissing + then n11 r + else lift $ halt HTTP.status404 + +m05 r = do + trace "m05" + req <- lift request + if requestMethod req == HTTP.methodPost + then n05 r + else lift $ halt HTTP.status410 + +------------------------------------------------------------------------------ +-- N column +------------------------------------------------------------------------------ + +n16 r = do + trace "n16" + req <- lift request + if requestMethod req == HTTP.methodPost + then n11 r + else o16 r + +n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r + +create :: Monad m => [Text] -> Resource m -> FlowStateT m () +create ts r = do + loc <- lift (appendRequestPath ts) + lift (addResponseHeader ("Location", loc)) + negotiateContentTypesAccepted r + +processPostAction :: Monad m => PostResponse m -> Flow m +processPostAction (PostCreate ts) r = do + create ts r + p11 r +processPostAction (PostCreateRedirect ts) r = do + create ts r + lift $ halt HTTP.status303 +processPostAction (PostProcess p) r = + lift p >> p11 r +processPostAction (PostProcessRedirect ts) _r = do + locBs <- lift ts + lift $ addResponseHeader ("Location", locBs) + lift $ halt HTTP.status303 + +n05 r@Resource{..} = do + trace "n05" + allow <- lift allowMissingPost + if allow + then n11 r + else lift $ halt HTTP.status410 + +------------------------------------------------------------------------------ +-- O column +------------------------------------------------------------------------------ + +o20 r = do + trace "o20" + body <- lift getResponseBody + -- ResponseBody is a little tough to make an instance of 'Eq', + -- so we just use a pattern match + case body of + Empty -> lift $ halt HTTP.status204 + _ -> o18 r + +o18 r@Resource{..} = do + trace "o18" + multiple <- lift multipleChoices + if multiple + then lift $ halt HTTP.status300 + else do + -- TODO: set etag, expiration, etc. headers + req <- lift request + let getOrHead = [ HTTP.methodGet + , HTTP.methodHead + ] + when (requestMethod req `elem` getOrHead) $ do + m <- _contentType <$> get + (cType, body) <- case m of + Nothing -> do + provided <- lift contentTypesProvided + return (head provided) + Just (cType, body) -> + return (cType, body) + b <- lift body + lift $ putResponseBody b + lift $ addResponseHeader ("Content-Type", renderHeader cType) + writeCacheTags r + lift $ halt HTTP.status200 + +o16 r = do + trace "o16" + req <- lift request + if requestMethod req == HTTP.methodPut + then o14 r + else o18 r + +o14 r@Resource{..} = do + trace "o14" + conflict <- lift isConflict + if conflict + then lift $ halt HTTP.status409 + else negotiateContentTypesAccepted r >> p11 r + +------------------------------------------------------------------------------ +-- P column +------------------------------------------------------------------------------ + +p11 r = do + trace "p11" + headers <- lift getResponseHeaders + case lookup HTTP.hLocation headers of + (Just _) -> + lift $ halt HTTP.status201 + _ -> + o20 r + +p03 r@Resource{..} = do + trace "p03" + conflict <- lift isConflict + if conflict + then lift $ halt HTTP.status409 + else negotiateContentTypesAccepted r >> p11 r diff --git a/tests/examples/ghc8/F.hs b/tests/examples/ghc8/F.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/F.hs @@ -0,0 +1,20 @@ +-- | Thompson's group F. +-- +-- See eg. +-- +-- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; +-- see +-- + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} +module Math.Combinat.Groups.Thompson.F where + +-- | Remove the carets with the given indices +-- (throws an error if there is no caret at the given index) +removeCarets :: [Int] -> T -> T +removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where + + (_,rem,final) = go 0 idxs tree where + + go :: Int -> [Int] -> T -> (Int,[Int],T) + go !x [] t = (x + treeWidth t , [] , t) diff --git a/tests/examples/ghc8/Families.hs b/tests/examples/ghc8/Families.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Families.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds, KindSignatures, + TypeOperators, UndecidableInstances #-} + +{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, EmptyDataDecls #-} + +-- | A prelude for type-level programming with type families + +module Prelude.Type.Families where + +-- >>> T :: T ((I 4) `Minus` (I 7)) +-- -3 +type family (a :: k) `Minus` (b :: k) :: k +type instance a `Minus` b = a + Negate b + diff --git a/tests/examples/ghc8/ForFree.hs b/tests/examples/ghc8/ForFree.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ForFree.hs @@ -0,0 +1,23 @@ + +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.ForFree where { + +-- | Free monad from a functor +; + data Free f x = Pure x | Free (f (Free f x)); + + deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a); + deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a); + deriving instance (Read (f (Free f a)), Read a) => Read (Free f a); + deriving instance (Show (f (Free f a)), Show a) => Show (Free f a); +} diff --git a/tests/examples/ghc8/FromGrin2.hs b/tests/examples/ghc8/FromGrin2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/FromGrin2.hs @@ -0,0 +1,6 @@ + +-- ./hackage-roundtrip-work/ajhc-0.8.0.10/src/C/FromGrin2.hs +-- orig line 588 +convertExp :: Exp -> C (Statement,Expression) +convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do + return (mempty,e) diff --git a/tests/examples/ghc8/GA1r.hs b/tests/examples/ghc8/GA1r.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/GA1r.hs @@ -0,0 +1,5 @@ +module GA1r where +import Text.ParserCombinators.Parsec + +parseStr :: CharParser () String +parseStr = char '"' *> (many1 (noneOf "\"")) <* char '"' diff --git a/tests/examples/ghc8/Generic.hs b/tests/examples/ghc8/Generic.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Generic.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +module Env.Generic + ( Record(..) + , type (?)(..) + ) where + +import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$)) +import Options.Generic (Generic, ParseRecord, type ()(..)) diff --git a/tests/examples/ghc8/Manipulate.hs b/tests/examples/ghc8/Manipulate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Manipulate.hs @@ -0,0 +1,39 @@ +{- | +Module : Control.Comonad.Sheet.Manipulate +Description : Generic functions for manipulating multi-dimensional comonadic spreadsheets. +Copyright : Copyright (c) 2014 Kenneth Foner + +Maintainer : kenneth.foner@gmail.com +Stability : experimental +Portability : non-portable + +This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These +constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite +slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert'). +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.Comonad.Sheet.Manipulate where + + +-- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@. +instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where + type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a) + asDimensionalAs = asNestedAs + +-- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures. +instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where + type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a) + x `asDimensionalAs` (Indexed i t) = x `asNestedAs` t + + +instance DepIndex (a,b) TH_0 where + type (a,b) `DepIndexResult` TH_0 = a + (a,b) # TH_0 = a diff --git a/tests/examples/ghc8/Match.hs b/tests/examples/ghc8/Match.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Match.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} + +-- Discriminate binary functions that commute, and if so return the operands in +-- a stable ordering such that matching recognises expressions modulo +-- commutativity. +-- +commutes + :: forall acc env aenv a r. + HashAcc acc + -> PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> Maybe (PreOpenExp acc env aenv a) +commutes h f x = case f of + PrimAdd _ -> Just (swizzle x) + PrimMul _ -> Just (swizzle x) + PrimBAnd _ -> Just (swizzle x) + PrimBOr _ -> Just (swizzle x) + PrimBXor _ -> Just (swizzle x) + PrimEq _ -> Just (swizzle x) + PrimNEq _ -> Just (swizzle x) + PrimMax _ -> Just (swizzle x) + PrimMin _ -> Just (swizzle x) + PrimLAnd -> Just (swizzle x) + PrimLOr -> Just (swizzle x) + _ -> Nothing + where + swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') + swizzle exp + | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp + , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) + -- + | otherwise = exp diff --git a/tests/examples/ghc8/MultiQuote.hs b/tests/examples/ghc8/MultiQuote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/MultiQuote.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes#-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Internal API for the store package. The functions here which are +-- not re-exported by "Data.Store" are less likely to have stable APIs. +-- +-- This module also defines most of the included 'Store' instances, for +-- types from the base package and other commonly used packages +-- (bytestring, containers, text, time, etc). +module Data.Store.Internal where + +------------------------------------------------------------------------ +-- Instances generated by TH + +$($(derive [d| + -- TODO + -- instance Deriving (Store ()) + instance Deriving (Store All) + instance Deriving (Store Any) + instance Deriving (Store Void) + instance Deriving (Store Bool) + |])) + diff --git a/tests/examples/ghc8/PSQ.hs b/tests/examples/ghc8/PSQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/PSQ.hs @@ -0,0 +1,4 @@ + +data TourView a = Null + | Single {-# UNPACK #-} !(Elem a) + | (PSQ a) `Play` (PSQ a) diff --git a/tests/examples/ghc8/Ppr017.hs b/tests/examples/ghc8/Ppr017.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Ppr017.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExplicitNamespaces #-} +module Imports( f, type (+), pattern Single ) where + +import GHC.TypeLits + +pattern Single x = [x] + +f = undefined diff --git a/tests/examples/ghc8/Query.hs b/tests/examples/ghc8/Query.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Query.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module AWS.Lib.Query where + +requestQuery = do + if st < 400 +#ifdef DEBUG + do e +#else + then return body + else fail "not reached" +#endif + diff --git a/tests/examples/ghc8/RulePragma.hs b/tests/examples/ghc8/RulePragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/RulePragma.hs @@ -0,0 +1,7 @@ +module Data.Text.Internal.Fusion.Common where + +{-# + RULES "STREAM map/map fusion" forall f g s. + map f (map g s) = map (\x -> f (g x)) s + #-} + diff --git a/tests/examples/ghc8/SpecializePhaseControl.hs b/tests/examples/ghc8/SpecializePhaseControl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/SpecializePhaseControl.hs @@ -0,0 +1,15 @@ +{-# SPECIALISE [1] x :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] x #-} +x :: (Num a, Integral b) => a -> b -> a +x = undefined + +{-# SPECIALISE INLINE [999] y :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] y #-} +y :: (Num a, Integral b) => a -> b -> a +y = undefined diff --git a/tests/examples/ghc8/Structure8.hs b/tests/examples/ghc8/Structure8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Structure8.hs @@ -0,0 +1,1 @@ +foo x | otherwise = y diff --git a/tests/examples/ghc8/Structure8a.hs b/tests/examples/ghc8/Structure8a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Structure8a.hs @@ -0,0 +1,1 @@ +foo x = y diff --git a/tests/examples/ghc8/T11381.hs b/tests/examples/ghc8/T11381.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T11381.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} + +module T11381 where + +-- ensure that this code does not compile without InjectiveTypeFamilies and that +-- injectivity error is not reported. +type family F a = r | r -> a +type instance F Int = Bool +type instance F Int = Char diff --git a/tests/examples/ghc8/T11959.hs b/tests/examples/ghc8/T11959.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T11959.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +import T11959Lib (Vec2(..), pattern (:>)) + +main = return () diff --git a/tests/examples/ghc8/Templates.hs b/tests/examples/ghc8/Templates.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Templates.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, FlexibleInstances, OverlappingInstances, TypeOperators, PatternGuards #-} +module Object.Templates( + makeName, + makeObject, + makeObjectFlexible + ) where + +import Object.Letters +import Object.Types + +import Prelude hiding ((.)) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Data.Char +import Data.Maybe + +-- | +-- implements 'makeObject' or 'makeObjectFlexible' depending on the first argument +makeObject' :: Bool -> Name -> Q [Dec] +makeObject' flexible name = go name where + go :: Name -> Q [Dec] + go obj = do + (name, vars, fields) <- reify name >>= getInfo + let objType = foldl AppT (ConT name) (VarT<*vars) + outputDecls <- if flexible + then return [] + else [d| + type instance Output $(return objType) (Method m) = + MethodOutput $(return objType) (Method m) + type instance Output $(return objType) (Method m := input) = + MethodOutput $(return objType) (Method m := input) + |] + fieldDecls <- (sequence $ makeField name vars <* fields) *> concat + return $ outputDecls ++ fieldDecls +-- "(Object.Example.Foo,[x_1627454179],[(Object.Example._bar,NotStrict,ConT GHC.Types.Int),(Object.Example._baz,NotStrict,ConT GHC.Types.Char),(Object.Example._blub,NotStrict,VarT x_1627454179)])" + makeField :: Name -> [Name] -> VarStrictType -> Q [Dec] + makeField _ _ (name,_,_) | '_' /= head (nameBase name) = fail $ show name ++ " did not start with underscore" + makeField name vars (fName, _, fType) = do + (decs1,(typeName,dataName)) <- makeName' (tail $ nameBase fName) + methodOutput <- lookupTypeName "Object.Types.MethodOutput" *> fromMaybe (error "no MethodOutput in scope") + let objType = foldl AppT (ConT name) (VarT<*vars) + + let methodOutInst = TySynInstD methodOutput $ TySynEqn [objType, ConT typeName] fType + actionInst <- [d| + instance Action $(return objType) $(return $ ConT typeName) where + object . _ = $(return $ VarE fName) object + |] + + matchType <- [t| $(return $ ConT typeName) := $(return $ VarT $ mkName "value") |] + let methodSetOutInst = TySynInstD methodOutput $ TySynEqn [objType, matchType] objType + actionSetInst <- [d| + instance (value ~ $(return fType)) => Action $(return objType) $(return matchType) where + object . ( _ := v) = $(recUpdE [e|object|] [return (fName, VarE $ mkName "v")]) + |] + + return $ [methodOutInst,methodSetOutInst] ++ actionInst ++ actionSetInst ++ decs1 + diff --git a/tests/examples/ghc8/TestUtils.hs b/tests/examples/ghc8/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TestUtils.hs @@ -0,0 +1,5 @@ + +module Math.NumberTheory.TestUtils where + +class (f `Compose` g) x + diff --git a/tests/examples/ghc8/UnicodeSyntax.hs b/tests/examples/ghc8/UnicodeSyntax.hs --- a/tests/examples/ghc8/UnicodeSyntax.hs +++ b/tests/examples/ghc8/UnicodeSyntax.hs @@ -234,3 +234,10 @@ , reCloseH ∷ !(FinalizerHandle r) } +-- from ghc-prim + +-- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' +type * = TYPE 'PtrRepLifted + +-- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' +type ★ = TYPE 'PtrRepLifted diff --git a/tests/examples/ghc8/Webhook.hs b/tests/examples/ghc8/Webhook.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Webhook.hs @@ -0,0 +1,176 @@ +{-| +Module : Servant.GitHub.Webhook +Description : Easily write safe GitHub webhook handlers with Servant +Copyright : (c) Jacob Thomas Errington, 2016 +License : MIT +Maintainer : servant-github-webhook@mail.jerrington.me +Stability : experimental + +The GitHub webhook machinery will attach three headers to the HTTP requests +that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. +The former two headers correspond with the 'GitHubEvent' and +'GitHubSignedReqBody''' routing combinators. This library ignores the +@X-Github-Delivery@ header; if you would like to access its value, then use the +builtin 'Header' combinator from Servant. + +Usage of the library is straightforward: protect routes with the 'GitHubEvent' +combinator to ensure that the route is only reached for specific +'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write +under that route with 'GitHubSignedReqBody'. It is advised to always include a +'GitHubSignedReqBody''', as this is the only way you can be sure that it is +GitHub who is sending the request, and not a malicious user. If you don't care +about the request body, then simply use Aeson\'s 'Object' type as the +deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and +ignore the @Object@ in the handler. + +The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in +order to extract the signing key. This is the same key that must be entered in +the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. + +In order to support multiple keys on a per-route basis, the basic combinator +@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, +create a datatype, e.g. @KeyIndex@ whose constructors identify the different +keys you will be using. Generally, this means one constructor per repository. +Use the @DataKinds@ extension to promote this datatype to a kind, and write an +instance of 'Reflect' for each promoted constructor of your datatype. Finally, +create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is +the datatype you've built up. Thus, your function can determine which key to +retrieve. +-} + +{-# LANGUAGE CPP #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- GHC 8 seems to have improved its decidability check for type family +-- instances and class instances. In particular, without UndecidableInstances +-- enabled, the Demote' instance for lists, which we need, will not compile. +-- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, +-- won't compile on GHC < 8 because the instance head is no smaller than the +-- instance head. +#if __GLASGOW_HASKELL__ < 800 +{-# LANGUAGE UndecidableInstances #-} +#endif + +module Servant.GitHub.Webhook +( -- * Servant combinators + GitHubSignedReqBody'' +, GitHubSignedReqBody' +, GitHubSignedReqBody +, GitHubEvent + + -- ** Security +, GitHubKey'(..) +, GitHubKey +, gitHubKey + + -- * Reexports + -- + -- | We reexport a few datatypes that are typically needed to use the + -- library. +, RepoWebhookEvent(..) +, KProxy(..) + + -- * Implementation details + + -- ** Type-level programming machinery +, Demote +, Demote' +, Reflect(..) + + -- ** Stringy stuff +, parseHeaderMaybe +, matchEvent + + -- * Examples + -- + -- $example1 + -- + -- $example2 +) where + +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson ( decode', encode ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy ( fromStrict, toStrict ) +import qualified Data.ByteString.Base16 as B16 +import Data.HMAC ( hmac_sha1 ) +import Data.List ( intercalate ) +import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Monoid ( (<>) ) +import Data.Proxy +import Data.String.Conversions ( cs ) +import qualified Data.Text.Encoding as E +import GHC.TypeLits +import GitHub.Data.Webhooks +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Wai ( requestHeaders, strictRequestBody ) +import Servant +import Servant.API.ContentTypes ( AllCTUnrender(..) ) +import Servant.Server.Internal + + +-- | A clone of Servant's 'ReqBody' combinator, except that it will also +-- verify the signature provided by GitHub in the @X-Hub-Signature@ header by +-- computing the SHA1 HMAC of the request body and comparing. +-- +-- The use of this combinator will require that the router context contain an +-- appropriate 'GitHubKey'' entry. Specifically, the type parameter of +-- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the +-- index @key@ used here. Consequently, it will be necessary to use +-- 'serveWithContext' instead of 'serve'. +-- +-- Other routes are not tried upon the failure of this combinator, and a 401 +-- response is generated. +-- +-- Use of this datatype directly is discouraged, since the choice of the index +-- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use +-- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just +-- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for +-- the implementation of the 'HasServer' instance for the datatype. +data GitHubSignedReqBody'' + (proxy :: KProxy k) + (key :: k) + (list :: [*]) + (result :: *) where + +-- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first +-- type argument given just the second one. +-- +-- Use this type synonym if you are creating a webhook server to handle +-- webhooks from multiple repositories, with different secret keys. +type GitHubSignedReqBody' (key :: k) + = GitHubSignedReqBody'' ('KProxy :: KProxy k) key + +-- | A convenient alias for a trivial key index. +-- +-- USe this type synonym if you are creating a webhook server to handle only +-- webhooks from a single repository, or for mutliple repositories using the +-- same secret key. +type GitHubSignedReqBody = GitHubSignedReqBody' '() + +-- | A routing combinator that succeeds only for a webhook request that matches +-- one of the given 'RepoWebhookEvent' given in the type-level list @events@. +-- +-- If the list contains 'WebhookWildcardEvent', then all events will be +-- matched. +-- +-- The combinator will require that its associated handler take a +-- 'RepoWebhookEvent' parameter, and the matched event will be passed to the +-- handler. This allows the handler to determine which event triggered it from +-- the list. +-- +-- Other routes are tried if there is a mismatch. +data GitHubEvent (events :: [RepoWebhookEvent]) where +