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
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
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
SetContextLevel :: Set.Set AstContext -> Int -> Annotated () -> next -> AnnotationF next
UnsetContext :: AstContext -> Annotated () -> next -> AnnotationF next
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 ())
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
withAST :: Data a => GHC.Located a -> Annotated () -> Annotated ()
withAST lss action = liftF (WithAST lss action ())
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
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)
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
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
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
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
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
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
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 "#-}"
#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
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@(GHC.L _ n)) -> do
#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)
#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
#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)
(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
canParen = isSym && rdrName2String n /= "$"
doNormalRdrName = do
let str' = case str of
"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
if spanLength l length str' > 6
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
"[]" -> 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
#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")
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 ()
#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
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
#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
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
#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
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
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
_ -> return ()
markListIntercalateWithFunLevel markLocated 2 grhs
unless (GHC.isEmptyLocalBinds lb) $ mark GHC.AnnWhere
markOptional GHC.AnnWhere
markLocalBindsWithLayout lb
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
#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
markAST _ (GHC.AbsBinds _ _ _ _ _) =
traceM "warning: AbsBinds introduced after renaming"
#if __GLASGOW_HASKELL__ > 710
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
#if __GLASGOW_HASKELL__ <= 710
case mln of
Nothing -> markListNoPrecedingSpace False pats
Just (n,_) -> do
setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n
mapM_ markLocated pats
#else
case mln of
GHC.NonFunBindMatch -> markListNoPrecedingSpace False pats
GHC.FunBindMatch n _ -> do
setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n
mapM_ markLocated pats
#endif
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
#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
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
setContext (Set.singleton PrefixOp) $ markListIntercalate ns
mark GHC.AnnDcolon
markLocated typ
markTrailingSemi
markAST _ (GHC.IdSig _) =
traceM "warning: Introduced after renaming"
#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
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
#if __GLASGOW_HASKELL__ <= 710
markAST _ (GHC.SpecSig ln typs inl) = do
#else
markAST _ (GHC.SpecSig ln typs inl) = do
#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
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
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
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
instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where
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 _ (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
#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
#else
markType _ (GHC.HsForAllTy tvs typ) = do
mark GHC.AnnForall
mapM_ markLocated tvs
mark GHC.AnnDot
markLocated typ
#endif
#if __GLASGOW_HASKELL__ > 710
markType _ (GHC.HsQualTy cxt typ) = do
markLocated cxt
markLocated typ
#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
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
#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
#endif
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
#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)
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
#else
markAST _ c =
case c of
GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do
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
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
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"
markPat _ (GHC.ViewPat e pat _) = do
markLocated e
mark GHC.AnnRarrow
markLocated pat
markPat l (GHC.SplicePat s) = do
#if __GLASGOW_HASKELL__ <= 710
mark GHC.AnnOpenPE
markAST l s
mark GHC.AnnCloseP
#else
markAST l s
#endif
markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp)
#if __GLASGOW_HASKELL__ <= 710
markPat _ (GHC.NPat ol mn _) = do
#else
markPat _ (GHC.NPat ol mn _ _) = do
#endif
when (isJust mn) $ mark GHC.AnnMinus
markLocated ol
#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"
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
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
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
#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
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
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
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
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
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
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
#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
#if __GLASGOW_HASKELL__ <= 710
markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"")
#else
markWithString GHC.AnnVal (GHC.sl_st csFStr)
#endif
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
#if __GLASGOW_HASKELL__ <= 710
workOutString _l GHC.AnnOpen
(\ss -> if spanLength ss == 2
then "[|"
else "[e|")
#else
markWithString GHC.AnnOpen "[|"
markOptional GHC.AnnOpenE
#endif
markLocated e
markWithString GHC.AnnClose "|]"
markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do
#if __GLASGOW_HASKELL__ <= 710
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
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
markWithString GHC.AnnOpen src
markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str))
markOffsetWithString GHC.AnnVal 1 (show v1)
markOffset GHC.AnnColon 0
markOffsetWithString GHC.AnnVal 2 (show v2)
mark GHC.AnnMinus
markOffsetWithString GHC.AnnVal 3 (show v3)
markOffset GHC.AnnColon 1
markOffsetWithString GHC.AnnVal 4 (show v4)
markWithString GHC.AnnClose "#-}"
markLocated e
#else
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
#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
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
instance (GHC.DataId name)
=> Annotate (GHC.AmbiguousFieldOcc name) where
markAST _ (GHC.Unambiguous n _) = markLocated n
markAST _ (GHC.Ambiguous n _) = markLocated n
#endif
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
#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"
#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
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
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
#endif
case info of
GHC.DataFamily -> mark GHC.AnnData
_ -> mark GHC.AnnType
#if __GLASGOW_HASKELL__ <= 710
mark GHC.AnnFamily
#else
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
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
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
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
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
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
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
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
data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable)
instance Annotate WildCardAnon where
markAST l WildCardAnon = do
markExternal l GHC.AnnVal "_"
#endif
instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (ResTyGADTHook name) where
markAST _ (ResTyGADTHook bndrs) = do
unless (null bndrs) $ do
mark GHC.AnnForall
mapM_ markLocated bndrs
mark GHC.AnnDot
instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.HsRecField name (GHC.LPat name)) where
markAST _ (GHC.HsRecField n e punFlag) = do
unsetContext Intercalate $ markLocated n
unless punFlag $ do
mark GHC.AnnEqual
unsetContext Intercalate $ markLocated e
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)
=> Annotate (GHC.HsRecField name (GHC.LHsExpr name)) where
markAST _ (GHC.HsRecField n e punFlag) = do
unsetContext Intercalate $ markLocated n
unless punFlag $ do
mark GHC.AnnEqual
unsetContext Intercalate $ markLocated e
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance (GHC.DataId name,Annotate name)
=> Annotate (GHC.FunDep (GHC.Located name)) where
markAST _ (ls,rs) = do
mapM_ markLocated ls
mark GHC.AnnRarrow
mapM_ markLocated rs
inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma
instance Annotate GHC.CType where
markAST _ (GHC.CType src mh f) = do
markWithString GHC.AnnOpen src
case mh of
Nothing -> return ()
#if __GLASGOW_HASKELL__ <= 710
Just (GHC.Header h) ->
markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"")
markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"")
#else
Just (GHC.Header srcH _h) ->
markWithString GHC.AnnHeader srcH
markWithString GHC.AnnVal (fst f)
#endif
markWithString GHC.AnnClose "#-}"