module Language.Haskell.GHC.ExactPrint.Types
(
Anns
, emptyAnns
, Annotation(..)
, annNone
, KeywordId(..)
, Comment(..)
, Pos
, DeltaPos(..)
, deltaRow, deltaColumn
, AnnKey(..)
, mkAnnKey
, AnnConName(..)
, annGetConstr
, Rigidity(..)
, LayoutStartCol(..)
, declFun
) where
import Data.Data (Data, Typeable, toConstr,cast)
import qualified DynFlags as GHC
import qualified GHC
import qualified Outputable as GHC
import qualified Data.Map as Map
data Comment = Comment
{
commentContents :: !String
, commentIdentifier :: !GHC.SrcSpan
, commentOrigin :: !(Maybe GHC.AnnKeywordId)
}
deriving (Eq,Typeable,Data,Ord)
instance Show Comment where
show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")"
instance GHC.Outputable Comment where
ppr x = GHC.text (show x)
type Pos = (Int,Int)
newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)
deltaRow, deltaColumn :: DeltaPos -> Int
deltaRow (DP (r, _)) = r
deltaColumn (DP (_, c)) = c
newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }
deriving (Eq, Num)
instance Show LayoutStartCol where
show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")"
annNone :: Annotation
annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing
data Annotation = Ann
{
annEntryDelta :: !DeltaPos
, annPriorComments :: ![(Comment, DeltaPos)]
, annFollowingComments :: ![(Comment, DeltaPos)]
, annsDP :: ![(KeywordId, DeltaPos)]
, annSortKey :: !(Maybe [GHC.SrcSpan])
, annCapturedSpan :: !(Maybe AnnKey)
} deriving (Typeable,Eq)
instance Show Annotation where
show (Ann dp comments fcomments ans sk csp)
= "(Ann (" ++ show dp ++ ") " ++ show comments ++ " "
++ show fcomments ++ " "
++ show ans ++ " " ++ showGhc sk ++ " "
++ showGhc csp ++ ")"
type Anns = Map.Map AnnKey Annotation
emptyAnns :: Anns
emptyAnns = Map.empty
data AnnKey = AnnKey GHC.SrcSpan AnnConName
deriving (Eq, Ord)
instance Show AnnKey where
show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn
mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey
mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a)
mkAnnKey :: (Data a) => GHC.Located a -> AnnKey
mkAnnKey ld =
case cast ld :: Maybe (GHC.LHsDecl GHC.RdrName) of
Just d -> declFun mkAnnKeyPrim d
Nothing -> mkAnnKeyPrim ld
data AnnConName = CN { unConName :: String }
deriving (Eq,Ord)
instance Show AnnConName where
show (CN s) = "CN " ++ show s
annGetConstr :: (Data a) => a -> AnnConName
annGetConstr a = CN (show $ toConstr a)
data KeywordId = G GHC.AnnKeywordId
| AnnSemiSep
| AnnComment Comment
| AnnString String
#if __GLASGOW_HASKELL__ <= 710
| AnnUnicode GHC.AnnKeywordId
#endif
deriving (Eq,Ord)
instance Show KeywordId where
show (G gc) = "(G " ++ show gc ++ ")"
show AnnSemiSep = "AnnSemiSep"
show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"
show (AnnString s) = "(AnnString " ++ s ++ ")"
#if __GLASGOW_HASKELL__ <= 710
show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")"
#endif
instance GHC.Outputable KeywordId where
ppr k = GHC.text (show k)
instance GHC.Outputable (AnnConName) where
ppr tr = GHC.text (show tr)
instance GHC.Outputable Annotation where
ppr a = GHC.text (show a)
instance GHC.Outputable AnnKey where
ppr a = GHC.text (show a)
instance GHC.Outputable DeltaPos where
ppr a = GHC.text (show a)
data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b
declFun f (GHC.L l de) =
case de of
GHC.TyClD d -> f (GHC.L l d)
GHC.InstD d -> f (GHC.L l d)
GHC.DerivD d -> f (GHC.L l d)
GHC.ValD d -> f (GHC.L l d)
GHC.SigD d -> f (GHC.L l d)
GHC.DefD d -> f (GHC.L l d)
GHC.ForD d -> f (GHC.L l d)
GHC.WarningD d -> f (GHC.L l d)
GHC.AnnD d -> f (GHC.L l d)
GHC.RuleD d -> f (GHC.L l d)
GHC.VectD d -> f (GHC.L l d)
GHC.SpliceD d -> f (GHC.L l d)
GHC.DocD d -> f (GHC.L l d)
GHC.RoleAnnotD d -> f (GHC.L l d)
#if __GLASGOW_HASKELL__ < 711
GHC.QuasiQuoteD d -> f (GHC.L l d)
#endif
showGhc :: (GHC.Outputable a) => a -> String
showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags