module Language.Haskell.GHC.ExactPrint.Utils
(
ss2pos
, ss2posEnd
, undelta
, isPointSrcSpan
, pos2delta
, ss2delta
, addDP
, spanLength
, isGoodDelta
, mkComment
, mkKWComment
, dpFromString
, comment2dp
, extractComments
, srcSpanStartLine
, srcSpanEndLine
, srcSpanStartColumn
, srcSpanEndColumn
, rdrName2String
, isSymbolRdrName
, tokComment
, isListComp
, isGadt
, isExactName
, getAnnotationEP
, annTrueEntryDelta
, annCommentEntryDelta
, annLeadingCommentEntryDelta
, orderByKey
, setAcs, setAcsWithLevel
, unsetAcs
, inAcs
, pushAcs
, bumpAcs
#if __GLASGOW_HASKELL__ <= 710
, makeBooleanFormulaAnns
#endif
, debug
, debugP
, debugM
, warn
, showGhc
, showAnnData
, occAttributes
, showSDoc_, showSDocDebug_
, ghead,glast,gtail,gfromJust
) where
import Control.Monad.State
import qualified Data.ByteString as B
import Data.Generics
import Data.Ord (comparing)
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Lookup
import qualified Bag as GHC
#if __GLASGOW_HASKELL__ <= 710
import qualified BooleanFormula as GHC
#endif
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified GHC
import qualified Name as GHC
import qualified NameSet as GHC
import qualified Outputable as GHC
import qualified RdrName as GHC
import qualified SrcLoc as GHC
import qualified Var as GHC
import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief)
import Control.Arrow
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List
import Debug.Trace
debugEnabledFlag :: Bool
debugEnabledFlag = False
debugPEnabledFlag :: Bool
debugPEnabledFlag = False
debug :: c -> String -> c
debug c s = if debugEnabledFlag
then trace s c
else c
debugP :: String -> c -> c
debugP s c = if debugPEnabledFlag
then trace s c
else c
debugM :: Monad m => String -> m ()
debugM s = when debugEnabledFlag $ traceM s
showGhc :: (GHC.Outputable a) => a -> String
showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
warn :: c -> String -> c
warn c _ = c
isGoodDelta :: DeltaPos -> Bool
isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0
ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos
ss2delta ref ss = pos2delta ref (ss2pos ss)
pos2delta :: Pos -> Pos -> DeltaPos
pos2delta (refl,refc) (l,c) = DP (lo,co)
where
lo = l refl
co = if lo == 0 then c refc
else c
undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos
undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc)
where
fl = l + dl
fc = if dl == 0 then c + dc
else co + dc
addDP :: DeltaPos -> DeltaPos -> DeltaPos
addDP (DP (a, b)) (DP (c, d)) =
if c >= 1 then DP (a+c, d)
else DP (a, b+d)
stepDP :: DeltaPos -> DeltaPos -> DeltaPos
stepDP (DP (a,b)) (DP (c,d))
| (a,b) == (c,d) = DP (a,b)
| a == c = if b < d then DP (0,d b)
else if d == 0
then DP (1,0)
else DP (c,d)
| a < c = DP (c a,d)
| otherwise = DP (1,d)
ss2pos :: GHC.SrcSpan -> Pos
ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss)
ss2posEnd :: GHC.SrcSpan -> Pos
ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss)
srcSpanEndColumn :: GHC.SrcSpan -> Int
srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s
srcSpanEndColumn _ = 0
srcSpanStartColumn :: GHC.SrcSpan -> Int
srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s
srcSpanStartColumn _ = 0
srcSpanEndLine :: GHC.SrcSpan -> Int
srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s
srcSpanEndLine _ = 0
srcSpanStartLine :: GHC.SrcSpan -> Int
srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s
srcSpanStartLine _ = 0
spanLength :: GHC.SrcSpan -> Int
spanLength = () <$> srcSpanEndColumn <*> srcSpanStartColumn
isPointSrcSpan :: GHC.SrcSpan -> Bool
isPointSrcSpan ss = spanLength ss == 0
&& srcSpanStartLine ss == srcSpanEndLine ss
orderByKey :: [(GHC.SrcSpan,a)] -> [GHC.SrcSpan] -> [(GHC.SrcSpan,a)]
orderByKey keys order
= sortBy (comparing (flip elemIndex order . fst)) keys
isListComp :: GHC.HsStmtContext name -> Bool
isListComp cts = case cts of
GHC.ListComp -> True
GHC.MonadComp -> True
GHC.PArrComp -> True
GHC.DoExpr -> False
GHC.MDoExpr -> False
GHC.ArrowExpr -> False
GHC.GhciStmtCtxt -> False
GHC.PatGuard {} -> False
GHC.ParStmtCtxt {} -> False
GHC.TransStmtCtxt {} -> False
isGadt :: [GHC.LConDecl name] -> Bool
isGadt [] = False
#if __GLASGOW_HASKELL__ <= 710
isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True
#else
isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True
#endif
isGadt _ = False
isExactName :: (Data name) => name -> Bool
isExactName = False `mkQ` GHC.isExact
ghcCommentText :: GHC.Located GHC.AnnotationComment -> String
ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s)) = s
ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s)) = s
ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s
ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s)) = s
ghcCommentText (GHC.L _ (GHC.AnnDocOptions s)) = s
#if __GLASGOW_HASKELL__ < 801
ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s)) = s
#endif
ghcCommentText (GHC.L _ (GHC.AnnLineComment s)) = s
ghcCommentText (GHC.L _ (GHC.AnnBlockComment s)) = s
tokComment :: GHC.Located GHC.AnnotationComment -> Comment
tokComment t@(GHC.L lt _) = mkComment (ghcCommentText t) lt
mkComment :: String -> GHC.SrcSpan -> Comment
mkComment c ss = Comment c ss Nothing
mkKWComment :: GHC.AnnKeywordId -> GHC.SrcSpan -> Comment
mkKWComment kw ss = Comment (keywordToString $ G kw) ss (Just kw)
comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos)
comment2dp = first AnnComment
extractComments :: GHC.ApiAnns -> [Comment]
extractComments (_,cm)
= map tokComment . GHC.sortLocated . concat $ Map.elems cm
getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation
getAnnotationEP la as =
Map.lookup (mkAnnKey la) as
annTrueEntryDelta :: Annotation -> DeltaPos
annTrueEntryDelta Ann{annEntryDelta, annPriorComments} =
foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
`addDP` annEntryDelta
annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos
annCommentEntryDelta Ann{annPriorComments} trueDP = dp
where
commentDP =
foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
dp = stepDP commentDP trueDP
annLeadingCommentEntryDelta :: Annotation -> DeltaPos
annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp
where
dp = case annPriorComments of
[] -> annEntryDelta
((_,ed):_) -> ed
dpFromString :: String -> DeltaPos
dpFromString xs = dpFromString' xs 0 0
where
dpFromString' "" line col = DP (line, col)
dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0
dpFromString' (_:cs) line col = dpFromString' cs line (col + 1)
isSymbolRdrName :: GHC.RdrName -> Bool
isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n
rdrName2String :: GHC.RdrName -> String
rdrName2String r =
case GHC.isExact_maybe r of
Just n -> name2String n
Nothing ->
case r of
GHC.Unqual occ -> GHC.occNameString occ
GHC.Qual modname occ -> GHC.moduleNameString modname ++ "."
++ GHC.occNameString occ
GHC.Orig _ occ -> GHC.occNameString occ
GHC.Exact n -> GHC.getOccString n
name2String :: GHC.Name -> String
name2String = showGhc
setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet
setAcs ctxt acs = setAcsWithLevel ctxt 3 acs
setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a
setAcsWithLevel ctxt level (ACS a) = ACS a'
where
upd s (k,v) = Map.insert k v s
a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level)
unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a
unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a
inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool
inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a)
pushAcs :: ACS' a -> ACS' a
pushAcs (ACS a) = ACS $ Map.mapMaybe f a
where
f n
| n <= 1 = Nothing
| otherwise = Just (n 1)
bumpAcs :: ACS' a -> ACS' a
bumpAcs (ACS a) = ACS $ Map.mapMaybe f a
where
f n = Just (n + 1)
#if __GLASGOW_HASKELL__ <= 710
makeBooleanFormulaAnns :: (GHC.Outputable a)
=> GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)]
makeBooleanFormulaAnns bf = go 1 bf
where
go :: (GHC.Outputable a)
=> Int -> GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)]
go _ (GHC.Var _) = []
go l v@(GHC.And [a,b]) =
go 3 a ++
go 3 b ++
(if l > 3 then addParensIfNeeded v else []) ++
[(GHC.AnnComma, ssAfter (getBoolSrcSpan a))]
go l v@(GHC.Or [a,b]) =
go 2 a ++
go 2 b ++
(if l > 2 then addParensIfNeeded v else []) ++
[(GHC.AnnVbar, ssAfter (getBoolSrcSpan a) )]
go _ x = error $ "makeBooleanFormulaAnns: unexpected case:" ++ showGhc x
addParensIfNeeded :: GHC.Outputable a
=> GHC.BooleanFormula (GHC.Located a)
-> [(GHC.AnnKeywordId, GHC.SrcSpan)]
addParensIfNeeded (GHC.Var _) = []
addParensIfNeeded a = [(GHC.AnnOpenP,opp),(GHC.AnnCloseP,cpp)]
where
ss = getBoolSrcSpan a
opp = ssBefore ss
cpp = ssAfter ss
ssBefore :: GHC.SrcSpan -> GHC.SrcSpan
ssBefore a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e)
where
GHC.RealSrcLoc as = GHC.srcSpanStart a
s = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as 2)
e = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as 1)
ssAfter :: GHC.SrcSpan -> GHC.SrcSpan
ssAfter a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e)
where
GHC.RealSrcLoc ae = GHC.srcSpanEnd a
s = ae
e = GHC.advanceSrcLoc s ' '
getBoolSrcSpan :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> GHC.SrcSpan
getBoolSrcSpan (GHC.Var (GHC.L ss _)) = ss
getBoolSrcSpan (GHC.And [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b)
getBoolSrcSpan (GHC.Or [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b)
getBoolSrcSpan x = error $ "getBoolSrcSpan: unexpected case:" ++ showGhc x
#endif
showAnnData :: Data a => Anns -> Int -> a -> String
showAnnData anns n =
generic
`ext1Q` list
`extQ` string `extQ` fastString `extQ` srcSpan
`extQ` bytestring
`extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
`extQ` fixity
`ext2Q` located
where generic :: Data a => a -> String
generic t = indent n ++ "(" ++ showConstr (toConstr t)
++ space (unwords (gmapQ (showAnnData anns (n+1)) t)) ++ ")"
space "" = ""
space s = ' ':s
indent i = "\n" ++ replicate i ' '
string = show :: String -> String
fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String
bytestring = show :: B.ByteString -> String
list l = indent n ++ "["
++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]"
name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String
occName o = "{OccName: "++ OccName.occNameString o ++ " " ++ occAttributes o ++ "}"
moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String
srcSpan :: GHC.SrcSpan -> String
srcSpan ss = "{ "++ showSDoc_ (GHC.hang (GHC.ppr ss) (n+2)
(GHC.text "")
)
++"}"
var = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String
dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String
bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String
bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList
bagName :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String
bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList
bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String
bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList
#if __GLASGOW_HASKELL__ > 800
nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable
#else
nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems
#endif
fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String
located :: (Data b,Data loc) => GHC.GenLocated loc b -> String
located (GHC.L ss a) =
indent n ++ "("
++ case cast ss of
Just (s :: GHC.SrcSpan) ->
srcSpan s
++ indent (n + 1) ++
show (getAnnotationEP (GHC.L s a) anns)
Nothing -> "nnnnnnnn"
++ showAnnData anns (n+1) a
++ ")"
occAttributes :: OccName.OccName -> String
occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"
where
ns = (GHC.showSDocUnsafe $ OccName.pprNameSpaceBrief $ GHC.occNameSpace o) ++ ", "
vo = if GHC.isVarOcc o then "Var " else ""
tv = if GHC.isTvOcc o then "Tv " else ""
tc = if GHC.isTcOcc o then "Tc " else ""
d = if GHC.isDataOcc o then "Data " else ""
ds = if GHC.isDataSymOcc o then "DataSym " else ""
s = if GHC.isSymOcc o then "Sym " else ""
v = if GHC.isValOcc o then "Val " else ""
showSDoc_ :: GHC.SDoc -> String
showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
showSDocDebug_ :: GHC.SDoc -> String
#if __GLASGOW_HASKELL__ <= 710
showSDocDebug_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
#else
showSDocDebug_ = GHC.showSDocDebug GHC.unsafeGlobalDynFlags
#endif
ghead :: String -> [a] -> a
ghead info [] = error $ "ghead "++info++" []"
ghead _info (h:_) = h
glast :: String -> [a] -> a
glast info [] = error $ "glast " ++ info ++ " []"
glast _info h = last h
gtail :: String -> [a] -> [a]
gtail info [] = error $ "gtail " ++ info ++ " []"
gtail _info h = tail h
gfromJust :: String -> Maybe a -> a
gfromJust _info (Just h) = h
gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing"