{-# LANGUAGE TypeOperators , DefaultSignatures , StandaloneDeriving , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses , TypeFamilies #-} -- | A module for displaying debug info about the source annotations of the syntax tree in different phases. module Language.Haskell.Tools.Refactor.RangeDebug where import GHC.Generics import Control.Reference import SrcLoc import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.FromGHC import Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate import Language.Haskell.Tools.AnnTrf.RangeTemplate import Language.Haskell.Tools.AnnTrf.SourceTemplate rangeDebug :: (a ~ NodeInfo sema SpanInfo, TreeDebug e a) => e a -> String rangeDebug = treeDebug' (shortShowSpanInfo . (^. sourceInfo)) 0 shortShowSpanInfo :: SpanInfo -> String shortShowSpanInfo (NodeSpan sp) = shortShowSpan sp shortShowSpanInfo (OptionalPos bef aft loc) = "?" ++ show bef ++ " " ++ show aft ++ " " ++ shortShowLoc loc shortShowSpanInfo (ListPos bef aft sep _ loc) = "*" ++ show bef ++ " " ++ show sep ++ " " ++ show aft ++ " " ++ shortShowLoc loc shortShowSpan :: SrcSpan -> String shortShowSpan (UnhelpfulSpan _) = "??-??" shortShowSpan sp@(RealSrcSpan _) = shortShowLoc (srcSpanStart sp) ++ "-" ++ shortShowLoc (srcSpanEnd sp) shortShowLoc :: SrcLoc -> String shortShowLoc (UnhelpfulLoc _) = "??" shortShowLoc (RealSrcLoc loc) = show (srcLocLine loc) ++ ":" ++ show (srcLocCol loc) templateDebug :: TreeDebug e (NodeInfo sema RangeTemplate) => e (NodeInfo sema RangeTemplate) -> String templateDebug = treeDebug' (shortShowRangeTemplate . (^. sourceInfo)) 0 shortShowRangeTemplate (RangeTemplate _ rngs) = "ˇ" ++ concatMap showRangeTemplateElem rngs ++ "ˇ" where showRangeTemplateElem (RangeElem sp) = "[" ++ shortShowSpan (RealSrcSpan sp) ++ "]" showRangeTemplateElem (RangeChildElem) = "." showRangeTemplateElem r = show r sourceTemplateDebug :: TreeDebug e (NodeInfo sema SourceTemplate) => e (NodeInfo sema SourceTemplate) -> String sourceTemplateDebug = treeDebug' (shortShowSourceTemplate . (^. sourceInfo)) 0 shortShowSourceTemplate temp = "ˇ" ++ (concatMap show $ temp ^. sourceTemplateElems) ++ "ˇ" class TreeDebug e a where treeDebug' :: (a -> String) -> Int -> e a -> String default treeDebug' :: (GTreeDebug (Rep (e a)) a, Generic (e a)) => (a -> String) -> Int -> e a -> String treeDebug' f i = gTreeDebug f i . from class GTreeDebug f a where gTreeDebug :: (a -> String) -> Int -> f p -> String instance GTreeDebug V1 a where gTreeDebug _ _ _ = error "GTreeDebug V1" instance GTreeDebug U1 a where gTreeDebug _ _ U1 = "" instance (GTreeDebug f a, GTreeDebug g a) => GTreeDebug (f :+: g) a where gTreeDebug f i (L1 x) = gTreeDebug f i x gTreeDebug f i (R1 x) = gTreeDebug f i x instance (GTreeDebug f a, GTreeDebug g a) => GTreeDebug (f :*: g) a where gTreeDebug f i (x :*: y) = gTreeDebug f i x ++ gTreeDebug f i y instance {-# OVERLAPPING #-} TreeDebug e a => GTreeDebug (K1 i (e a)) a where gTreeDebug f i (K1 x) = treeDebug' f i x instance {-# OVERLAPPABLE #-} GTreeDebug (K1 i c) a where gTreeDebug f i (K1 x) = "" instance GTreeDebug f a => GTreeDebug (M1 i t f) a where gTreeDebug f i (M1 x) = gTreeDebug f i x