1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE NamedFieldPuns #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeSynonymInstances #-}
11{-# LANGUAGE ViewPatterns #-}
12module Language.Haskell.GHC.ExactPrint.Types
13  ( -- * Core Types
14   Anns
15  , emptyAnns
16  , Annotation(..)
17  , annNone
18
19  , KeywordId(..)
20  , Comment(..)
21  -- * Positions
22  , Pos
23  , DeltaPos(..)
24  , deltaRow, deltaColumn
25  -- * AnnKey
26  , AnnSpan
27  , AnnKey(..)
28  , mkAnnKey
29  , AnnConName(..)
30  , annGetConstr
31#if __GLASGOW_HASKELL__ >= 900
32  , badRealSrcSpan
33#endif
34
35  -- * Other
36
37  , Rigidity(..)
38  , AstContext(..),AstContextSet,defaultACS
39  , ACS'(..)
40  , ListContexts(..)
41
42  -- * For managing compatibility
43  , Constraints
44
45  -- * GHC version compatibility
46  , GhcPs
47  , GhcRn
48  , GhcTc
49
50#if __GLASGOW_HASKELL__ > 804
51  , noExt
52#endif
53
54  -- * Internal Types
55  , LayoutStartCol(..)
56  , declFun
57
58  ) where
59
60import Data.Data (Data, Typeable, toConstr,cast)
61-- import Data.Generics
62
63import qualified GHC
64#if __GLASGOW_HASKELL__ >= 900
65import GHC.Data.FastString     as GHC
66import GHC.Driver.Session      as GHC
67import GHC.Types.SrcLoc        as GHC
68import GHC.Utils.Outputable    as GHC
69#else
70import qualified DynFlags      as GHC
71import qualified Outputable    as GHC
72#endif
73
74import qualified Data.Map as Map
75import qualified Data.Set as Set
76
77-- ---------------------------------------------------------------------
78
79#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900)
80type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a)
81#else
82type Constraints a = (Data a)
83#endif
84
85-- ---------------------------------------------------------------------
86
87-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted
88-- from an @AnnKeywordId@ because the annotation must be interleaved into the
89-- stream and does not have a well-defined position
90data Comment = Comment
91    {
92      commentContents   :: !String -- ^ The contents of the comment including separators
93
94    -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is
95    -- the thing we use to decide where in the output stream the comment should
96    -- go.
97    , commentIdentifier :: !AnnSpan -- ^ Needed to uniquely identify two comments with the same contents
98    , commentOrigin     :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
99    }
100  deriving (Eq,Typeable,Data,Ord)
101instance Show Comment where
102  show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")"
103
104instance GHC.Outputable Comment where
105  ppr x = GHC.text (show x)
106
107type Pos = (Int,Int)
108
109-- | A relative positions, row then column
110newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data)
111
112deltaRow, deltaColumn :: DeltaPos -> Int
113deltaRow (DP (r, _)) = r
114deltaColumn (DP (_, c)) = c
115
116
117-- | Marks the start column of a layout block.
118newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int }
119  deriving (Eq, Num)
120
121instance Show LayoutStartCol where
122  show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")"
123
124
125annNone :: Annotation
126annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing
127
128data Annotation = Ann
129  {
130    -- The first three fields relate to interfacing up into the AST
131    annEntryDelta      :: !DeltaPos
132    -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior
133    -- output was, including all annPriorComments (field below).
134  , annPriorComments   :: ![(Comment,  DeltaPos)]
135    -- ^ Comments coming after the last non-comment output of the preceding
136    -- element but before the SrcSpan being annotated by this Annotation. If
137    -- these are changed then annEntryDelta (field above) must also change to
138    -- match.
139  , annFollowingComments   :: ![(Comment,  DeltaPos)]
140    -- ^ Comments coming after the last output for the element subject to this
141    -- Annotation. These will only be added by AST transformations, and care
142    -- must be taken not to disturb layout of following elements.
143
144  -- The next three fields relate to interacing down into the AST
145  , annsDP             :: ![(KeywordId, DeltaPos)]
146    -- ^ Annotations associated with this element.
147#if __GLASGOW_HASKELL__ >= 900
148  , annSortKey         :: !(Maybe [GHC.RealSrcSpan])
149#else
150  , annSortKey         :: !(Maybe [GHC.SrcSpan])
151#endif
152    -- ^ Captures the sort order of sub elements. This is needed when the
153    -- sub-elements have been split (as in a HsLocalBind which holds separate
154    -- binds and sigs) or for infix patterns where the order has been
155    -- re-arranged. It is captured explicitly so that after the Delta phase a
156    -- SrcSpan is used purely as an index into the annotations, allowing
157    -- transformations of the AST including the introduction of new Located
158    -- items or re-arranging existing ones.
159  , annCapturedSpan    :: !(Maybe AnnKey)
160    -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of
161    -- elements which we must remember for the Print phase. e.g. the statements
162    -- in a HsLet or HsDo. These must be managed as a group because they all
163    -- need eo be vertically aligned for the Haskell layout rules, and this
164    -- guarantees this property in the presence of AST edits.
165
166  } deriving (Typeable,Eq)
167
168instance Show Annotation where
169  show (Ann dp comments fcomments ans sk csp)
170    = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " "
171        ++ show fcomments ++ " "
172        ++ show ans ++ " " ++ showGhc sk ++ " "
173        ++ showGhc csp ++ ")"
174
175
176-- | This structure holds a complete set of annotations for an AST
177type Anns = Map.Map AnnKey Annotation
178
179emptyAnns :: Anns
180emptyAnns = Map.empty
181
182-- | For every @Located a@, use the @SrcSpan@ and constructor name of
183-- a as the key, to store the standard annotation.
184-- These are used to maintain context in the AP and EP monads
185data AnnKey   = AnnKey AnnSpan AnnConName
186                  deriving (Eq, Ord, Data)
187
188-- | From GHC 9.0 the ParsedSource uses RealSrcSpan instead of SrcSpan.
189--   Compatibility type
190#if __GLASGOW_HASKELL__ >= 900
191type AnnSpan = GHC.RealSrcSpan
192#else
193type AnnSpan = GHC.SrcSpan
194#endif
195
196-- More compact Show instance
197instance Show AnnKey where
198  show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn
199
200
201#if __GLASGOW_HASKELL__ >= 900
202mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey
203mkAnnKeyPrim (GHC.L (GHC.RealSrcSpan l _) a) = AnnKey l (annGetConstr a)
204mkAnnKeyPrim (GHC.L _ a) = AnnKey badRealSrcSpan (annGetConstr a)
205#elif __GLASGOW_HASKELL__ > 806
206mkAnnKeyPrim :: (Constraints a)
207             => a -> AnnKey
208mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a)
209#else
210mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey
211mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a)
212#endif
213
214
215#if __GLASGOW_HASKELL__ >= 900
216badRealSrcSpan :: GHC.RealSrcSpan
217badRealSrcSpan = GHC.mkRealSrcSpan bad bad
218  where
219    bad = GHC.mkRealSrcLoc (GHC.fsLit "ghc-exactprint-nospan") 0 0
220#endif
221
222#if __GLASGOW_HASKELL__ <= 802
223type GhcPs = GHC.RdrName
224type GhcRn = GHC.Name
225type GhcTc = GHC.Id
226#else
227type GhcPs = GHC.GhcPs
228type GhcRn = GHC.GhcRn
229type GhcTc = GHC.GhcTc
230#endif
231
232
233#if __GLASGOW_HASKELL__ > 808
234noExt :: GHC.NoExtField
235noExt = GHC.NoExtField
236#elif __GLASGOW_HASKELL__ > 804
237noExt :: GHC.NoExt
238noExt = GHC.noExt
239#endif
240
241-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.
242#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900)
243mkAnnKey :: (Constraints a) => a -> AnnKey
244#else
245mkAnnKey :: (Data a) => GHC.Located a -> AnnKey
246#endif
247mkAnnKey ld =
248  case cast ld :: Maybe (GHC.LHsDecl GhcPs) of
249    Just d -> declFun mkAnnKeyPrim d
250    Nothing -> mkAnnKeyPrim ld
251
252-- Holds the name of a constructor
253data AnnConName = CN { unConName :: String }
254                 deriving (Eq, Ord, Data)
255
256-- More compact show instance
257instance Show AnnConName where
258  show (CN s) = "CN " ++ show s
259
260annGetConstr :: (Data a) => a -> AnnConName
261annGetConstr a = CN (show $ toConstr a)
262
263-- | The different syntactic elements which are not represented in the
264-- AST.
265data KeywordId = G GHC.AnnKeywordId  -- ^ A normal keyword
266               | AnnSemiSep          -- ^ A separating comma
267#if __GLASGOW_HASKELL__ >= 900
268               | AnnEofPos
269#endif
270#if __GLASGOW_HASKELL__ >= 800
271               | AnnTypeApp          -- ^ Visible type application annotation
272#endif
273               | AnnComment Comment
274               | AnnString String    -- ^ Used to pass information from
275                                     -- Delta to Print when we have to work
276                                     -- out details from the original
277                                     -- SrcSpan.
278#if __GLASGOW_HASKELL__ <= 710
279               | AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible.
280#endif
281               deriving (Eq, Ord, Data)
282
283instance Show KeywordId where
284  show (G gc)          = "(G " ++ show gc ++ ")"
285  show AnnSemiSep      = "AnnSemiSep"
286#if __GLASGOW_HASKELL__ >= 900
287  show AnnEofPos       = "AnnEofPos"
288#endif
289#if __GLASGOW_HASKELL__ >= 800
290  show AnnTypeApp      = "AnnTypeApp"
291#endif
292  show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"
293  show (AnnString s)   = "(AnnString " ++ s ++ ")"
294#if __GLASGOW_HASKELL__ <= 710
295  show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")"
296#endif
297
298-- ---------------------------------------------------------------------
299
300instance GHC.Outputable KeywordId where
301  ppr k     = GHC.text (show k)
302
303instance GHC.Outputable AnnConName where
304  ppr tr     = GHC.text (show tr)
305
306instance GHC.Outputable Annotation where
307  ppr a     = GHC.text (show a)
308
309instance GHC.Outputable AnnKey where
310  ppr a     = GHC.text (show a)
311
312instance GHC.Outputable DeltaPos where
313  ppr a     = GHC.text (show a)
314
315-- ---------------------------------------------------------------------
316--
317-- Flag used to control whether we use rigid or normal layout rules.
318-- NOTE: check is done via comparison of enumeration order, be careful with any changes
319data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
320{-
321
322Rigidity logic. The same type is used for two different things
323
3241. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies
325   NormalLayout - Layout should be captured unconditionally
326
327   RigidLayout - Layout should be captured or not depending on a parameter kept
328                 in the interpreter Read state
329
3302. As the controlling parameter for the optional (Rigid) layout
331
332The nett effect is the following, where flag is the hard-coded flag value in
333Annotate, and param is the interpreter param set when the interpreter is run
334
335   flag         |  param       | result
336   -------------+--------------+--------------------
337   NormalLayout |  either      | layout captured
338   RigidLayout  | NormalLayout | layout NOT captured
339   RigidLayout  | RigidLayout  | layout captured
340
341The flag is only used on HsIf and HsCase
342
343So
344
345   state                       | HsCase    | HsIf
346   ----------------------------|-----------+------
347   before rigidity flag (AZ)   | no layout | layout
348   param NormalLayout          | no layout | no layout
349   param RigidLayout           | layout    | layout
350   ----------------------------+-----------+-------
351   desired future HaRe         | no layout | layout
352   desired future apply-refact | layout    | layout
353-}
354
355-- ---------------------------------------------------------------------
356
357data ACS' a = ACS
358  { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should
359                            -- propagate down the AST. Removed when it hits zero
360  } deriving (Show)
361
362#if __GLASGOW_HASKELL__ >= 804
363instance Semigroup (ACS' AstContext) where
364  (<>) = mappend
365#endif
366
367instance Monoid (ACS' AstContext) where
368  mempty = ACS mempty
369  -- ACS a `mappend` ACS b = ACS (a `mappend` b)
370  ACS a `mappend` ACS b = ACS (Map.unionWith max a b)
371  -- For Data.Map, mappend == union, which is a left-biased replace for key collisions
372
373type AstContextSet = ACS' AstContext
374-- data AstContextSet = ACS
375--   { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should
376--                                      -- propagate down the AST. Removed when it
377--                                      -- hits zero
378--   } deriving (Show)
379
380defaultACS :: AstContextSet
381defaultACS = ACS Map.empty
382
383-- instance GHC.Outputable AstContextSet where
384instance (Show a) => GHC.Outputable (ACS' a) where
385  ppr x = GHC.text $ show x
386
387data AstContext = LambdaExpr
388                | CaseAlt
389                | NoPrecedingSpace
390                | HasHiding
391                | AdvanceLine
392                | NoAdvanceLine
393                | Intercalate -- This item may have a list separator following
394                | InIE -- possible 'type' or 'pattern'
395                | PrefixOp
396                | PrefixOpDollar
397                | InfixOp -- RdrName may be used as an infix operator
398                | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently
399                | ListItem -- Identifies subsequent elements of a list in layout
400                | TopLevel -- top level declaration
401                | NoDarrow
402                | AddVbar
403                | Deriving
404                | Parens -- TODO: Not currently used?
405                | ExplicitNeverActive
406                | InGadt
407                | InRecCon
408                | InClassDecl
409                | InSpliceDecl
410                | LeftMost -- Is this the leftmost operator in a chain of OpApps?
411                | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt
412                          -- TODO:AZ: do we actually need this?
413                          -- TODO:AZ this is actually tight prefix
414
415                -- Next four used to identify current list context
416                | CtxOnly
417                | CtxFirst
418                | CtxMiddle
419                | CtxLast
420                | CtxPos Int -- 0 for first, increasing for subsequent
421
422                -- Next are used in tellContext to push context up the tree
423                | FollowingLine
424                deriving (Eq, Ord, Show)
425
426
427data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) }
428  deriving (Eq,Show)
429
430-- ---------------------------------------------------------------------
431
432-- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD
433--                                    -- should not have blank lines after it
434--                 deriving (Eq, Ord, Show)
435
436-- ---------------------------------------------------------------------
437
438declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b
439
440#if __GLASGOW_HASKELL__ > 804
441declFun f (GHC.L l de) =
442  case de of
443      GHC.TyClD _ d       -> f (GHC.L l d)
444      GHC.InstD _ d       -> f (GHC.L l d)
445      GHC.DerivD _ d      -> f (GHC.L l d)
446      GHC.ValD _ d        -> f (GHC.L l d)
447      GHC.SigD _ d        -> f (GHC.L l d)
448#if __GLASGOW_HASKELL__ > 808
449      GHC.KindSigD _ d    -> f (GHC.L l d)
450#endif
451      GHC.DefD _ d        -> f (GHC.L l d)
452      GHC.ForD _ d        -> f (GHC.L l d)
453      GHC.WarningD _ d    -> f (GHC.L l d)
454      GHC.AnnD _ d        -> f (GHC.L l d)
455      GHC.RuleD _ d       -> f (GHC.L l d)
456      GHC.SpliceD _ d     -> f (GHC.L l d)
457      GHC.DocD _ d        -> f (GHC.L l d)
458      GHC.RoleAnnotD _ d  -> f (GHC.L l d)
459      GHC.XHsDecl _       -> error "declFun:XHsDecl"
460#else
461declFun f (GHC.L l de) =
462  case de of
463      GHC.TyClD d       -> f (GHC.L l d)
464      GHC.InstD d       -> f (GHC.L l d)
465      GHC.DerivD d      -> f (GHC.L l d)
466      GHC.ValD d        -> f (GHC.L l d)
467      GHC.SigD d        -> f (GHC.L l d)
468      GHC.DefD d        -> f (GHC.L l d)
469      GHC.ForD d        -> f (GHC.L l d)
470      GHC.WarningD d    -> f (GHC.L l d)
471      GHC.AnnD d        -> f (GHC.L l d)
472      GHC.RuleD d       -> f (GHC.L l d)
473      GHC.VectD d       -> f (GHC.L l d)
474      GHC.SpliceD d     -> f (GHC.L l d)
475      GHC.DocD d        -> f (GHC.L l d)
476      GHC.RoleAnnotD d  -> f (GHC.L l d)
477#if __GLASGOW_HASKELL__ < 711
478      GHC.QuasiQuoteD d -> f (GHC.L l d)
479#endif
480#endif
481
482-- ---------------------------------------------------------------------
483
484-- Duplicated here so it can be used in show instances
485showGhc :: (GHC.Outputable a) => a -> String
486showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
487
488-- ---------------------------------------------------------------------
489
490