module Language.Haskell.GHC.ExactPrint.Annotater
(
annotate
, AnnotationF(..)
, Annotated
, Annotate(..)
, withSortKeyContextsHelper
) where
import Language.Haskell.GHC.ExactPrint.AnnotateTypes
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils
import qualified Bag as GHC
import qualified BasicTypes as GHC
import qualified BooleanFormula as GHC
import qualified Class as GHC
import qualified CoAxiom as GHC
import qualified FastString as GHC
import qualified ForeignCall as GHC
import qualified GHC as GHC
import qualified Name as GHC
import qualified RdrName as GHC
import qualified Outputable as GHC
import Control.Monad.Identity
import Data.Data
import Data.Maybe
import qualified Data.Set as Set
import Debug.Trace
class Data ast => Annotate ast where
markAST :: GHC.SrcSpan -> ast -> Annotated ()
annotate :: (Annotate ast) => GHC.Located ast -> Annotated ()
annotate = markLocated
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
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'
markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated ()
markListIntercalate ls = markListIntercalateWithFun markLocated ls
markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated ()
markListWithContexts ctxInitial ctxRest ls =
case ls of
[] -> return ()
[x] -> setContextLevel ctxInitial 2 $ markLocated x
(x:xs) -> do
setContextLevel ctxInitial 2 $ markLocated x
setContextLevel ctxRest 2 $ mapM_ markLocated xs
markListWithContexts' :: Annotate ast
=> ListContexts
-> [GHC.Located ast] -> Annotated ()
markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls =
case ls of
[] -> return ()
[x] -> setContextLevel ctxOnly level $ markLocated x
(x:xs) -> do
setContextLevel ctxInitial level $ markLocated x
go xs
where
level = 2
go [] = return ()
go [x] = setContextLevel ctxLast level $ markLocated x
go (x:xs) = do
setContextLevel ctxMiddle level $ markLocated x
go xs
markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated ()
markListWithLayout ls =
setLayoutFlag $ markList ls
markList :: Annotate ast => [GHC.Located ast] -> Annotated ()
markList ls =
setContext (Set.singleton NoPrecedingSpace)
$ markListWithContexts' listContexts' ls
markLocalBindsWithLayout :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.HsLocalBinds name -> Annotated ()
markLocalBindsWithLayout binds =
markHsLocalBinds binds
markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated ()
markLocatedFromKw kw (GHC.L l a) = do
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
prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())]
prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls
instance Annotate (GHC.HsModule GHC.RdrName) where
markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do
case mmn of
Nothing -> return ()
Just (GHC.L ln mn) -> do
mark GHC.AnnModule
markExternal ln GHC.AnnVal (GHC.moduleNameString mn)
forM_ mdepr markLocated
forM_ mexp markLocated
mark GHC.AnnWhere
markOptional GHC.AnnOpenC
markManyOptional GHC.AnnSemi
setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps
setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs
markOptional GHC.AnnCloseC
markEOF
instance Annotate GHC.WarningTxt where
markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do
markExternal ls GHC.AnnOpen txt
mark GHC.AnnOpenS
markListIntercalate lss
mark GHC.AnnCloseS
markWithString GHC.AnnClose "#-}"
markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do
markExternal ls GHC.AnnOpen txt
mark GHC.AnnOpenS
markListIntercalate lss
mark GHC.AnnCloseS
markWithString GHC.AnnClose "#-}"
instance Annotate GHC.StringLiteral where
markAST l (GHC.StringLiteral src _) = do
markExternal l GHC.AnnVal src
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance Annotate (GHC.SourceText,GHC.FastString) where
markAST l (src,_fs) = do
markExternal l GHC.AnnVal src
instance (GHC.DataId name,GHC.HasOccName name,Annotate name)
=> Annotate [GHC.LIE name] where
markAST _ ls = do
inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding
mark GHC.AnnOpenP
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
if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln
then mark GHC.AnnPattern
else markOptional GHC.AnnPattern
setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln
(GHC.IEThingAbs ln) -> do
setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln
(GHC.IEThingWith ln wc ns _lfs) -> do
setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln
mark GHC.AnnOpenP
case wc of
GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp,InIE])
$ markListIntercalate ns
GHC.IEWildcard n -> do
setContext (Set.fromList [PrefixOp,Intercalate,InIE]) $ mapM_ markLocated (take n ns)
mark GHC.AnnDotdot
case drop n ns of
[] -> return ()
ns' -> do
mark GHC.AnnComma
setContext (Set.fromList [PrefixOp,InIE]) $ mapM_ markLocated ns'
mark GHC.AnnCloseP
(GHC.IEThingAll ln) -> do
setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln
mark GHC.AnnOpenP
mark GHC.AnnDotdot
mark GHC.AnnCloseP
(GHC.IEModuleContents (GHC.L lm mn)) -> do
mark GHC.AnnModule
markExternal lm GHC.AnnVal (GHC.moduleNameString mn)
(GHC.IEGroup _ _) -> return ()
(GHC.IEDoc _) -> return ()
(GHC.IEDocNamed _) -> return ()
ifInContext (Set.fromList [Intercalate])
(mark GHC.AnnComma)
(markOptional GHC.AnnComma)
isSymRdr :: GHC.RdrName -> Bool
isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "."
instance Annotate GHC.RdrName where
markAST l n = do
let
str = rdrName2String n
isSym = isSymRdr n
typeIESym = isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n)
&& spanLength l length str > 6
canParen = isSym && rdrName2String n /= "$"
&& (not typeIESym)
doNormalRdrName = do
let str' = case str of
"forall" -> if spanLength l == 1 then "∀" else str
_ -> str
when (spanLength l length str > 4) $ inContext (Set.singleton InIE) $ mark GHC.AnnType
let str'' = if typeIESym then "(" ++ str' ++ ")"
else str'
let
markParen :: GHC.AnnKeywordId -> Annotated ()
markParen pa = do
if canParen
then ifInContext (Set.singleton PrefixOp)
(mark pa)
(markOptional pa)
else if isSym
then ifInContext (Set.singleton PrefixOpDollar)
(mark pa)
(markOptional pa)
else markOptional pa
markParen GHC.AnnOpenP
unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0
cnt <- countAnns GHC.AnnVal
case cnt of
0 -> markExternal l GHC.AnnVal str'
1 -> markWithString GHC.AnnVal str''
_ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n)
unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1
markParen GHC.AnnCloseP
case n of
GHC.Unqual _ -> doNormalRdrName
GHC.Qual _ _ -> doNormalRdrName
GHC.Orig _ _ -> if str == "~"
then doNormalRdrName
else markExternal l GHC.AnnVal str
GHC.Exact n' -> do
case str of
"[]" -> 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
markExternal l GHC.AnnVal str
":" -> do
doNormalRdrName
('(':',':_) -> do
mark GHC.AnnOpenP
let cnt = length $ filter (==',') str
replicateM_ cnt (mark GHC.AnnCommaTuple)
mark GHC.AnnCloseP
_ -> do
let isSym' = isSymRdr (GHC.nameRdrName n')
when isSym' $ mark GHC.AnnOpenP
markWithString GHC.AnnVal str
when isSym $ mark GHC.AnnCloseP
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName")
instance Annotate GHC.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
mark GHC.AnnImport
when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc)
>> markWithString GHC.AnnClose "#-}")
when safeflag (mark GHC.AnnSafe)
when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified)
case mpkg of
Nothing -> return ()
Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg
markLocated modname
case GHC.ideclAs imp of
Nothing -> return ()
Just mn -> do
mark GHC.AnnAs
markWithString GHC.AnnVal (GHC.moduleNameString mn)
case hiding of
Nothing -> return ()
Just (isHiding,lie) -> do
if isHiding
then setContext (Set.singleton HasHiding) $
markLocated lie
else markLocated lie
markTrailingSemi
instance Annotate GHC.ModuleName where
markAST l mname =
markExternal l GHC.AnnVal (GHC.moduleNameString mname)
markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.LHsDecl name -> Annotated ()
markLHsDecl (GHC.L l decl) =
case decl of
GHC.TyClD d -> markLocated (GHC.L l d)
GHC.InstD d -> markLocated (GHC.L l d)
GHC.DerivD d -> markLocated (GHC.L l d)
GHC.ValD d -> markLocated (GHC.L l d)
GHC.SigD d -> markLocated (GHC.L l d)
GHC.DefD d -> markLocated (GHC.L l d)
GHC.ForD d -> markLocated (GHC.L l d)
GHC.WarningD d -> markLocated (GHC.L l d)
GHC.AnnD d -> markLocated (GHC.L l d)
GHC.RuleD d -> markLocated (GHC.L l d)
GHC.VectD d -> markLocated (GHC.L l d)
GHC.SpliceD d -> markLocated (GHC.L l d)
GHC.DocD d -> markLocated (GHC.L l d)
GHC.RoleAnnotD d -> markLocated (GHC.L l d)
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsDecl name) where
markAST l d = markLHsDecl (GHC.L l d)
instance (Annotate name)
=> Annotate (GHC.RoleAnnotDecl name) where
markAST _ (GHC.RoleAnnotDecl ln mr) = do
mark GHC.AnnType
mark GHC.AnnRole
markLocated ln
mapM_ markLocated mr
instance Annotate (Maybe GHC.Role) where
markAST l Nothing = markExternal l GHC.AnnVal "_"
markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r)
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.SpliceDecl name) where
markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do
setContext (Set.singleton InSpliceDecl) $ markLocated e
markTrailingSemi
markAST _ (GHC.SpliceDecl e flag) = do
case flag of
GHC.ExplicitSplice -> mark GHC.AnnOpenPE
GHC.ImplicitSplice -> return ()
setContext (Set.singleton InSpliceDecl) $ markLocated e
case flag of
GHC.ExplicitSplice -> mark GHC.AnnCloseP
GHC.ImplicitSplice -> return ()
markTrailingSemi
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
markLocated ln
mark GHC.AnnEqual
markLocated e
markWithString GHC.AnnClose "#-}"
markAST _ (GHC.HsNoVect src ln) = do
markWithString GHC.AnnOpen src
markLocated ln
markWithString GHC.AnnClose "#-}"
markAST _ (GHC.HsVectTypeIn src _b ln mln) = do
markWithString GHC.AnnOpen src
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
mark GHC.AnnClass
markLocated ln
markWithString GHC.AnnClose "#-}"
markAST _ GHC.HsVectClassOut {} =
traceM "warning: HsVecClassOut appears after renaming"
markAST _ GHC.HsVectInstIn {} =
traceM "warning: HsVecInstsIn appears after renaming"
markAST _ GHC.HsVectInstOut {} =
traceM "warning: HsVecInstOut appears after renaming"
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.RuleDecls name) where
markAST _ (GHC.HsRules src rules) = do
markWithString GHC.AnnOpen src
setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules
markWithString GHC.AnnClose "#-}"
markTrailingSemi
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.RuleDecl name) where
markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do
markLocated ln
setContext (Set.singleton ExplicitNeverActive) $ markActivation act
unless (null bndrs) $ do
mark GHC.AnnForall
mapM_ markLocated bndrs
mark GHC.AnnDot
markLocated lhs
mark GHC.AnnEqual
markLocated rhs
inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi
markTrailingSemi
markActivation :: GHC.Activation -> Annotated ()
markActivation act = do
case act of
GHC.ActiveBefore src _ -> do
mark GHC.AnnOpenS
mark GHC.AnnTilde
markWithString GHC.AnnVal src
mark GHC.AnnCloseS
GHC.ActiveAfter src _ -> do
mark GHC.AnnOpenS
markWithString GHC.AnnVal src
mark GHC.AnnCloseS
GHC.NeverActive -> do
inContext (Set.singleton ExplicitNeverActive) $ do
mark GHC.AnnOpenS
mark GHC.AnnTilde
mark GHC.AnnCloseS
_ -> return ()
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.RuleBndr name) where
markAST _ (GHC.RuleBndr ln) = markLocated ln
markAST _ (GHC.RuleBndrSig ln st) = do
mark GHC.AnnOpenP
markLocated ln
mark GHC.AnnDcolon
markLHsSigWcType st
mark GHC.AnnCloseP
markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.LHsSigWcType name -> Annotated ()
markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do
case mwc of
Nothing -> markLocated ty
Just lwc -> do
applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")]
++ prepareListAnnotation [ty]
)
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.AnnDecl name) where
markAST _ (GHC.HsAnnotation src prov e) = do
markWithString GHC.AnnOpen src
case prov of
(GHC.ValueAnnProvenance n) -> markLocated n
(GHC.TypeAnnProvenance n) -> do
mark GHC.AnnType
markLocated n
GHC.ModuleAnnProvenance -> mark GHC.AnnModule
markLocated e
markWithString GHC.AnnClose "#-}"
markTrailingSemi
instance Annotate name => Annotate (GHC.WarnDecls name) where
markAST _ (GHC.Warnings src warns) = do
markWithString GHC.AnnOpen src
mapM_ markLocated warns
markWithString GHC.AnnClose "#-}"
instance (Annotate name)
=> Annotate (GHC.WarnDecl name) where
markAST _ (GHC.Warning lns txt) = do
markListIntercalate lns
mark GHC.AnnOpenS
case txt of
GHC.WarningTxt _src ls -> markListIntercalate ls
GHC.DeprecatedTxt _src ls -> markListIntercalate ls
mark GHC.AnnCloseS
instance Annotate GHC.FastString where
markAST l fs = do
markExternal l GHC.AnnVal (show (GHC.unpackFS fs))
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.ForeignDecl name) where
markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _
(GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do
mark GHC.AnnForeign
mark GHC.AnnImport
markLocated cconv
unless (ll == GHC.noSrcSpan) $ markLocated safety
if GHC.unLoc cconv == GHC.PrimCallConv
then markExternal ls GHC.AnnVal src
#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1))
else markExternal ls GHC.AnnVal src
#else
else markExternal ls GHC.AnnVal (show src)
#endif
markLocated ln
mark GHC.AnnDcolon
markLocated typ
markTrailingSemi
markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ) _ (GHC.CExport spec (GHC.L ls src))) = do
mark GHC.AnnForeign
mark GHC.AnnExport
markLocated spec
markExternal ls GHC.AnnVal (show src)
setContext (Set.singleton PrefixOp) $ markLocated ln
mark GHC.AnnDcolon
markLocated typ
instance (Annotate GHC.CExportSpec) where
markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv
instance (Annotate GHC.CCallConv) where
markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall"
markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall"
markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi"
markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim"
markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript"
instance (Annotate GHC.Safety) where
markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe"
markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe"
markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible"
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.DerivDecl name) where
markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do
mark GHC.AnnDeriving
mark GHC.AnnInstance
markMaybe mov
markLocated typ
markTrailingSemi
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.DefaultDecl name) where
markAST _ (GHC.DefaultDecl typs) = do
mark GHC.AnnDefault
mark GHC.AnnOpenP
markListIntercalate typs
mark GHC.AnnCloseP
markTrailingSemi
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.InstDecl name) where
markAST l (GHC.ClsInstD cid) = markAST l cid
markAST l (GHC.DataFamInstD dfid) = markAST l dfid
markAST l (GHC.TyFamInstD tfid) = markAST l tfid
instance Annotate GHC.OverlapMode where
markAST _ (GHC.NoOverlap src) = do
markWithString GHC.AnnOpen src
markWithString GHC.AnnClose "#-}"
markAST _ (GHC.Overlappable src) = do
markWithString GHC.AnnOpen src
markWithString GHC.AnnClose "#-}"
markAST _ (GHC.Overlapping src) = do
markWithString GHC.AnnOpen src
markWithString GHC.AnnClose "#-}"
markAST _ (GHC.Overlaps src) = do
markWithString GHC.AnnOpen src
markWithString GHC.AnnClose "#-}"
markAST _ (GHC.Incoherent src) = do
markWithString GHC.AnnOpen src
markWithString GHC.AnnClose "#-}"
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.ClsInstDecl name) where
markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do
mark GHC.AnnInstance
markMaybe mov
markLocated poly
if null (GHC.bagToList binds) && null sigs && null tyfams && null datafams
then markOptional GHC.AnnWhere
else do
mark GHC.AnnWhere
markOptional GHC.AnnOpenC
markInside GHC.AnnSemi
applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds)
++ prepareListAnnotation sigs
++ prepareListAnnotation tyfams
++ prepareListAnnotation datafams
)
markOptional GHC.AnnCloseC
markTrailingSemi
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.TyFamInstDecl name) where
markAST _ (GHC.TyFamInstDecl eqn _) = do
mark GHC.AnnType
inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance
markLocated eqn
markTrailingSemi
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.DataFamInstDecl name) where
markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats)
defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do
case GHC.dd_ND defn of
GHC.NewType -> mark GHC.AnnNewtype
GHC.DataType -> mark GHC.AnnData
inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance
markLocated ctx
markTyClass ln pats
case (GHC.dd_kindSig defn) of
Just s -> do
mark GHC.AnnDcolon
markLocated s
Nothing -> return ()
if isGadt $ GHC.dd_cons defn
then mark GHC.AnnWhere
else mark GHC.AnnEqual
markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs)
markTrailingSemi
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsBind name) where
markAST _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do
let
tlFun =
ifInContext (Set.fromList [CtxOnly,CtxFirst])
(markListWithContexts' listContexts matches)
(markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches)
ifInContext (Set.singleton TopLevel)
(setContextLevel (Set.singleton TopLevel) 2 tlFun)
tlFun
markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do
markLocated lhs
case grhs of
(GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual
_ -> return ()
markListIntercalateWithFunLevel markLocated 2 grhs
case lb of
GHC.EmptyLocalBinds -> return ()
_ -> do
mark GHC.AnnWhere
markOptional GHC.AnnOpenC
markInside GHC.AnnSemi
markLocalBindsWithLayout lb
markOptional GHC.AnnCloseC
markTrailingSemi
markAST _ (GHC.VarBind _n rhse _) =
markLocated rhse
markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do
mark GHC.AnnPattern
case args of
GHC.InfixPatSyn la lb -> do
markLocated la
setContext (Set.singleton InfixOp) $ markLocated ln
markLocated lb
GHC.PrefixPatSyn ns -> do
markLocated ln
mapM_ markLocated ns
GHC.RecordPatSyn fs -> do
markLocated ln
mark GHC.AnnOpenC
markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs
mark GHC.AnnCloseC
case dir of
GHC.ImplicitBidirectional -> mark GHC.AnnEqual
_ -> mark GHC.AnnLarrow
markLocated def
case dir of
GHC.Unidirectional -> return ()
GHC.ImplicitBidirectional -> return ()
GHC.ExplicitBidirectional mg -> do
mark GHC.AnnWhere
mark GHC.AnnOpenC
markMatchGroup l mg
mark GHC.AnnCloseC
markTrailingSemi
markAST _ (GHC.AbsBinds _ _ _ _ _) =
traceM "warning: AbsBinds introduced after renaming"
markAST _ GHC.AbsBindsSig{} =
traceM "warning: AbsBindsSig introduced after renaming"
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.IPBind name) where
markAST _ (GHC.IPBind en e) = do
case en of
Left n -> markLocated n
Right _i -> return ()
mark GHC.AnnEqual
markLocated e
markTrailingSemi
instance Annotate GHC.HsIPName where
markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n)
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,
Annotate body)
=> Annotate (GHC.Match name (GHC.Located body)) where
markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do
let
get_infix GHC.NonFunBindMatch = False
get_infix (GHC.FunBindMatch _ f) = f
isFunBind GHC.NonFunBindMatch = False
isFunBind GHC.FunBindMatch{} = True
case (get_infix mln,pats) of
(True, a:b:xs) -> do
if null xs
then markOptional GHC.AnnOpenP
else mark GHC.AnnOpenP
markLocated a
case mln of
GHC.NonFunBindMatch -> return ()
GHC.FunBindMatch n _ -> setContext (Set.singleton InfixOp) $ markLocated n
markLocated b
if null xs
then markOptional GHC.AnnCloseP
else mark GHC.AnnCloseP
mapM_ markLocated xs
_ -> do
annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]
inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam
case mln of
GHC.NonFunBindMatch -> markListNoPrecedingSpace False pats
GHC.FunBindMatch n _ -> do
setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n
mapM_ markLocated pats
case grhs of
(GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual
_ -> return ()
inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow
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
inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow
setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.Sig name) where
markAST _ (GHC.TypeSig lns st) = do
setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns
mark GHC.AnnDcolon
markLHsSigWcType st
markTrailingSemi
tellContext (Set.singleton FollowingLine)
markAST _ (GHC.PatSynSig ln (GHC.HsIB _ typ)) = do
mark GHC.AnnPattern
markLocated ln
mark GHC.AnnDcolon
markLocated typ
markTrailingSemi
markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ)) = do
when isDefault $ mark GHC.AnnDefault
setContext (Set.singleton PrefixOp) $ markListIntercalate ns
mark GHC.AnnDcolon
markLocated typ
markTrailingSemi
markAST _ (GHC.IdSig _) =
traceM "warning: Introduced after renaming"
markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src _v fdir))) = do
let fixstr = case fdir of
GHC.InfixL -> "infixl"
GHC.InfixR -> "infixr"
GHC.InfixN -> "infix"
markWithString GHC.AnnInfix fixstr
markWithString GHC.AnnVal src
setContext (Set.singleton InfixOp) $ markListIntercalate lns
markTrailingSemi
markAST _ (GHC.InlineSig ln inl) = do
markWithString GHC.AnnOpen (GHC.inl_src inl)
markActivation (GHC.inl_act inl)
setContext (Set.singleton PrefixOp) $ markLocated ln
markWithString GHC.AnnClose "#-}"
markTrailingSemi
markAST _ (GHC.SpecSig ln typs inl) = do
markWithString GHC.AnnOpen (GHC.inl_src inl)
markActivation (GHC.inl_act inl)
markLocated ln
mark GHC.AnnDcolon
markListIntercalateWithFunLevel markLHsSigType 2 typs
markWithString GHC.AnnClose "#-}"
markTrailingSemi
markAST _ (GHC.SpecInstSig src typ) = do
markWithString GHC.AnnOpen src
mark GHC.AnnInstance
markLHsSigType typ
markWithString GHC.AnnClose "#-}"
markTrailingSemi
markAST _l (GHC.MinimalSig src formula) = do
markWithString GHC.AnnOpen src
markLocated formula
markWithString GHC.AnnClose "#-}"
markTrailingSemi
markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.LHsSigType name -> Annotated ()
markLHsSigType (GHC.HsIB _ typ) = markLocated typ
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate [GHC.LHsSigType name] where
markAST _ ls = do
mark GHC.AnnDeriving
case ls of
[] -> markManyOptional GHC.AnnOpenP
[GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnOpenP
[_] -> markManyOptional GHC.AnnOpenP
_ -> markMany GHC.AnnOpenP
markListIntercalateWithFun markLHsSigType ls
case ls of
[] -> markManyOptional GHC.AnnCloseP
[GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnCloseP
[_] -> markManyOptional GHC.AnnCloseP
_ -> markMany GHC.AnnCloseP
instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where
markAST _ (GHC.Var x) = do
setContext (Set.singleton PrefixOp) $ markLocated x
inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls
markAST _ (GHC.And ls) = do
markListIntercalateWithFunLevel markLocated 2 ls
inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
markAST _ (GHC.Parens x) = do
mark GHC.AnnOpenP
markLocated x
mark GHC.AnnCloseP
inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsTyVarBndr name) where
markAST _l (GHC.UserTyVar n) = do
markLocated n
markAST _ (GHC.KindedTyVar n ty) = do
mark GHC.AnnOpenP
markLocated n
mark GHC.AnnDcolon
markLocated ty
mark GHC.AnnCloseP
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsType name) where
markAST loc ty = do
markType loc ty
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
where
markType _ (GHC.HsForAllTy tvs typ) = do
mark GHC.AnnForall
mapM_ markLocated tvs
mark GHC.AnnDot
markLocated typ
markType _ (GHC.HsQualTy cxt typ) = do
markLocated cxt
markLocated typ
markType _l (GHC.HsTyVar name) = do
if ((GHC.isDataOcc $ GHC.occName $ GHC.unLoc name) && ((not $ isExactName $ GHC.unLoc name)))
|| (showGhc name == "()")
then do
mark GHC.AnnSimpleQuote
markLocatedFromKw GHC.AnnName name
else markLocated name
markType _ (GHC.HsAppsTy ts) = do
mapM_ markLocated ts
markType _ (GHC.HsAppTy t1 t2) = do
setContext (Set.singleton PrefixOp) $ markLocated t1
markLocated t2
markType _ (GHC.HsFunTy t1 t2) = do
markLocated t1
mark GHC.AnnRarrow
markLocated t2
markType _ (GHC.HsListTy t) = do
mark GHC.AnnOpenS
markLocated t
mark GHC.AnnCloseS
markType _ (GHC.HsPArrTy t) = do
markWithString GHC.AnnOpen "[:"
markLocated t
markWithString GHC.AnnClose ":]"
markType _ (GHC.HsTupleTy tt ts) = do
case tt of
GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP
_ -> markWithString GHC.AnnOpen "(#"
markListIntercalateWithFunLevel markLocated 2 ts
case tt of
GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP
_ -> markWithString GHC.AnnClose "#)"
markType _ (GHC.HsOpTy t1 lo t2) = do
markLocated t1
if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo)
then do
markOptional GHC.AnnSimpleQuote
else do
mark GHC.AnnSimpleQuote
unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo
markLocated t2
markType _ (GHC.HsParTy t) = do
mark GHC.AnnOpenP
markLocated t
mark GHC.AnnCloseP
markType _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do
markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n))
mark GHC.AnnDcolon
markLocated t
markType _ (GHC.HsEqTy t1 t2) = do
markLocated t1
mark GHC.AnnTilde
markLocated t2
markType _ (GHC.HsKindSig t k) = do
mark GHC.AnnOpenP
markLocated t
mark GHC.AnnDcolon
markLocated k
mark GHC.AnnCloseP
markType l (GHC.HsSpliceTy s _) = do
markAST l s
markType _ (GHC.HsDocTy t ds) = do
markLocated t
markLocated ds
markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do
case mt of
Nothing -> return ()
Just src -> do
markWithString GHC.AnnOpen src
markWithString GHC.AnnClose "#-}"
case str of
GHC.SrcLazy -> mark GHC.AnnTilde
GHC.SrcStrict -> mark GHC.AnnBang
GHC.NoSrcStrict -> return ()
markLocated t
markType _ (GHC.HsRecTy cons) = do
mark GHC.AnnOpenC
markListIntercalate cons
mark GHC.AnnCloseC
markType _ (GHC.HsCoreTy _t) =
traceM "warning: HsCoreTy Introduced after renaming"
markType _ (GHC.HsExplicitListTy _ 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
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
markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do
markExternal l GHC.AnnVal "_"
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsAppType name) where
markAST _ (GHC.HsAppInfix n) = do
when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote
setContext (Set.singleton InfixOp) $ markLocated n
markAST _ (GHC.HsAppPrefix t) = do
markOptional GHC.AnnTilde
setContext (Set.singleton PrefixOp) $ markLocated t
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsSplice name) where
markAST l c =
case c of
GHC.HsQuasiQuote _ n _pos fs -> do
markExternal l GHC.AnnVal
("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")
GHC.HsTypedSplice _n (GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do
markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))
GHC.HsTypedSplice _n b -> do
mark GHC.AnnOpenPTE
markLocated b
mark GHC.AnnCloseP
GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do
ifInContext (Set.singleton InSpliceDecl)
(return ())
(mark GHC.AnnOpenPE)
markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))
markLocated b
ifInContext (Set.singleton InSpliceDecl)
(return ())
(mark GHC.AnnCloseP)
GHC.HsUntypedSplice _n b -> do
markOptional GHC.AnnThIdSplice
ifInContext (Set.singleton InSpliceDecl)
(return ())
(mark GHC.AnnOpenPE)
markLocated b
ifInContext (Set.singleton InSpliceDecl)
(return ())
(mark GHC.AnnCloseP)
#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1))
GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC"
#endif
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) =>
Annotate (GHC.ConDeclField name) where
markAST _ (GHC.ConDeclField ns ty mdoc) = do
unsetContext Intercalate $ do
markListIntercalate ns
mark GHC.AnnDcolon
markLocated ty
markMaybe mdoc
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (GHC.DataId name)
=> Annotate (GHC.FieldOcc name) where
markAST _ (GHC.FieldOcc rn _) = do
markLocated rn
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance Annotate GHC.HsDocString where
markAST l (GHC.HsDocString s) = do
markExternal l GHC.AnnVal (GHC.unpackFS s)
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.Pat name) where
markAST loc typ = do
markPat loc typ
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat")
where
markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_"
markPat l (GHC.VarPat n) = do
let pun_RDR = "pun-right-hand-side"
when (showGhc n /= pun_RDR) $
unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n)
markPat _ (GHC.LazyPat p) = do
mark GHC.AnnTilde
markLocated p
markPat _ (GHC.AsPat ln p) = do
markLocated ln
mark GHC.AnnAt
markLocated p
markPat _ (GHC.ParPat p) = do
mark GHC.AnnOpenP
markLocated p
mark GHC.AnnCloseP
markPat _ (GHC.BangPat p) = do
mark GHC.AnnBang
markLocated p
markPat _ (GHC.ListPat ps _ _) = do
mark GHC.AnnOpenS
markListIntercalateWithFunLevel markLocated 2 ps
mark GHC.AnnCloseS
markPat _ (GHC.TuplePat pats b _) = do
if b == GHC.Boxed then mark GHC.AnnOpenP
else markWithString GHC.AnnOpen "(#"
markListIntercalateWithFunLevel markLocated 2 pats
if b == GHC.Boxed then mark GHC.AnnCloseP
else markWithString GHC.AnnClose "#)"
markPat _ (GHC.PArrPat ps _) = do
markWithString GHC.AnnOpen "[:"
mapM_ markLocated ps
markWithString GHC.AnnClose ":]"
markPat _ (GHC.ConPatIn n dets) = do
markHsConPatDetails n dets
markPat _ GHC.ConPatOut {} =
traceM "warning: ConPatOut Introduced after renaming"
markPat _ (GHC.ViewPat e pat _) = do
markLocated e
mark GHC.AnnRarrow
markLocated pat
markPat l (GHC.SplicePat s) = do
markAST l s
markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp)
markPat _ (GHC.NPat ol mn _ _) = do
when (isJust mn) $ mark GHC.AnnMinus
markLocated ol
markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do
markLocated ln
markWithString GHC.AnnVal "+"
markLocated ol
markPat _ (GHC.SigPatIn pat ty) = do
markLocated pat
mark GHC.AnnDcolon
markLHsSigWcType ty
markPat _ GHC.SigPatOut {} =
traceM "warning: SigPatOut introduced after renaming"
markPat _ GHC.CoPat {} =
traceM "warning: CoPat introduced after renaming"
hsLit2String :: GHC.HsLit -> GHC.SourceText
hsLit2String lit =
case lit of
GHC.HsChar src _ -> src
GHC.HsCharPrim src _ -> src ++ "#"
GHC.HsString src _ -> src
GHC.HsStringPrim src _ -> src
GHC.HsInt src _ -> src
GHC.HsIntPrim src _ -> src
GHC.HsWordPrim src _ -> src
GHC.HsInt64Prim src _ -> src
GHC.HsWord64Prim src _ -> src
GHC.HsInteger src _ _ -> src
GHC.HsRat (GHC.FL src _) _ -> src
GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#"
GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##"
markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.Located name -> GHC.HsConPatDetails name -> Annotated ()
markHsConPatDetails ln dets = do
case dets of
GHC.PrefixCon args -> do
setContext (Set.singleton PrefixOp) $ markLocated ln
mapM_ markLocated args
GHC.RecCon (GHC.HsRecFields fs dd) -> do
markLocated ln
mark GHC.AnnOpenC
case dd of
Nothing -> markListIntercalateWithFunLevel markLocated 2 fs
Just _ -> do
setContext (Set.singleton Intercalate) $ mapM_ markLocated fs
mark GHC.AnnDotdot
mark GHC.AnnCloseC
GHC.InfixCon a1 a2 -> do
markLocated a1
setContext (Set.singleton InfixOp) $ markLocated ln
markLocated a2
markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated ()
markHsConDeclDetails isDeprecated inGadt lns dets = do
case dets of
GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args
GHC.RecCon fs -> do
mark GHC.AnnOpenC
if inGadt
then do
if isDeprecated
then setContext (Set.fromList [InGadt]) $ markLocated fs
else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs
else do
if isDeprecated
then markLocated fs
else setContext (Set.fromList [InRecCon]) $ markLocated fs
GHC.InfixCon a1 a2 -> do
markLocated a1
setContext (Set.singleton InfixOp) $ mapM_ markLocated lns
markLocated a2
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate [GHC.LConDeclField name] where
markAST _ fs = do
markOptional GHC.AnnOpenC
markListIntercalate fs
markOptional GHC.AnnDotdot
inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC
inContext (Set.singleton InGadt) $ do
mark GHC.AnnRarrow
instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where
markAST l ol =
let str = case GHC.ol_val ol of
GHC.HsIntegral src _ -> src
GHC.HsFractional l2 -> GHC.fl_text l2
GHC.HsIsString src _ -> src
in
markExternal l GHC.AnnVal str
instance (GHC.DataId name,Annotate arg)
=> Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where
markAST _ (GHC.HsIB _ thing) = do
markLocated thing
instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name
,GHC.HasOccName name,Annotate body)
=> Annotate (GHC.Stmt name (GHC.Located body)) where
markAST _ (GHC.LastStmt body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body
markAST _ (GHC.BindStmt pat body _ _ _) = do
unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat
mark GHC.AnnLarrow
unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body
ifInContext (Set.singleton Intercalate)
(mark GHC.AnnComma)
(inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
markTrailingSemi
markAST _ GHC.ApplicativeStmt{}
= error "ApplicativeStmt should not appear in ParsedSource"
markAST _ (GHC.BodyStmt body _ _ _) = do
unsetContext Intercalate $ markLocated body
inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
markTrailingSemi
markAST _ (GHC.LetStmt (GHC.L _ lb)) = do
mark GHC.AnnLet
markOptional GHC.AnnOpenC
markInside GHC.AnnSemi
markLocalBindsWithLayout lb
markOptional GHC.AnnCloseC
ifInContext (Set.singleton Intercalate)
(mark GHC.AnnComma)
(inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar)
markTrailingSemi
markAST l (GHC.ParStmt pbs _ _ _) = do
ifInContext (Set.singleton Intercalate)
(
unsetContext Intercalate $
markListWithContextsFunction
(LC (Set.singleton Intercalate)
Set.empty
Set.empty
(Set.singleton Intercalate)
) (markAST l) pbs
)
(
unsetContext Intercalate $
markListWithContextsFunction
(LC Set.empty
(Set.fromList [AddVbar])
(Set.fromList [AddVbar])
Set.empty
) (markAST l) pbs
)
markTrailingSemi
markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do
setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts
case form of
GHC.ThenForm -> do
mark GHC.AnnThen
unsetContext Intercalate $ markLocated using
case by of
Just b -> do
mark GHC.AnnBy
unsetContext Intercalate $ markLocated b
Nothing -> return ()
GHC.GroupForm -> do
mark GHC.AnnThen
mark GHC.AnnGroup
case by of
Just b -> mark GHC.AnnBy >> markLocated b
Nothing -> return ()
mark GHC.AnnUsing
markLocated using
inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
markTrailingSemi
markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do
mark GHC.AnnRec
markOptional GHC.AnnOpenC
markInside GHC.AnnSemi
mapM_ markLocated stmts
markOptional GHC.AnnCloseC
inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
inContext (Set.singleton Intercalate) $ mark GHC.AnnComma
markTrailingSemi
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.ParStmtBlock name name) where
markAST _ (GHC.ParStmtBlock stmts _ns _) = do
markListIntercalate stmts
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsLocalBinds name) where
markAST _ lb = markHsLocalBinds lb
markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.HsLocalBinds name -> Annotated ()
markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =
applyListAnnotationsLayout
(prepareListAnnotation (GHC.bagToList binds)
++ prepareListAnnotation sigs
)
markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {})
= traceM "warning: ValBindsOut introduced after renaming"
markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds)
markHsLocalBinds GHC.EmptyLocalBinds = return ()
markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,
Annotate body)
=> GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body)
-> Annotated ()
markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _)
= setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,
Annotate body)
=> Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where
markAST _ ls = mapM_ markLocated ls
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsExpr name) where
markAST loc expr = do
markExpr loc expr
inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
where
markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do
ifInContext (Set.singleton PrefixOp)
(setContext (Set.singleton PrefixOp) $ markLocated n)
(ifInContext (Set.singleton InfixOp)
(setContext (Set.singleton InfixOp) $ markLocated n)
(markLocated n)
)
markExpr l (GHC.HsRecFld f) = markAST l f
markExpr l (GHC.HsOverLabel fs)
= markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs)
markExpr l (GHC.HsIPVar (GHC.HsIPName v)) =
markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v)
markExpr l (GHC.HsOverLit ov) = markAST l ov
markExpr l (GHC.HsLit lit) = markAST l lit
markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do
setContext (Set.singleton LambdaExpr) $ do
markLocated match
markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match"
markExpr l (GHC.HsLamCase _ match) = do
mark GHC.AnnLam
mark GHC.AnnCase
markOptional GHC.AnnOpenC
setContext (Set.singleton CaseAlt) $ do
markMatchGroup l match
markOptional GHC.AnnCloseC
markExpr _ (GHC.HsApp e1 e2) = do
setContext (Set.singleton PrefixOp) $ markLocated e1
setContext (Set.singleton PrefixOp) $ markLocated e2
markExpr _ (GHC.OpApp e1 e2 _ e3) = do
let
isInfix = case e2 of
GHC.L _ (GHC.HsVar _) -> True
_ -> False
normal =
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
markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do
mark GHC.AnnIf
markLocated e1
markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen
mark GHC.AnnThen
setContextLevel (Set.singleton ListStart) 2 $ markLocated e2
markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse
mark GHC.AnnElse
setContextLevel (Set.singleton ListStart) 2 $ markLocated e3
markExpr _ (GHC.HsMultiIf _ rhs) = do
mark GHC.AnnIf
markOptional GHC.AnnOpenC
setContext (Set.singleton CaseAlt) $ do
markListWithLayout rhs
markOptional GHC.AnnCloseC
markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do
setLayoutFlag (do
mark GHC.AnnLet
markOptional GHC.AnnOpenC
markInside GHC.AnnSemi
markLocalBindsWithLayout binds
markOptional GHC.AnnCloseC
mark GHC.AnnIn
markLocated e)
markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do
case cts of
GHC.DoExpr -> mark GHC.AnnDo
GHC.MDoExpr -> mark GHC.AnnMdo
_ -> return ()
let (ostr,cstr) =
if isListComp cts
then case cts of
GHC.PArrComp -> ("[:",":]")
_ -> ("[", "]")
else ("{","}")
when (isListComp cts) $ markWithString GHC.AnnOpen ostr
markOptional GHC.AnnOpenS
markOptional GHC.AnnOpenC
markInside GHC.AnnSemi
if isListComp cts
then do
markLocated (last es)
mark GHC.AnnVbar
setLayoutFlag (markListIntercalate (init es))
else do
markListWithLayout es
markOptional GHC.AnnCloseS
markOptional GHC.AnnCloseC
when (isListComp cts) $ markWithString GHC.AnnClose cstr
markExpr _ (GHC.ExplicitList _ _ es) = do
mark GHC.AnnOpenS
setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es
mark GHC.AnnCloseS
markExpr _ (GHC.ExplicitPArr _ es) = do
markWithString GHC.AnnOpen "[:"
markListIntercalate es
markWithString GHC.AnnClose ":]"
markExpr _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs dd)) = do
markLocated n
mark GHC.AnnOpenC
case dd of
Nothing -> markListIntercalate fs
Just _ -> do
setContext (Set.singleton Intercalate) $ mapM_ markLocated fs
mark GHC.AnnDotdot
mark GHC.AnnCloseC
markExpr _ (GHC.RecordUpd e fs _cons _ _ _) = do
markLocated e
mark GHC.AnnOpenC
markListIntercalate fs
mark GHC.AnnCloseC
markExpr _ (GHC.ExprWithTySig e typ) = do
setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e
mark GHC.AnnDcolon
markLHsSigWcType typ
markExpr _ (GHC.ExprWithTySigOut e typ) = do
markLocated e
mark GHC.AnnDcolon
markLHsSigWcType typ
markExpr _ (GHC.ArithSeq _ _ seqInfo) = do
mark GHC.AnnOpenS
case seqInfo of
GHC.From e -> do
markLocated e
mark GHC.AnnDotdot
GHC.FromTo e1 e2 -> do
markLocated e1
mark GHC.AnnDotdot
markLocated e2
GHC.FromThen e1 e2 -> do
markLocated e1
mark GHC.AnnComma
markLocated e2
mark GHC.AnnDotdot
GHC.FromThenTo e1 e2 e3 -> do
markLocated e1
mark GHC.AnnComma
markLocated e2
mark GHC.AnnDotdot
markLocated e3
mark GHC.AnnCloseS
markExpr _ (GHC.PArrSeq _ seqInfo) = do
markWithString GHC.AnnOpen "[:"
case seqInfo of
GHC.From e -> do
markLocated e
mark GHC.AnnDotdot
GHC.FromTo e1 e2 -> do
markLocated e1
mark GHC.AnnDotdot
markLocated e2
GHC.FromThen e1 e2 -> do
markLocated e1
mark GHC.AnnComma
markLocated e2
mark GHC.AnnDotdot
GHC.FromThenTo e1 e2 e3 -> do
markLocated e1
mark GHC.AnnComma
markLocated e2
mark GHC.AnnDotdot
markLocated e3
markWithString GHC.AnnClose ":]"
markExpr _ (GHC.HsSCC src csFStr e) = do
markWithString GHC.AnnOpen src
markWithStringOptional GHC.AnnVal (GHC.sl_st csFStr)
markWithString GHC.AnnValStr (GHC.sl_st csFStr)
markWithString GHC.AnnClose "#-}"
markLocated e
markExpr _ (GHC.HsCoreAnn src csFStr e) = do
markWithString GHC.AnnOpen src
markWithString GHC.AnnVal (GHC.sl_st csFStr)
markWithString GHC.AnnClose "#-}"
markLocated e
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 "|]"
markExpr _ (GHC.HsBracket (GHC.DecBrG _)) =
traceM "warning: DecBrG introduced after renamer"
markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do
markWithString GHC.AnnOpen "[|"
markOptional GHC.AnnOpenE
markLocated e
markWithString GHC.AnnClose "|]"
markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do
markWithString GHC.AnnOpen "[||"
markWithStringOptional GHC.AnnOpenE "[e||"
markLocated e
markWithString GHC.AnnClose "||]"
markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do
markWithString GHC.AnnOpen "[t|"
markLocated e
markWithString GHC.AnnClose "|]"
markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do
markWithString GHC.AnnOpen "[p|"
markLocated e
markWithString GHC.AnnClose "|]"
markExpr _ (GHC.HsRnBracketOut _ _) =
traceM "warning: HsRnBracketOut introduced after renamer"
markExpr _ (GHC.HsTcBracketOut _ _) =
traceM "warning: HsTcBracketOut introduced after renamer"
markExpr l (GHC.HsSpliceE e) = do
markOptional GHC.AnnOpenPE
markAST l e
markOptional GHC.AnnCloseP
markExpr _ (GHC.HsProc p c) = do
mark GHC.AnnProc
markLocated p
mark GHC.AnnRarrow
markLocated c
markExpr _ (GHC.HsStatic e) = do
mark GHC.AnnStatic
markLocated e
markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do
if isRightToLeft
then do
markLocated e1
case o of
GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail
GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail
else do
markLocated e2
case o of
GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail
GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail
if isRightToLeft
then markLocated e2
else markLocated e1
markExpr _ (GHC.HsArrForm e _ cs) = do
markWithString GHC.AnnOpen "(|"
markLocated e
mapM_ markLocated cs
markWithString GHC.AnnClose "|)"
markExpr _ (GHC.HsTick _ _) = return ()
markExpr _ (GHC.HsBinTick _ _ _) = return ()
markExpr _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do
markWithString GHC.AnnOpen src
markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str)
markOffsetWithString GHC.AnnVal 1 v1
markOffset GHC.AnnColon 0
markOffsetWithString GHC.AnnVal 2 v2
mark GHC.AnnMinus
markOffsetWithString GHC.AnnVal 3 v3
markOffset GHC.AnnColon 1
markOffsetWithString GHC.AnnVal 4 v4
markWithString GHC.AnnClose "#-}"
markLocated e
markExpr l GHC.EWildPat = do
markExternal l GHC.AnnVal "_"
markExpr _ (GHC.EAsPat ln e) = do
markLocated ln
mark GHC.AnnAt
markLocated e
markExpr _ (GHC.EViewPat e1 e2) = do
markLocated e1
mark GHC.AnnRarrow
markLocated e2
markExpr _ (GHC.ELazyPat e) = do
mark GHC.AnnTilde
markLocated e
markExpr _ (GHC.HsAppType e ty) = do
markLocated e
mark GHC.AnnAt
markLHsWcType ty
markExpr _ (GHC.HsAppTypeOut _ _) =
traceM "warning: HsAppTypeOut introduced after renaming"
markExpr _ (GHC.HsWrap _ _) =
traceM "warning: HsWrap introduced after renaming"
markExpr _ (GHC.HsUnboundVar _) =
traceM "warning: HsUnboundVar introduced after renaming"
markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.LHsWcType name -> Annotated ()
markLHsWcType (GHC.HsWC _ mwc ty) = do
case mwc of
Nothing -> markLocated ty
Just lwc -> do
applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")]
++ prepareListAnnotation [ty]
)
instance Annotate GHC.HsLit where
markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit)
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsRecUpdField name) where
markAST _ (GHC.HsRecField lbl expr punFlag) = do
unsetContext Intercalate $ markLocated lbl
when (punFlag == False) $ do
mark GHC.AnnEqual
unsetContext Intercalate $ markLocated expr
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (GHC.DataId name)
=> Annotate (GHC.AmbiguousFieldOcc name) where
markAST _ (GHC.Unambiguous n _) = markLocated n
markAST _ (GHC.Ambiguous n _) = markLocated n
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
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
let isPrefixOp = case cs of
[] -> True
(GHC.L h _:_) -> GHC.getLoc e < h
when isPrefixOp $ markWithString GHC.AnnOpen "(|"
applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp)
(Set.singleton InfixOp) (Set.singleton InfixOp))
(prepareListAnnotation [e]
++ prepareListAnnotation cs)
when isPrefixOp $ markWithString GHC.AnnClose "|)"
markAST _ (GHC.HsCmdApp e1 e2) = do
markLocated e1
markLocated e2
markAST l (GHC.HsCmdLam match) = do
setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match
markAST _ (GHC.HsCmdPar e) = do
mark GHC.AnnOpenP
markLocated e
mark GHC.AnnCloseP
markAST l (GHC.HsCmdCase e1 matches) = do
mark GHC.AnnCase
markLocated e1
mark GHC.AnnOf
markOptional GHC.AnnOpenC
setContext (Set.singleton CaseAlt) $ do
markMatchGroup l matches
markOptional GHC.AnnCloseC
markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do
mark GHC.AnnIf
markLocated e1
markOffset GHC.AnnSemi 0
mark GHC.AnnThen
markLocated e2
markOffset GHC.AnnSemi 1
mark GHC.AnnElse
markLocated e3
markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do
mark GHC.AnnLet
markOptional GHC.AnnOpenC
markLocalBindsWithLayout binds
markOptional GHC.AnnCloseC
mark GHC.AnnIn
markLocated e
markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do
mark GHC.AnnDo
markOptional GHC.AnnOpenC
markListWithLayout es
markOptional GHC.AnnCloseC
markAST _ (GHC.HsCmdWrap {}) =
traceM "warning: HsCmdWrap introduced after renaming"
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where
markAST _ ls = mapM_ markLocated ls
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.TyClDecl name) where
markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi
markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) typ _) = do
mark GHC.AnnType
markTyClass ln tyvars
mark GHC.AnnEqual
markLocated typ
markTrailingSemi
markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _)
(GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _ _) = do
if nd == GHC.DataType
then mark GHC.AnnData
else mark GHC.AnnNewtype
markMaybe mctyp
when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow
markLocated ctx
markTyClass ln tyVars
case mk of
Nothing -> return ()
Just k -> do
mark GHC.AnnDcolon
markLocated k
if isGadt cons
then mark GHC.AnnWhere
else unless (null cons) $ mark GHC.AnnEqual
markOptional GHC.AnnWhere
markOptional GHC.AnnOpenC
setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace)
$ markListWithContexts' listContexts cons
markOptional GHC.AnnCloseC
setContext (Set.fromList [Deriving,NoDarrow]) $ markMaybe mderivs
markTrailingSemi
markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds
sigs meths ats atdefs docs _) = do
mark GHC.AnnClass
markLocated ctx
markTyClass ln tyVars
unless (null fds) $ do
mark GHC.AnnVbar
markListIntercalateWithFunLevel markLocated 2 fds
mark GHC.AnnWhere
markOptional GHC.AnnOpenC
markInside GHC.AnnSemi
setContext (Set.singleton InClassDecl) $
applyListAnnotationsLayout
(prepareListAnnotation sigs
++ prepareListAnnotation (GHC.bagToList meths)
++ prepareListAnnotation ats
++ prepareListAnnotation atdefs
++ prepareListAnnotation docs
)
markOptional GHC.AnnCloseC
markTrailingSemi
markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a)
=> GHC.Located a -> [GHC.Located ast] -> Annotated ()
markTyClass ln tyVars = do
markManyOptional GHC.AnnOpenP
let
parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2
lnFun = do
ifInContext (Set.singleton CtxMiddle)
(setContext (Set.singleton InfixOp) $ markLocated ln)
(markLocated ln)
listFun b = do
if parensNeeded
then ifInContext (Set.singleton (CtxPos 0))
(markMany GHC.AnnOpenP)
(return ())
else ifInContext (Set.singleton (CtxPos 0))
(markManyOptional GHC.AnnOpenP)
(return ())
markLocated b
if parensNeeded
then ifInContext (Set.singleton (CtxPos 2))
(markMany GHC.AnnCloseP)
(return ())
else ifInContext (Set.singleton (CtxPos 2))
(markManyOptional GHC.AnnCloseP)
(return ())
prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls
unsetContext CtxMiddle $
applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp])
(Set.singleton CtxMiddle) (Set.singleton CtxLast))
([(GHC.getLoc ln,lnFun)]
++ prepareListFun tyVars)
markManyOptional GHC.AnnCloseP
instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.FamilyDecl name) where
markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) rsig minj) = do
case info of
GHC.DataFamily -> mark GHC.AnnData
_ -> mark GHC.AnnType
mark GHC.AnnFamily
markTyClass ln tyvars
case GHC.unLoc rsig of
GHC.NoSig -> return ()
GHC.KindSig _ -> do
mark GHC.AnnDcolon
markLocated rsig
GHC.TyVarSig _ -> do
mark GHC.AnnEqual
markLocated rsig
case minj of
Nothing -> return ()
Just inj -> do
mark GHC.AnnVbar
markLocated inj
case info of
GHC.ClosedTypeFamily (Just eqns) -> do
mark GHC.AnnWhere
markOptional GHC.AnnOpenC
markListWithLayout eqns
markOptional GHC.AnnCloseC
GHC.ClosedTypeFamily Nothing -> do
mark GHC.AnnWhere
mark GHC.AnnOpenC
mark GHC.AnnDotdot
mark GHC.AnnCloseC
_ -> return ()
markTrailingSemi
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.FamilyResultSig name) where
markAST _ (GHC.NoSig) = return ()
markAST _ (GHC.KindSig k) = markLocated k
markAST _ (GHC.TyVarSig ltv) = markLocated ltv
instance (GHC.DataId name,Annotate name)
=> Annotate (GHC.InjectivityAnn name) where
markAST _ (GHC.InjectivityAnn ln lns) = do
markLocated ln
mark GHC.AnnRarrow
mapM_ markLocated lns
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.TyFamInstEqn name) where
markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do
markTyClass ln pats
mark GHC.AnnEqual
markLocated typ
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.TyFamDefltEqn name) where
markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do
mark GHC.AnnType
mark GHC.AnnInstance
applyListAnnotations (prepareListAnnotation [ln]
++ prepareListAnnotation bndrs
)
mark GHC.AnnEqual
markLocated typ
instance Annotate GHC.DocDecl where
markAST l v =
let str =
case v of
(GHC.DocCommentNext (GHC.HsDocString fs)) -> GHC.unpackFS fs
(GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs
(GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs
(GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs
in
markExternal l GHC.AnnVal str >> markTrailingSemi
markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated ()
markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do
markLocated ctx
markMaybe typ
if isGadt cons
then markListWithLayout cons
else markListIntercalateWithFunLevel markLocated 2 cons
case mderivs of
Nothing -> return ()
Just d -> setContext (Set.singleton Deriving) $ markLocated d
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate [GHC.LHsType name] where
markAST l ts = do
let
parenIfNeeded' pa =
case ts of
[] -> if l == GHC.noSrcSpan
then markManyOptional pa
else markMany pa
[GHC.L _ GHC.HsForAllTy{}] -> markMany pa
[_] -> markManyOptional pa
_ -> markMany pa
parenIfNeeded'' pa =
ifInContext (Set.singleton Parens)
(markMany pa)
(parenIfNeeded' pa)
parenIfNeeded pa =
case ts of
[GHC.L _ GHC.HsParTy{}] -> markOptional pa
_ -> parenIfNeeded'' pa
parenIfNeeded GHC.AnnOpenP
unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts
parenIfNeeded GHC.AnnCloseP
ifInContext (Set.singleton NoDarrow)
(return ())
(if null ts && (l == GHC.noSrcSpan)
then markOptional GHC.AnnDarrow
else mark GHC.AnnDarrow)
instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.ConDecl name) where
markAST _ (GHC.ConDeclH98 ln mqtvs mctx
dets _ ) = do
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
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
data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable)
instance Annotate WildCardAnon where
markAST l WildCardAnon = do
markExternal l GHC.AnnVal "_"
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (ResTyGADTHook name) where
markAST _ (ResTyGADTHook bndrs) = do
unless (null bndrs) $ do
mark GHC.AnnForall
mapM_ markLocated bndrs
mark GHC.AnnDot
instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.HsRecField name (GHC.LPat name)) where
markAST _ (GHC.HsRecField n e punFlag) = do
unsetContext Intercalate $ markLocated n
unless punFlag $ do
mark GHC.AnnEqual
unsetContext Intercalate $ markLocated e
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.HsRecField name (GHC.LHsExpr name)) where
markAST _ (GHC.HsRecField n e punFlag) = do
unsetContext Intercalate $ markLocated n
unless punFlag $ do
mark GHC.AnnEqual
unsetContext Intercalate $ markLocated e
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (GHC.DataId name,Annotate name)
=> Annotate (GHC.FunDep (GHC.Located name)) where
markAST _ (ls,rs) = do
mapM_ markLocated ls
mark GHC.AnnRarrow
mapM_ markLocated rs
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance Annotate GHC.CType where
markAST _ (GHC.CType src mh f) = do
markWithString GHC.AnnOpen src
case mh of
Nothing -> return ()
Just (GHC.Header srcH _h) ->
markWithString GHC.AnnHeader srcH
markWithString GHC.AnnVal (fst f)
markWithString GHC.AnnClose "#-}"