module Language.Haskell.GHC.ExactPrint
( annotateAST
, Anns
, exactPrintAnnotated
, exactPrintAnnotation
, exactPrint
, ExactP
) where
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils
import Control.Monad (when, liftM, ap)
import Control.Exception
import Data.Data
import Data.List
import qualified Bag as GHC
import qualified BasicTypes 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 SrcLoc as GHC
import qualified Data.Map as Map
data SrcSpanInfo = SrcSpanInfo
{ srcInfoSpan :: GHC.SrcSpan
, srcInfoPoints :: [GHC.SrcSpan]
}
deriving (Eq,Ord,Show,Typeable,Data)
class SrcInfo si where
toSrcInfo :: GHC.SrcLoc -> [GHC.SrcSpan] -> GHC.SrcLoc -> si
fromSrcInfo :: SrcSpanInfo -> si
getPointLoc :: si -> GHC.SrcLoc
fileName :: si -> String
startLine :: si -> Int
startColumn :: si -> Int
getPointLoc si = GHC.mkSrcLoc (GHC.mkFastString $ fileName si) (startLine si) (startColumn si)
instance SrcInfo GHC.SrcSpan where
toSrcInfo = error "toSrcInfo GHC.SrcSpan undefined"
fromSrcInfo = error "toSrcInfo GHC.SrcSpan undefined"
getPointLoc = GHC.srcSpanStart
fileName (GHC.RealSrcSpan s) = GHC.unpackFS $ GHC.srcSpanFile s
fileName _ = "bad file name for SrcSpan"
startLine = srcSpanStartLine
startColumn = srcSpanStartColumn
class Annotated a where
ann :: a -> GHC.SrcSpan
instance Annotated (GHC.Located a) where
ann (GHC.L l _) = l
newtype EP x = EP (Pos -> [(Int,DeltaPos)] -> [GHC.SrcSpan] -> [Comment] -> Extra -> Anns
-> (x, Pos, [(Int,DeltaPos)], [GHC.SrcSpan], [Comment], Extra, Anns, ShowS))
data Extra = E { eFunId :: (Bool,String)
, eFunIsInfix :: Bool
}
initExtra :: Extra
initExtra = E (False,"") False
instance Functor EP where
fmap = liftM
instance Applicative EP where
pure = return
(<*>) = ap
instance Monad EP where
return x = EP $ \l dp s cs st an -> (x, l, dp, s, cs, st, an, id)
EP m >>= k = EP $ \l0 ss0 dp0 c0 st0 an0 -> let
(a, l1, ss1, dp1, c1, st1, an1, s1) = m l0 ss0 dp0 c0 st0 an0
EP f = k a
(b, l2, ss2, dp2, c2, st2, an2, s2) = f l1 ss1 dp1 c1 st1 an1
in (b, l2, ss2, dp2, c2, st2, an2, s1 . s2)
runEP :: EP () -> GHC.SrcSpan -> [Comment] -> Anns -> String
runEP (EP f) ss cs ans = let (_,_,_,_,_,_,_,s) = f (1,1) [(0,DP (0,0))] [ss] cs initExtra ans in s ""
getPos :: EP Pos
getPos = EP (\l dp s cs st an -> (l,l,dp,s,cs,st,an,id))
setPos :: Pos -> EP ()
setPos l = EP (\_ dp s cs st an -> ((),l,dp,s,cs,st,an,id))
getOffset :: EP Int
getOffset = EP (\l dps s cs st an -> (fst $ ghead "getOffset" dps,l,dps,s,cs,st,an,id))
pushOffset :: DeltaPos -> EP ()
pushOffset dp@(DP (f,dc)) = EP (\l dps s cs st an ->
let
(co,_) = ghead "pushOffset" dps
co' = dc + co
in ((),l,(co',dp):dps,s,cs,st,an,id)
`debug` ("pushOffset:co'=" ++ show co')
)
popOffset :: EP ()
popOffset = EP (\l (_o:dp) s cs st an -> ((),l,dp,s,cs,st,an,id)
`debug` ("popOffset:co=" ++ show (fst _o))
)
pushSrcSpan :: GHC.SrcSpan -> EP ()
pushSrcSpan ss = EP (\l dp sss cs st an -> ((),l,dp,(ss:sss),cs,st,an,id))
popSrcSpan :: EP ()
popSrcSpan = EP (\l dp (_:sss) cs st an -> ((),l,dp,sss,cs,st,an,id))
getAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation)
getAnnotation a = EP (\l dp s cs st an -> (getAnnotationEP (anEP an) a
,l,dp,s,cs,st,an,id))
getAndRemoveAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation)
getAndRemoveAnnotation a = EP (\l dp s cs st (ane,anf) ->
let
(r,ane') = getAndRemoveAnnotationEP ane a
in
(r, l,dp,s,cs,st,(ane',anf),id))
getAnnFinal :: KeywordId -> EP [DeltaPos]
getAnnFinal kw = EP (\l dp (s:ss) cs st (ane,anf) ->
let
(r,anf') = case Map.lookup (s,kw) anf of
Nothing -> ([],anf)
Just ds -> ([d],f')
where
(d,f') = case reverse ds of
[h] -> (h,Map.delete (s,kw) anf)
(h:t) -> (h,Map.insert (s,kw) (reverse t) anf)
in (r ,l,dp,(s:ss),cs,st,(ane,anf'),id))
peekAnnFinal :: KeywordId -> EP [DeltaPos]
peekAnnFinal kw = EP (\l dp (s:ss) cs st (ane,anf) ->
let
r = case Map.lookup (s,kw) anf of
Nothing -> []
Just ds -> ds
in (r ,l,dp,(s:ss),cs,st,(ane,anf),id))
getFunId :: EP (Bool,String)
getFunId = EP (\l dp s cs st an -> (eFunId st,l,dp,s,cs,st,an,id))
setFunId :: (Bool,String) -> EP ()
setFunId st = EP (\l dp s cs e an -> ((),l,dp,s,cs,e { eFunId = st},an,id))
getFunIsInfix :: EP Bool
getFunIsInfix = EP (\l dp s cs e an -> (eFunIsInfix e,l,dp,s,cs,e,an,id))
setFunIsInfix :: Bool -> EP ()
setFunIsInfix b = EP (\l dp s cs e an -> ((),l,dp,s,cs,e { eFunIsInfix = b},an,id))
printString :: String -> EP ()
printString str = EP (\(l,c) dp s cs st an ->
((), (l,c+length str), dp, s, cs, st, an, showString str))
getComment :: EP (Maybe Comment)
getComment = EP $ \l dp s cs st an ->
let x = case cs of
c:_ -> Just c
_ -> Nothing
in (x, l, dp, s, cs, st, an, id)
dropComment :: EP ()
dropComment = EP $ \l dp s cs st an ->
let cs' = case cs of
(_:csl) -> csl
_ -> cs
in ((), l, dp, s, cs', st, an, id)
mergeComments :: [DComment] -> EP ()
mergeComments dcs = EP $ \l dps s cs st an ->
let ll = ss2pos $ head s
(co,_) = ghead "mergeComments" dps
acs = map (undeltaComment ll co) dcs
cs' = merge acs cs
in ((), l, dps, s, cs', st, an, id) `debug` ("mergeComments:(l,acs,dcs)=" ++ show (l,acs,dcs))
newLine :: EP ()
newLine = do
(l,_) <- getPos
printString "\n"
setPos (l+1,1)
padUntil :: Pos -> EP ()
padUntil (l,c) = do
(l1,c1) <- getPos
case () of
_ | l1 >= l && c1 <= c -> printString $ replicate (c c1) ' '
| l1 < l -> newLine >> padUntil (l,c)
| otherwise -> return ()
mPrintComments :: Pos -> EP ()
mPrintComments p = do
mc <- getComment
case mc of
Nothing -> return ()
Just (Comment multi (s,e) str) ->
(
when (s < p) $ do
dropComment
padUntil s
printComment multi str
setPos e
mPrintComments p
)
printComment :: Bool -> String -> EP ()
printComment b str
| b = printString str
| otherwise = printString str
printWhitespace :: Pos -> EP ()
printWhitespace (r,c) = do
let (dr,dc) = (0,0)
let p = (r + dr, c + dc)
mPrintComments p >> padUntil p
printStringAt :: Pos -> String -> EP ()
printStringAt p str = printWhitespace p >> printString str
printStringAtLsDelta :: [DeltaPos] -> String -> EP ()
printStringAtLsDelta mc s =
case reverse mc of
(cl:_) -> do
p <- getPos
colOffset <- getOffset
if isGoodDeltaWithOffset cl colOffset
then printStringAt (undelta p cl colOffset) s
else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (mc,s))
_ -> return ()
isGoodDeltaWithOffset :: DeltaPos -> Int -> Bool
isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset))
printStringAtMaybeAnn :: KeywordId -> String -> EP ()
printStringAtMaybeAnn an str = do
ma <- getAnnFinal an
printStringAtLsDelta ma str
`debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str))
printStringAtMaybeAnnAll :: KeywordId -> String -> EP ()
printStringAtMaybeAnnAll an str = go
where
go = do
ma <- getAnnFinal an
case ma of
[] -> return ()
[d] -> printStringAtLsDelta [d] str >> go
countAnns :: KeywordId -> EP Int
countAnns an = do
ma <- peekAnnFinal an
return (length ma)
exactPrint :: (ExactP ast) => GHC.Located ast -> [Comment] -> String
exactPrint ast@(GHC.L l _) cs = runEP (exactPC ast) l cs (Map.empty,Map.empty)
exactPrintAnnotated ::
GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> String
exactPrintAnnotated ast@(GHC.L l _) ghcAnns = runEP (loadInitialComments >> exactPC ast) l [] an
where
an = annotateLHsModule ast ghcAnns
exactPrintAnnotation :: ExactP ast =>
GHC.Located ast -> [Comment] -> Anns -> String
exactPrintAnnotation ast@(GHC.L l _) cs an = runEP (loadInitialComments >> exactPC ast) l cs an
annotateAST :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> Anns
annotateAST ast ghcAnns = annotateLHsModule ast ghcAnns
loadInitialComments :: EP ()
loadInitialComments = do
Just (Ann cs _) <- getAnnotation (GHC.L GHC.noSrcSpan ())
mergeComments cs
return ()
exactPC :: (Data ast,ExactP ast) => GHC.Located ast -> EP ()
exactPC a@(GHC.L l ast) =
do pushSrcSpan l `debug` ("exactPC entered for:" ++ showGhc l)
ma <- getAndRemoveAnnotation a
offset <- case ma of
Nothing -> return (DP (0,0))
`debug` ("exactPC:no annotation for " ++ show (ss2span l,typeOf ast))
Just (Ann lcs dp) -> do
mergeComments lcs `debug` ("exactPC:(l,lcs,dp):" ++ show (showGhc l,lcs,dp))
return dp
pushOffset offset
do
exactP ast
printStringAtMaybeAnn (G GHC.AnnComma) ","
printStringAtMaybeAnnAll AnnSemiSep ";"
popOffset
popSrcSpan
printMerged :: (ExactP a, ExactP b) => [GHC.Located a] -> [GHC.Located b] -> EP ()
printMerged [] [] = return ()
printMerged [] bs = mapM_ exactPC bs
printMerged as [] = mapM_ exactPC as
printMerged (a@(GHC.L l1 _):as) (b@(GHC.L l2 _):bs) =
if l1 < l2
then exactPC a >> printMerged as (b:bs)
else exactPC b >> printMerged (a:as) bs
prepareListPrint :: ExactP ast
=> [GHC.GenLocated GHC.SrcSpan ast] -> [(GHC.SrcSpan, EP ())]
prepareListPrint ls = map (\b@(GHC.L l _) -> (l,exactPC b)) ls
applyListPrint :: (Monad m, Ord a) => [(a, m b)] -> m ()
applyListPrint ls = mapM_ (\(_,b) -> b) $ sortBy (\(a,_) (b,_) -> compare a b) ls
class (Data ast) => ExactP ast where
exactP :: ast -> EP ()
instance ExactP (GHC.HsModule GHC.RdrName) where
exactP (GHC.HsModule mmn mexp imps decls mdepr _haddock) = do
case mmn of
Just (GHC.L _ mn) -> do
printStringAtMaybeAnn (G GHC.AnnModule) "module"
printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn)
Nothing -> return ()
case mdepr of
Nothing -> return ()
Just depr -> exactPC depr
case mexp of
Just lexps -> do
return () `debug` ("about to exactPC lexps")
exactPC lexps
return ()
Nothing -> return ()
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
exactP imps
mapM_ exactPC decls
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
printStringAtMaybeAnn (G GHC.AnnEofPos) ""
instance ExactP GHC.WarningTxt where
exactP (GHC.WarningTxt (GHC.L _ ls) lss) = do
printStringAtMaybeAnn (G GHC.AnnOpen) ls
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
mapM_ exactPC lss
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.DeprecatedTxt (GHC.L _ ls) lss) = do
printStringAtMaybeAnn (G GHC.AnnOpen) ls
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
mapM_ exactPC lss
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
instance ExactP (GHC.ModuleName) where
exactP mn = do
printString (GHC.moduleNameString mn)
instance ExactP [GHC.LIE GHC.RdrName] where
exactP ies = do
printStringAtMaybeAnn (G GHC.AnnHiding) "hiding"
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
mapM_ exactPC ies
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
instance ExactP (GHC.IE GHC.RdrName) where
exactP (GHC.IEVar ln) = do
printStringAtMaybeAnn (G GHC.AnnPattern) "pattern"
printStringAtMaybeAnn (G GHC.AnnType) "type"
exactPC ln
exactP (GHC.IEThingAbs n) = do
printStringAtMaybeAnn (G GHC.AnnType) "type"
exactPC n
exactP (GHC.IEThingWith n ns) = do
exactPC n
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
mapM_ exactPC ns
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.IEThingAll n) = do
exactPC n
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.IEModuleContents (GHC.L _ mn)) = do
printStringAtMaybeAnn (G GHC.AnnModule) "module"
printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn)
exactP x = printString ("no exactP.IE for " ++ showGhc (x))
instance ExactP [GHC.LImportDecl GHC.RdrName] where
exactP imps = mapM_ exactPC imps
instance ExactP (GHC.ImportDecl GHC.RdrName) where
exactP imp = do
printStringAtMaybeAnn (G GHC.AnnImport) "import"
printStringAtMaybeAnn (G GHC.AnnOpen) "{-# SOURCE"
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
printStringAtMaybeAnn (G GHC.AnnSafe) "safe"
printStringAtMaybeAnn (G GHC.AnnQualified) "qualified"
printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString $ GHC.unLoc $ GHC.ideclName imp)
case GHC.ideclAs imp of
Nothing -> return ()
Just mn -> do
printStringAtMaybeAnn (G GHC.AnnAs) "as"
printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn)
case GHC.ideclHiding imp of
Nothing -> return ()
Just (_,lie) -> do
exactPC lie
doMaybe :: (Monad m) => (a -> m ()) -> Maybe a -> m ()
doMaybe f ma = case ma of
Nothing -> return ()
Just a -> f a
instance ExactP (GHC.HsDecl GHC.RdrName) where
exactP decl = case decl of
GHC.TyClD d -> exactP d
GHC.InstD d -> exactP d
GHC.DerivD d -> exactP d
GHC.ValD d -> exactP d
GHC.SigD d -> exactP d
GHC.DefD d -> exactP d
GHC.ForD d -> exactP d
GHC.WarningD d -> exactP d
GHC.AnnD d -> exactP d
GHC.RuleD d -> exactP d
GHC.VectD d -> exactP d
GHC.SpliceD d -> exactP d
GHC.DocD d -> exactP d
GHC.QuasiQuoteD d -> exactP d
GHC.RoleAnnotD d -> exactP d
instance ExactP (GHC.RoleAnnotDecl GHC.RdrName) where
exactP (GHC.RoleAnnotDecl ln mr) = do
printStringAtMaybeAnn (G GHC.AnnType) "type"
printStringAtMaybeAnn (G GHC.AnnRole) "role"
exactPC ln
mapM_ exactPC mr
instance ExactP (Maybe GHC.Role) where
exactP Nothing = printStringAtMaybeAnn (G GHC.AnnVal) "_"
exactP (Just r) = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS $ GHC.fsFromRole r)
instance ExactP (GHC.HsQuasiQuote GHC.RdrName) where
exactP = assert False undefined
instance ExactP (GHC.SpliceDecl GHC.RdrName) where
exactP (GHC.SpliceDecl (GHC.L _ (GHC.HsSplice _n e)) flag) = do
case flag of
GHC.ExplicitSplice ->
printStringAtMaybeAnn (G GHC.AnnOpen) "$("
GHC.ImplicitSplice ->
printStringAtMaybeAnn (G GHC.AnnOpen) "$$("
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) ")"
instance ExactP (GHC.VectDecl GHC.RdrName) where
exactP (GHC.HsVect src ln e) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
exactPC ln
printStringAtMaybeAnn (G GHC.AnnEqual) "="
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.HsNoVect src ln) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
exactPC ln
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.HsVectTypeIn src _b ln mln) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnType) "type"
exactPC ln
printStringAtMaybeAnn (G GHC.AnnEqual) "="
case mln of
Nothing -> return ()
Just n -> exactPC n
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.HsVectTypeOut {}) = error $ "exactP.HsVectTypeOut: only valid after type checker"
exactP (GHC.HsVectClassIn src ln) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnClass) "class"
exactPC ln
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.HsVectClassOut {}) = error $ "exactP.HsVectClassOut: only valid after type checker"
exactP (GHC.HsVectInstIn {}) = error $ "exactP.HsVectInstIn: not supported?"
exactP (GHC.HsVectInstOut {}) = error $ "exactP.HsVectInstOut: not supported?"
instance ExactP (GHC.RuleDecls GHC.RdrName) where
exactP (GHC.HsRules src rules) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
mapM_ exactPC rules
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
instance ExactP (GHC.AnnDecl GHC.RdrName) where
exactP (GHC.HsAnnotation src prov e) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnType) "type"
printStringAtMaybeAnn (G GHC.AnnModule) "module"
case prov of
(GHC.ValueAnnProvenance n) -> exactPC n
(GHC.TypeAnnProvenance n) -> exactPC n
(GHC.ModuleAnnProvenance) -> return ()
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
instance ExactP (GHC.RuleDecl GHC.RdrName) where
exactP (GHC.HsRule ln act bndrs lhs _ rhs _) = do
exactPC ln
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
printStringAtMaybeAnn (G GHC.AnnTilde) "~"
case act of
GHC.ActiveBefore n -> printStringAtMaybeAnn (G GHC.AnnVal) (show n)
GHC.ActiveAfter n -> printStringAtMaybeAnn (G GHC.AnnVal) (show n)
_ -> return ()
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
printStringAtMaybeAnn (G GHC.AnnForall) "forall"
mapM_ exactPC bndrs
printStringAtMaybeAnn (G GHC.AnnDot) "."
exactPC lhs
printStringAtMaybeAnn (G GHC.AnnEqual) "="
exactPC rhs
instance ExactP (GHC.RuleBndr GHC.RdrName) where
exactP (GHC.RuleBndr ln) = exactPC ln
exactP (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
exactPC ln
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC thing
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
instance ExactP (GHC.WarnDecls GHC.RdrName) where
exactP (GHC.Warnings src warns) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
mapM_ exactPC warns
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
instance ExactP (GHC.WarnDecl GHC.RdrName) where
exactP (GHC.Warning lns txt) = do
mapM_ exactPC lns
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
case txt of
GHC.WarningTxt src ls -> mapM_ exactPC ls
GHC.DeprecatedTxt src ls -> mapM_ exactPC ls
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
instance ExactP GHC.FastString where
exactP fs = printStringAtMaybeAnn (G GHC.AnnVal) (show (GHC.unpackFS fs))
instance ExactP (GHC.ForeignDecl GHC.RdrName) where
exactP (GHC.ForeignImport ln typ _
(GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L _ src))) = do
printStringAtMaybeAnn (G GHC.AnnForeign) "foreign"
printStringAtMaybeAnn (G GHC.AnnImport) "import"
exactPC cconv
if ll == GHC.noSrcSpan
then return ()
else exactPC safety
printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ src ++ "\"")
exactPC ln
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC typ
exactP (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L _ src))) = do
printStringAtMaybeAnn (G GHC.AnnForeign) "foreign"
printStringAtMaybeAnn (G GHC.AnnExport) "export"
exactPC spec
printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ src ++ "\"")
exactPC ln
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC typ
instance (ExactP GHC.CExportSpec) where
exactP (GHC.CExportStatic _ cconv) = exactP cconv
instance ExactP GHC.CCallConv where
exactP GHC.StdCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "stdcall"
exactP GHC.CCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "ccall"
exactP GHC.CApiConv = printStringAtMaybeAnn (G GHC.AnnVal) "capi"
exactP GHC.PrimCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "prim"
exactP GHC.JavaScriptCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "javascript"
instance ExactP GHC.Safety where
exactP GHC.PlayRisky = printStringAtMaybeAnn (G GHC.AnnVal) "unsafe"
exactP GHC.PlaySafe = printStringAtMaybeAnn (G GHC.AnnVal) "safe"
exactP GHC.PlayInterruptible = printStringAtMaybeAnn (G GHC.AnnVal) "interruptible"
instance ExactP (GHC.DerivDecl GHC.RdrName) where
exactP (GHC.DerivDecl typ mov) = do
printStringAtMaybeAnn (G GHC.AnnDeriving) "deriving"
printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
case mov of
Nothing -> return ()
Just ov -> exactPC ov
exactPC typ
instance ExactP (GHC.DefaultDecl GHC.RdrName) where
exactP (GHC.DefaultDecl typs) = do
printStringAtMaybeAnn (G GHC.AnnDefault) "default"
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
mapM_ exactPC typs
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
instance ExactP (GHC.InstDecl GHC.RdrName) where
exactP (GHC.ClsInstD cid) = exactP cid
exactP (GHC.DataFamInstD dfid) = exactP dfid
exactP (GHC.TyFamInstD tfid) = exactP tfid
instance ExactP GHC.OverlapMode where
exactP (GHC.NoOverlap src) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.Overlappable src) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.Overlapping src) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.Overlaps src) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.Incoherent src) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
instance ExactP (GHC.ClsInstDecl GHC.RdrName) where
exactP (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do
printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
case mov of
Nothing -> return ()
Just ov -> exactPC ov
exactPC poly
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
applyListPrint (prepareListPrint (GHC.bagToList binds)
++ prepareListPrint sigs
++ prepareListPrint tyfams
++ prepareListPrint datafams
)
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
instance ExactP (GHC.TyFamInstDecl GHC.RdrName) where
exactP (GHC.TyFamInstDecl eqn _) = do
printStringAtMaybeAnn (G GHC.AnnType) "type"
printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
exactPC eqn
instance ExactP (GHC.DataFamInstDecl GHC.RdrName) where
exactP (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _)
(GHC.HsDataDefn _nOrD _ctx _mtyp mkind cons mderivs) _) = do
printStringAtMaybeAnn (G GHC.AnnData) "data"
printStringAtMaybeAnn (G GHC.AnnNewtype) "newtype"
printStringAtMaybeAnn (G GHC.AnnInstance) "instance"
exactPC ln
mapM_ exactPC pats
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
doMaybe exactPC mkind
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
printStringAtMaybeAnn (G GHC.AnnEqual) "="
mapM_ exactPC cons
doMaybe exactPC mderivs
instance ExactP (GHC.HsBind GHC.RdrName) where
exactP (GHC.FunBind (GHC.L _ n) isInfix (GHC.MG matches _ _ _) _ _ _) = do
setFunId (isSymbolRdrName n,rdrName2String n)
setFunIsInfix isInfix
mapM_ exactPC matches
exactP (GHC.PatBind lhs (GHC.GRHSs grhs lb) _ty _fvs _ticks) = do
exactPC lhs
printStringAtMaybeAnn (G GHC.AnnEqual) "="
mapM_ exactPC grhs
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
exactP lb
exactP (GHC.VarBind _var_id _var_rhs _var_inline ) = printString "VarBind"
exactP (GHC.AbsBinds _abs_tvs _abs_ev_vars _abs_exports _abs_ev_binds _abs_binds) = printString "AbsBinds"
exactP (GHC.PatSynBind (GHC.PSB n _fvs args def dir)) = do
printStringAtMaybeAnn (G GHC.AnnPattern) "pattern"
exactPC n
case args of
GHC.InfixPatSyn na nb -> do
exactPC na
exactPC nb
GHC.PrefixPatSyn ns -> do
mapM_ exactPC ns
printStringAtMaybeAnn (G GHC.AnnEqual) "="
printStringAtMaybeAnn (G GHC.AnnLarrow) "<-"
exactPC def
case dir of
GHC.Unidirectional -> return ()
GHC.ImplicitBidirectional -> return ()
GHC.ExplicitBidirectional mg -> exactPMatchGroup mg
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
instance ExactP (GHC.IPBind GHC.RdrName) where
exactP (GHC.IPBind en e) = do
case en of
Left n -> exactPC n
Right _i -> error $ "annotateP.IPBind:should not happen"
printStringAtMaybeAnn (G GHC.AnnEqual) "="
exactPC e
instance (ExactP body) => ExactP (GHC.Match GHC.RdrName (GHC.Located body)) where
exactP (GHC.Match mln pats typ (GHC.GRHSs grhs lb)) = do
(isSym,funid) <- getFunId
isInfix <- getFunIsInfix
let
get_infix Nothing = isInfix
get_infix (Just (_,f)) = f
case (get_infix mln,pats) of
(True,[a,b]) -> do
exactPC a
case mln of
Nothing -> do
if isSym
then printStringAtMaybeAnn (G GHC.AnnFunId) funid
else printStringAtMaybeAnn (G GHC.AnnFunId) ("`"++ funid ++ "`")
Just (n,_) -> exactPC n
exactPC b
_ -> do
case mln of
Nothing -> printStringAtMaybeAnn (G GHC.AnnFunId) funid
Just (n,_) -> exactPC n
mapM_ exactPC pats
printStringAtMaybeAnn (G GHC.AnnEqual) "="
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
mapM_ exactPC typ
mapM_ exactPC grhs
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
exactP lb
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
instance ExactP (GHC.Pat GHC.RdrName) where
exactP (GHC.WildPat _) = printStringAtMaybeAnn (G GHC.AnnVal) "_"
exactP (GHC.VarPat n) = printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n)
exactP (GHC.LazyPat p) = do
printStringAtMaybeAnn (G GHC.AnnTilde) "~"
exactPC p
exactP (GHC.AsPat n p) = do
exactPC n
printStringAtMaybeAnn (G GHC.AnnAt) "@"
exactPC p
exactP (GHC.ParPat p) = do
return () `debug` ("in exactP.ParPat")
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
exactPC p
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.BangPat p) = do
printStringAtMaybeAnn (G GHC.AnnBang) "!"
exactPC p
exactP (GHC.ListPat ps _ _) = do
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
mapM_ exactPC ps
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
exactP (GHC.TuplePat pats b _) = do
if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnOpenP) "("
else printStringAtMaybeAnn (G GHC.AnnOpen) "(#"
mapM_ exactPC pats
if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
else printStringAtMaybeAnn (G GHC.AnnClose) "#)"
exactP (GHC.PArrPat ps _) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
mapM_ exactPC ps
printStringAtMaybeAnn (G GHC.AnnClose) ":]"
exactP (GHC.ConPatIn n dets) = do
case dets of
GHC.PrefixCon args -> do
exactPC n
mapM_ exactPC args
GHC.RecCon (GHC.HsRecFields fs _) -> do
exactPC n
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
mapM_ exactPC fs
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
GHC.InfixCon a1 a2 -> do
exactPC a1
exactPC n
exactPC a2
exactP (GHC.ConPatOut {}) = return ()
exactP (GHC.ViewPat e pat _) = do
exactPC e
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
exactPC pat
exactP (GHC.SplicePat (GHC.HsSplice _ e)) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "$("
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) ")"
exactP (GHC.QuasiQuotePat (GHC.HsQuasiQuote n _ q)) = do
printStringAtMaybeAnn (G GHC.AnnVal)
("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS q) ++ "|]")
exactP (GHC.LitPat lp) = do
printStringAtMaybeAnn (G GHC.AnnVal) (hsLit2String lp)
exactP (GHC.NPat ol _ _) = do
printStringAtMaybeAnn (G GHC.AnnMinus) "-"
exactPC ol
exactP (GHC.NPlusKPat ln ol _ _) = do
exactPC ln
printStringAtMaybeAnn (G GHC.AnnVal) "+"
exactPC ol
exactP (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do
exactPC pat
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC ty
exactP (GHC.SigPatOut {}) = return ()
exactP (GHC.CoPat {}) = return ()
instance ExactP (GHC.HsType GHC.Name) where
exactP typ = do
return () `debug` ("exactP.HsType not implemented for " ++ showGhc (typ))
printString "HsType.Name"
assert False undefined
instance ExactP (GHC.HsType GHC.RdrName) where
exactP (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
printStringAtMaybeAnn (G GHC.AnnForall) "forall"
mapM_ exactPC tvs
printStringAtMaybeAnn (G GHC.AnnDot) "."
case mwc of
Nothing -> exactPC ctx
Just lwc -> exactPC (GHC.L lc (GHC.sortLocated ((GHC.L lwc GHC.HsWildcardTy):ctxs)))
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
exactPC typ
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.HsTyVar n) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactP n
exactP (GHC.HsAppTy t1 t2) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC t1
exactPC t2
exactP (GHC.HsFunTy t1 t2) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC t1
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
exactPC t2
exactP (GHC.HsListTy t) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
exactPC t
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
exactP (GHC.HsPArrTy t) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
exactPC t
printStringAtMaybeAnn (G GHC.AnnClose) ":]"
exactP (GHC.HsTupleTy _tsort ts) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
printStringAtMaybeAnn (G GHC.AnnOpen) "(#"
mapM_ exactPC ts
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
printStringAtMaybeAnn (G GHC.AnnClose) "#)"
exactP (GHC.HsOpTy t1 (_,op) t2) = do
exactPC t1
exactPC op
exactPC t2
exactP (GHC.HsParTy t1) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
exactPC t1
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.HsIParamTy (GHC.HsIPName n) t) = do
printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ (GHC.unpackFS n))
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC t
exactP (GHC.HsEqTy t1 t2) = do
exactPC t1
printStringAtMaybeAnn (G GHC.AnnTilde) "~"
exactPC t2
exactP (GHC.HsKindSig t k) = do
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
exactPC t
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC k
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote n _ss q)) = do
printStringAtMaybeAnn (G GHC.AnnVal)
("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS q) ++ "|]")
exactP (GHC.HsSpliceTy (GHC.HsSplice _is e) _) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "$("
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) ")"
exactP (GHC.HsDocTy t d) = do
exactPC t
exactPC d
exactP (GHC.HsBangTy b t) = do
case b of
(GHC.HsSrcBang ms (Just True) _) -> do
printStringAtMaybeAnn (G GHC.AnnOpen) (maybe "{-# UNPACK" id ms)
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
printStringAtMaybeAnn (G GHC.AnnBang) "!"
(GHC.HsSrcBang ms (Just False) _) -> do
printStringAtMaybeAnn (G GHC.AnnOpen) (maybe "{-# NOUNPACK" id ms)
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
printStringAtMaybeAnn (G GHC.AnnBang) "!"
_ -> do
printStringAtMaybeAnn (G GHC.AnnBang) "!"
exactPC t
exactP (GHC.HsRecTy cons) = do
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
mapM_ exactPC cons
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.HsCoreTy _t) = return ()
exactP (GHC.HsExplicitListTy _ ts) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
printStringAtMaybeAnn (G GHC.AnnOpen) "'["
mapM_ exactPC ts
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
exactP (GHC.HsExplicitTupleTy _ ts) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
printStringAtMaybeAnn (G GHC.AnnOpen) "'("
mapM_ exactPC ts
printStringAtMaybeAnn (G GHC.AnnClose) ")"
exactP (GHC.HsTyLit lit) = do
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
case lit of
(GHC.HsNumTy s _) -> printStringAtMaybeAnn (G GHC.AnnVal) s
(GHC.HsStrTy s _) -> printStringAtMaybeAnn (G GHC.AnnVal) s
exactP (GHC.HsWrapTy _ _) = return ()
exactP GHC.HsWildcardTy = do
printStringAtMaybeAnn (G GHC.AnnVal) "_"
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
exactP (GHC.HsNamedWildcardTy n) = do
printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n)
instance ExactP GHC.HsDocString where
exactP (GHC.HsDocString s) = do
printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS s)
instance ExactP (GHC.ConDeclField GHC.RdrName) where
exactP (GHC.ConDeclField ns ty mdoc) = do
mapM_ exactPC ns
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC ty
case mdoc of
Just doc -> exactPC doc
Nothing -> return ()
instance ExactP (GHC.HsContext GHC.RdrName) where
exactP typs = do
printStringAtMaybeAnn (G GHC.AnnDeriving) "deriving"
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
mapM_ exactPC typs
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
instance (ExactP body) => ExactP (GHC.GRHS GHC.RdrName (GHC.Located body)) where
exactP (GHC.GRHS guards expr) = do
printStringAtMaybeAnn (G GHC.AnnVbar) "|"
mapM_ exactPC guards
printStringAtMaybeAnn (G GHC.AnnEqual) "="
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
exactPC expr
instance (ExactP body)
=> ExactP (GHC.Stmt GHC.RdrName (GHC.Located body)) where
exactP (GHC.LastStmt body _) = exactPC body
`debug` ("exactP.LastStmt")
exactP (GHC.BindStmt pat body _ _) = do
exactPC pat
printStringAtMaybeAnn (G GHC.AnnLarrow) "<-"
exactPC body
printStringAtMaybeAnn (G GHC.AnnVbar) "|"
exactP (GHC.BodyStmt e _ _ _) = do
exactPC e
exactP (GHC.LetStmt lb) = do
printStringAtMaybeAnn (G GHC.AnnLet) "let"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
exactP lb
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.ParStmt pbs _ _) = do
mapM_ exactPParStmtBlock pbs
exactP (GHC.TransStmt form stmts _b using by _ _ _) = do
mapM_ exactPC stmts
case form of
GHC.ThenForm -> do
printStringAtMaybeAnn (G GHC.AnnThen) "then"
exactPC using
printStringAtMaybeAnn (G GHC.AnnBy) "by"
case by of
Just b -> exactPC b
Nothing -> return ()
GHC.GroupForm -> do
printStringAtMaybeAnn (G GHC.AnnThen) "then"
printStringAtMaybeAnn (G GHC.AnnGroup) "group"
printStringAtMaybeAnn (G GHC.AnnBy) "by"
case by of
Just b -> exactPC b
Nothing -> return ()
printStringAtMaybeAnn (G GHC.AnnUsing) "using"
exactPC using
exactP (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do
printStringAtMaybeAnn (G GHC.AnnRec) "rec"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
mapM_ exactPC stmts
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactPParStmtBlock :: GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> EP ()
exactPParStmtBlock (GHC.ParStmtBlock stmts _ns _) = do
mapM_ exactPC stmts
instance ExactP (GHC.HsExpr GHC.RdrName) where
exactP (GHC.HsVar v) = exactP v
exactP (GHC.HsIPVar (GHC.HsIPName v)) = do
printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ GHC.unpackFS v)
exactP (GHC.HsOverLit lit) = exactP lit
exactP (GHC.HsLit lit) = exactP lit
exactP (GHC.HsLam match) = do
printStringAtMaybeAnn (G GHC.AnnLam) "\\"
exactPMatchGroup match
exactP (GHC.HsLamCase _ match) = exactPMatchGroup match
exactP (GHC.HsApp e1 e2) = exactPC e1 >> exactPC e2
exactP (GHC.OpApp e1 op _f e2) = exactPC e1 >> exactPC op >> exactPC e2
exactP (GHC.NegApp e _) = do
printStringAtMaybeAnn (G GHC.AnnMinus) "-"
exactPC e
exactP (GHC.HsPar e) = do
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
exactPC e
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.SectionL e1 e2) = exactPC e1 >> exactPC e2
exactP (GHC.SectionR e1 e2) = exactPC e1 >> exactPC e2
exactP (GHC.ExplicitTuple args b) = do
if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnOpenP) "("
else printStringAtMaybeAnn (G GHC.AnnOpen) "(#"
mapM_ exactPC args `debug` ("exactP.ExplicitTuple")
if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
else printStringAtMaybeAnn (G GHC.AnnClose) "#)"
exactP (GHC.HsCase e1 matches) = do
printStringAtMaybeAnn (G GHC.AnnCase) "case"
exactPC e1
printStringAtMaybeAnn (G GHC.AnnOf) "of"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
exactPMatchGroup matches
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.HsIf _ e1 e2 e3) = do
printStringAtMaybeAnn (G GHC.AnnIf) "if"
exactPC e1
printStringAtMaybeAnn (G GHC.AnnSemi) ";"
printStringAtMaybeAnn (G GHC.AnnThen) "then"
exactPC e2
printStringAtMaybeAnn (G GHC.AnnSemi) ";"
printStringAtMaybeAnn (G GHC.AnnElse) "else"
exactPC e3
exactP (GHC.HsMultiIf _ rhs) = do
printStringAtMaybeAnn (G GHC.AnnIf) "if"
mapM_ exactPC rhs
exactP (GHC.HsLet lb e) = do
printStringAtMaybeAnn (G GHC.AnnLet) "let"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
exactP lb
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
printStringAtMaybeAnn (G GHC.AnnIn) "in"
exactPC e
exactP (GHC.HsDo cts stmts _typ) = do
printStringAtMaybeAnn (G GHC.AnnDo) "do"
let (ostr,cstr,isComp) =
if isListComp cts
then case cts of
GHC.PArrComp -> ("[:",":]",True)
_ -> ("[", "]",True)
else ("{","}",False)
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
printStringAtMaybeAnn (G GHC.AnnOpen) ostr
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
if isComp
then do
exactPC(last stmts)
printStringAtMaybeAnn (G GHC.AnnVbar) "|"
mapM_ exactPC (init stmts)
else do
mapM_ exactPC stmts
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
printStringAtMaybeAnn (G GHC.AnnClose) cstr
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.ExplicitList _ _ es) = do
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
mapM_ exactPC es
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
exactP (GHC.ExplicitPArr _ es) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
mapM_ exactPC es
printStringAtMaybeAnn (G GHC.AnnClose) ":]"
exactP (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do
exactPC n
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
mapM_ exactPC fs
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.RecordUpd e (GHC.HsRecFields fs _) cons _ _) = do
exactPC e
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
mapM_ exactPC fs
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.ExprWithTySig e typ _) = do
exactPC e
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC typ
exactP (GHC.ExprWithTySigOut e typ) = do
exactPC e
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC typ
exactP (GHC.ArithSeq _ _ seqInfo) = do
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
case seqInfo of
GHC.From e1 -> exactPC e1 >> printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
GHC.FromTo e1 e2 -> do
exactPC e1
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
exactPC e2
GHC.FromThen e1 e2 -> do
exactPC e1
printStringAtMaybeAnn (G GHC.AnnComma) ","
exactPC e2
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
GHC.FromThenTo e1 e2 e3 -> do
exactPC e1
printStringAtMaybeAnn (G GHC.AnnComma) ","
exactPC e2
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
exactPC e3
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
exactP (GHC.PArrSeq _ seqInfo) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
case seqInfo of
GHC.From e1 -> exactPC e1 >> printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
GHC.FromTo e1 e2 -> do
exactPC e1
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
exactPC e2
GHC.FromThen e1 e2 -> do
exactPC e1
printStringAtMaybeAnn (G GHC.AnnComma) ","
exactPC e2
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
GHC.FromThenTo e1 e2 e3 -> do
exactPC e1
printStringAtMaybeAnn (G GHC.AnnComma) ","
exactPC e2
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
exactPC e3
printStringAtMaybeAnn (G GHC.AnnClose) ":]"
exactP (GHC.HsSCC src str e) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS str)
printStringAtMaybeAnn (G GHC.AnnValStr) ("\"" ++ GHC.unpackFS str ++ "\"")
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactPC e
exactP (GHC.HsCoreAnn src str e) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS str)
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactPC e
exactP (GHC.HsBracket (GHC.VarBr single v)) = do
if single then printStringAtMaybeAnn (G GHC.AnnVal) ("'" ++ rdrName2String v)
else printStringAtMaybeAnn (G GHC.AnnVal) ("''" ++ rdrName2String v)
exactP (GHC.HsBracket (GHC.DecBrL ds)) = do
cnt <- countAnns (G GHC.AnnOpen)
case cnt of
1 -> do
printStringAtMaybeAnn (G GHC.AnnOpen) "[d|"
mapM_ exactPC ds
printStringAtMaybeAnn (G GHC.AnnClose) "|]"
_ -> do
printStringAtMaybeAnn (G GHC.AnnOpen) "[d|"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
mapM_ exactPC ds
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
printStringAtMaybeAnn (G GHC.AnnClose) "|]"
exactP (GHC.HsBracket (GHC.ExpBr e)) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[|"
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) "|]"
exactP (GHC.HsBracket (GHC.TExpBr e)) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[||"
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) "||]"
exactP (GHC.HsBracket (GHC.TypBr e)) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[t|"
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) "|]"
exactP (GHC.HsBracket (GHC.PatBr e)) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "[p|"
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) "|]"
exactP (GHC.HsRnBracketOut _ _) = return ()
exactP (GHC.HsTcBracketOut _ _) = return ()
exactP (GHC.HsSpliceE False (GHC.HsSplice _ e)) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "$("
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) ")"
exactP (GHC.HsSpliceE True (GHC.HsSplice _ e)) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "$$("
exactPC e
printStringAtMaybeAnn (G GHC.AnnClose) ")"
exactP (GHC.HsQuasiQuoteE (GHC.HsQuasiQuote n _ str)) = do
printStringAtMaybeAnn (G GHC.AnnVal)
("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS str) ++ "|]")
exactP (GHC.HsProc p c) = do
printStringAtMaybeAnn (G GHC.AnnProc) "proc"
exactPC p
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
exactPC c
exactP (GHC.HsStatic e) = do
printStringAtMaybeAnn (G GHC.AnnStatic) "static"
exactPC e
exactP (GHC.HsArrApp e1 e2 _ _ _) = do
exactPC e1
printStringAtMaybeAnn (G GHC.Annlarrowtail) "-<"
printStringAtMaybeAnn (G GHC.Annrarrowtail) ">-"
printStringAtMaybeAnn (G GHC.AnnLarrowtail) "-<<"
printStringAtMaybeAnn (G GHC.AnnRarrowtail) ">>-"
exactPC e2
exactP (GHC.HsArrForm e _ cs) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "(|"
exactPC e
mapM_ exactPC cs
printStringAtMaybeAnn (G GHC.AnnClose) "|)"
exactP (GHC.HsTick _ _) = return ()
exactP (GHC.HsBinTick _ _ _) = return ()
exactP (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
printStringAtMaybeAnn (G GHC.AnnVal) (show $ GHC.unpackFS str)
printStringAtMaybeAnn (G GHC.AnnVal) (show v1)
printStringAtMaybeAnn (G GHC.AnnColon) ":"
printStringAtMaybeAnn (G GHC.AnnVal) (show v2)
printStringAtMaybeAnn (G GHC.AnnMinus) "-"
printStringAtMaybeAnn (G GHC.AnnVal) (show v3)
printStringAtMaybeAnn (G GHC.AnnColon) ":"
printStringAtMaybeAnn (G GHC.AnnVal) (show v4)
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactPC e
exactP (GHC.EWildPat) = printStringAtMaybeAnn (G GHC.AnnVal) "_"
exactP (GHC.EAsPat n e) = do
exactPC n
printStringAtMaybeAnn (G GHC.AnnAt) "@"
exactPC e
exactP (GHC.EViewPat e1 e2) = do
exactPC e1
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
exactPC e2
exactP (GHC.ELazyPat e) = do
printStringAtMaybeAnn (G GHC.AnnTilde) "~"
exactPC e
exactP (GHC.HsType ty) = exactPC ty
exactP (GHC.HsWrap _ _) = return ()
exactP (GHC.HsUnboundVar _) = return ()
exactP e = printString "HsExpr"
`debug` ("exactP.HsExpr:not processing " ++ (showGhc e) )
instance (ExactP arg) => ExactP (GHC.HsRecField GHC.RdrName (GHC.Located arg)) where
exactP (GHC.HsRecField n e _) = do
exactPC n
printStringAtMaybeAnn (G GHC.AnnEqual) "="
exactPC e
instance ExactP (GHC.HsCmdTop GHC.RdrName) where
exactP (GHC.HsCmdTop cmd _ _ _) = exactPC cmd
instance ExactP (GHC.HsCmd GHC.RdrName) where
exactP (GHC.HsCmdArrApp e1 e2 _ _ _) = do
exactPC e1
printStringAtMaybeAnn (G GHC.Annlarrowtail) "-<"
printStringAtMaybeAnn (G GHC.Annrarrowtail) ">-"
printStringAtMaybeAnn (G GHC.AnnLarrowtail) "-<<"
printStringAtMaybeAnn (G GHC.AnnRarrowtail) ">>-"
exactPC e2
exactP (GHC.HsCmdArrForm e _ cs) = do
printStringAtMaybeAnn (G GHC.AnnOpen) "(|"
exactPC e
mapM_ exactPC cs
printStringAtMaybeAnn (G GHC.AnnClose) "|)"
exactP (GHC.HsCmdApp e1 e2) = exactPC e1 >> exactPC e2
exactP (GHC.HsCmdLam match) = do
printStringAtMaybeAnn (G GHC.AnnLam) "\\"
exactPMatchGroup match
exactP (GHC.HsCmdPar e) = do
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
exactPC e
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
exactP (GHC.HsCmdCase e1 matches) = do
printStringAtMaybeAnn (G GHC.AnnCase) "case"
exactPC e1
printStringAtMaybeAnn (G GHC.AnnOf) "of"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
exactPMatchGroup matches
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.HsCmdIf _ e1 e2 e3) = do
printStringAtMaybeAnn (G GHC.AnnIf) "if"
exactPC e1
printStringAtMaybeAnn (G GHC.AnnSemi) ";"
printStringAtMaybeAnn (G GHC.AnnThen) "then"
exactPC e2
printStringAtMaybeAnn (G GHC.AnnSemi) ";"
printStringAtMaybeAnn (G GHC.AnnElse) "else"
exactPC e3
exactP (GHC.HsCmdLet lb e) = do
printStringAtMaybeAnn (G GHC.AnnLet) "let"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
exactP lb
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
printStringAtMaybeAnn (G GHC.AnnIn) "in"
exactPC e
exactP (GHC.HsCmdDo stmts _typ) = do
printStringAtMaybeAnn (G GHC.AnnDo) "do"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
mapM_ exactPC stmts
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
exactP (GHC.HsCmdCast {}) = error $ "exactP.HsCmdCast: only valid after type checker"
instance ExactP GHC.RdrName where
exactP n = do
case rdrName2String n of
"[]" -> do
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
"()" -> do
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
"(##)" -> do
printStringAtMaybeAnn (G GHC.AnnOpen) "(#"
printStringAtMaybeAnn (G GHC.AnnClose) "#)"
"[::]" -> do
printStringAtMaybeAnn (G GHC.AnnOpen) "[:"
printStringAtMaybeAnn (G GHC.AnnClose) ":]"
str -> do
printStringAtMaybeAnn (G GHC.AnnType) "type"
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
printStringAtMaybeAnn (G GHC.AnnBackquote) "`"
printStringAtMaybeAnn (G GHC.AnnTildehsh) "~#"
printStringAtMaybeAnn (G GHC.AnnTilde) "~"
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
printStringAtMaybeAnn (G GHC.AnnVal) str
printStringAtMaybeAnn (G GHC.AnnBackquote) "`"
printStringAtMaybeAnnAll (G GHC.AnnCommaTuple) ","
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
return () `debug` ("exactP.RdrName:n=" ++ str)
instance ExactP GHC.HsIPName where
exactP (GHC.HsIPName n) = do
printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ GHC.unpackFS n)
exactPMatchGroup :: (ExactP body) => (GHC.MatchGroup GHC.RdrName (GHC.Located body))
-> EP ()
exactPMatchGroup (GHC.MG matches _ _ _)
= mapM_ exactPC matches
instance ExactP (GHC.HsTupArg GHC.RdrName) where
exactP (GHC.Missing _) = do
printStringAtMaybeAnn (G GHC.AnnComma) ","
return ()
exactP (GHC.Present e) = do
exactPC e
printStringAtMaybeAnn (G GHC.AnnComma) ","
instance ExactP (GHC.HsLocalBinds GHC.RdrName) where
exactP (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do
printMerged (GHC.bagToList binds) sigs
exactP (GHC.HsValBinds (GHC.ValBindsOut _binds _sigs)) = printString "ValBindsOut"
exactP (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ exactPC binds
exactP (GHC.EmptyLocalBinds) = return ()
instance ExactP (GHC.Sig GHC.RdrName) where
exactP (GHC.TypeSig lns typ _) = do
mapM_ exactPC lns
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC typ
exactP (GHC.PatSynSig n (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do
printStringAtMaybeAnn (G GHC.AnnPattern) "pattern"
exactPC n
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
printStringAtMaybeAnn (G GHC.AnnForall) "forall"
mapM_ exactPC bndrs
printStringAtMaybeAnn (G GHC.AnnDot) "."
exactPC ctx1
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
exactPC ctx2
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
exactPC typ
exactP (GHC.GenericSig ns typ) = do
printStringAtMaybeAnn (G GHC.AnnDefault) "default"
mapM_ exactPC ns
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC typ
exactP (GHC.IdSig _) = return ()
exactP (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do
let fixstr = case fdir of
GHC.InfixL -> "infixl"
GHC.InfixR -> "infixr"
GHC.InfixN -> "infix"
printStringAtMaybeAnn (G GHC.AnnInfix) fixstr
printStringAtMaybeAnn (G GHC.AnnVal) (show v)
mapM_ exactPC lns
exactP (GHC.InlineSig n inl) = do
let actStr = case GHC.inl_act inl of
GHC.NeverActive -> ""
GHC.AlwaysActive -> ""
GHC.ActiveBefore np -> show np
GHC.ActiveAfter np -> show np
printStringAtMaybeAnn (G GHC.AnnOpen) (GHC.inl_src inl)
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
printStringAtMaybeAnn (G GHC.AnnTilde) "~"
printStringAtMaybeAnn (G GHC.AnnVal) actStr
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
exactPC n
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP (GHC.SpecSig n typs inl) = do
printStringAtMaybeAnn (G GHC.AnnOpen) (GHC.inl_src inl)
printStringAtMaybeAnn (G GHC.AnnOpenS) "["
printStringAtMaybeAnn (G GHC.AnnTilde) "~"
printStringAtMaybeAnn (G GHC.AnnVal) "TODO:what here?"
printStringAtMaybeAnn (G GHC.AnnCloseS) "]"
exactPC n
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
mapM_ exactPC typs
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"
exactP _ = printString "Sig"
instance ExactP (GHC.HsOverLit GHC.RdrName) where
exactP ol = do
case GHC.ol_val ol of
GHC.HsIntegral src _ -> printStringAtMaybeAnn (G GHC.AnnVal) src
GHC.HsFractional l -> printStringAtMaybeAnn (G GHC.AnnVal) (GHC.fl_text l)
GHC.HsIsString src _ -> printStringAtMaybeAnn (G GHC.AnnVal) src
instance ExactP GHC.HsLit where
exactP lit = printStringAtMaybeAnn (G GHC.AnnVal) (hsLit2String lit)
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
instance ExactP (GHC.TyClDecl GHC.RdrName) where
exactP (GHC.FamDecl famdecl) = exactP famdecl
exactP (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do
printStringAtMaybeAnn (G GHC.AnnType) "type"
exactPC ln
mapM_ exactPC tyvars
printStringAtMaybeAnn (G GHC.AnnEqual) "="
exactPC typ
exactP (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars)
(GHC.HsDataDefn _nOrD ctx mctyp mkind cons mderivs) _) = do
printStringAtMaybeAnn (G GHC.AnnData) "data"
printStringAtMaybeAnn (G GHC.AnnNewtype) "newtype"
doMaybe exactPC mctyp
exactPC ctx
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
printTyClass ln tyVars
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
doMaybe exactPC mkind
printStringAtMaybeAnn (G GHC.AnnEqual) "="
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
mapM_ exactPC cons
doMaybe exactPC mderivs
exactP (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds
sigs meths ats atdefs docs _) = do
printStringAtMaybeAnn (G GHC.AnnClass) "class"
exactPC ctx
printTyClass ln tyVars
printStringAtMaybeAnn (G GHC.AnnVbar) "|"
mapM_ exactPC fds
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
printStringAtMaybeAnnAll (G GHC.AnnSemi) ";"
applyListPrint (prepareListPrint sigs
++ prepareListPrint (GHC.bagToList meths)
++ prepareListPrint ats
++ prepareListPrint atdefs
++ prepareListPrint docs
)
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
printTyClass :: (ExactP ast, ExactP ast1)
=> GHC.Located ast -> [GHC.Located ast1] -> EP ()
printTyClass ln tyVars = do
printStringAtMaybeAnnAll (G GHC.AnnOpenP) "("
applyListPrint (prepareListPrint [ln]
++ prepareListPrint (take 2 tyVars))
printStringAtMaybeAnnAll (G GHC.AnnCloseP) ")"
mapM_ exactPC (drop 2 tyVars)
instance ExactP (GHC.FamilyDecl GHC.RdrName) where
exactP (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do
printStringAtMaybeAnn (G GHC.AnnType) "type"
printStringAtMaybeAnn (G GHC.AnnData) "data"
printStringAtMaybeAnn (G GHC.AnnFamily) "family"
exactPC ln
mapM_ exactPC tyvars
case mkind of
Nothing -> return ()
Just k -> exactPC k
printStringAtMaybeAnn (G GHC.AnnWhere) "where"
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
case info of
GHC.ClosedTypeFamily eqns -> mapM_ exactPC eqns
_ -> return ()
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
instance ExactP (GHC.TyFamDefltEqn GHC.RdrName) where
exactP = assert False undefined
instance ExactP (GHC.TyFamInstEqn GHC.RdrName) where
exactP (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do
exactPC ln
mapM_ exactPC pats
printStringAtMaybeAnn (G GHC.AnnEqual) "="
exactPC typ
instance ExactP GHC.DocDecl where
exactP (GHC.DocCommentNext (GHC.HsDocString fs))
= printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)
exactP (GHC.DocCommentPrev (GHC.HsDocString fs))
= printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)
exactP (GHC.DocCommentNamed _s (GHC.HsDocString fs))
= printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)
exactP (GHC.DocGroup _i (GHC.HsDocString fs))
= printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs)
instance ExactP (GHC.FunDep (GHC.Located GHC.RdrName)) where
exactP (ls,rs) = do
mapM_ exactPC ls
printStringAtMaybeAnn (G GHC.AnnRarrow) "->"
mapM_ exactPC rs
instance ExactP (GHC.HsTyVarBndr GHC.RdrName) where
exactP (GHC.UserTyVar n) = printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n)
exactP (GHC.KindedTyVar n ty) = do
printStringAtMaybeAnn (G GHC.AnnOpenP) "("
exactPC n
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC ty
printStringAtMaybeAnn (G GHC.AnnCloseP) ")"
instance ExactP [GHC.LConDecl GHC.RdrName] where
exactP cons = mapM_ exactPC cons
instance ExactP (GHC.ConDecl GHC.RdrName) where
exactP (GHC.ConDecl lns _exp (GHC.HsQTvs _ns bndrs) ctx dets res _ _) = do
case res of
GHC.ResTyH98 -> do
printStringAtMaybeAnn (G GHC.AnnForall) "forall"
mapM_ exactPC bndrs
printStringAtMaybeAnn (G GHC.AnnDot) "."
exactPC ctx
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
case dets of
GHC.InfixCon _ _ -> return ()
_ -> mapM_ exactPC lns
case dets of
GHC.PrefixCon args -> mapM_ exactPC args
GHC.RecCon fs -> do
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
exactPC fs
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
GHC.InfixCon a1 a2 -> do
exactPC a1
mapM_ exactPC lns
exactPC a2
GHC.ResTyGADT ls ty -> do
case dets of
GHC.InfixCon _ _ -> return ()
_ -> mapM_ exactPC lns
case dets of
GHC.PrefixCon args -> mapM_ exactPC args
GHC.RecCon fs -> do
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
exactPC fs
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
GHC.InfixCon a1 a2 -> do
exactPC a1
mapM_ exactPC lns
exactPC a2
printStringAtMaybeAnn (G GHC.AnnDcolon) "::"
exactPC (GHC.L ls (ResTyGADTHook bndrs))
exactPC ctx
printStringAtMaybeAnn (G GHC.AnnDarrow) "=>"
exactPC ty
printStringAtMaybeAnn (G GHC.AnnVbar) "|"
instance ExactP (ResTyGADTHook GHC.RdrName) where
exactP (ResTyGADTHook bndrs) = do
printStringAtMaybeAnn (G GHC.AnnForall) "forall"
mapM_ exactPC bndrs
printStringAtMaybeAnn (G GHC.AnnDot) "."
instance ExactP [GHC.LConDeclField GHC.RdrName] where
exactP fs = do
printStringAtMaybeAnn (G GHC.AnnOpenC) "{"
mapM_ exactPC fs
printStringAtMaybeAnn (G GHC.AnnDotdot) ".."
printStringAtMaybeAnn (G GHC.AnnCloseC) "}"
instance ExactP (GHC.CType) where
exactP (GHC.CType src mh f) = do
printStringAtMaybeAnn (G GHC.AnnOpen) src
case mh of
Nothing -> return ()
Just (GHC.Header h) ->
printStringAtMaybeAnn (G GHC.AnnHeader) ("\"" ++ GHC.unpackFS h ++ "\"")
printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ GHC.unpackFS f ++ "\"")
printStringAtMaybeAnn (G GHC.AnnClose) "#-}"