Embrace -XTypeInType, add -XStarIsType
[ghc.git] / compiler / basicTypes / SrcLoc.hs
index 8e17561..eeba3d7 100644 (file)
@@ -1,10 +1,12 @@
 -- (c) The University of Glasgow, 1992-2006
 
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
-   -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
-   -- When the earliest compiler we want to boostrap with is
-   -- GHC 7.2, we can make RealSrcLoc properly abstract
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE DeriveFoldable     #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE RecordWildCards    #-}
 
 -- | This module contains types that relate to the positions of things
 -- in source files, and allow tagging of those things with locations
@@ -36,14 +38,16 @@ module SrcLoc (
         mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
         noSrcSpan,
         wiredInSrcSpan,         -- Something wired into the compiler
+        interactiveSrcSpan,
         srcLocSpan, realSrcLocSpan,
         combineSrcSpans,
+        srcSpanFirstCharacter,
 
         -- ** Deconstructing SrcSpan
         srcSpanStart, srcSpanEnd,
         realSrcSpanStart, realSrcSpanEnd,
         srcSpanFileName_maybe,
-        showUserSpan,
+        pprUserRealSpan,
 
         -- ** Unsafely deconstructing SrcSpan
         -- These are dubious exports, because they crash on some inputs
@@ -53,6 +57,7 @@ module SrcLoc (
 
         -- ** Predicates on SrcSpan
         isGoodSrcSpan, isOneLineSpan,
+        containsSpan,
 
         -- * Located
         Located,
@@ -72,10 +77,14 @@ module SrcLoc (
         spans, isSubspanOf, sortLocated
     ) where
 
+import GhcPrelude
+
 import Util
+import Json
 import Outputable
 import FastString
 
+import Control.DeepSeq
 import Data.Bits
 import Data.Data
 import Data.List
@@ -92,16 +101,20 @@ We keep information about the {\em definition} point for each entity;
 this is the obvious stuff:
 -}
 
--- | Represents a single point within a file
+-- | Real Source Location
+--
+-- Represents a single point within a file
 data RealSrcLoc
   = SrcLoc      FastString              -- A precise location (file name)
                 {-# UNPACK #-} !Int     -- line number, begins at 1
                 {-# UNPACK #-} !Int     -- column number, begins at 1
+  deriving (Eq, Ord)
 
+-- | Source Location
 data SrcLoc
   = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
   | UnhelpfulLoc FastString     -- Just a general indication
-  deriving Show
+  deriving (Eq, Ord, Show)
 
 {-
 ************************************************************************
@@ -121,7 +134,7 @@ mkRealSrcLoc x line col = SrcLoc x line col
 noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
 noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")
 generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")
-interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>")
+interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")
 
 -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
 mkGeneralSrcLoc :: FastString -> SrcLoc
@@ -156,36 +169,9 @@ advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)
 ************************************************************************
 -}
 
--- SrcLoc is an instance of Ord so that we can sort error messages easily
-instance Eq SrcLoc where
-  loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of
-                 EQ     -> True
-                 _other -> False
-
-instance Eq RealSrcLoc where
-  loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of
-                 EQ     -> True
-                 _other -> False
-
-instance Ord SrcLoc where
-  compare = cmpSrcLoc
-
-instance Ord RealSrcLoc where
-  compare = cmpRealSrcLoc
-
 sortLocated :: [Located a] -> [Located a]
 sortLocated things = sortBy (comparing getLoc) things
 
-cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
-cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
-cmpSrcLoc (UnhelpfulLoc _)  (RealSrcLoc _)    = GT
-cmpSrcLoc (RealSrcLoc _)    (UnhelpfulLoc _)  = LT
-cmpSrcLoc (RealSrcLoc l1)   (RealSrcLoc l2)   = (l1 `compare` l2)
-
-cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering
-cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
-  = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
-
 instance Outputable RealSrcLoc where
     ppr (SrcLoc src_path src_line src_col)
       = hcat [ pprFastFilePath src_path <> colon
@@ -227,7 +213,7 @@ instance Data SrcSpan where
 -}
 
 {- |
-A SrcSpan delimits a portion of a text file.  It could be represented
+A 'RealSrcSpan' delimits a portion of a text file.  It could be represented
 by a pair of (line,column) coordinates, but in fact we optimise
 slightly by using more compact representations for single-line and
 zero-length spans, both of which are quite common.
@@ -236,41 +222,50 @@ The end position is defined to be the column /after/ the end of the
 span.  That is, a span of (1,1)-(1,2) is one character long, and a
 span of (1,1)-(1,1) is zero characters long.
 -}
-data RealSrcSpan
-  = SrcSpanOneLine              -- a common case: a single line
-        { srcSpanFile     :: !FastString,
-          srcSpanLine     :: {-# UNPACK #-} !Int,
-          srcSpanSCol     :: {-# UNPACK #-} !Int,
-          srcSpanECol     :: {-# UNPACK #-} !Int
-        }
 
-  | SrcSpanMultiLine
+-- | Real Source Span
+data RealSrcSpan
+  = RealSrcSpan'
         { srcSpanFile     :: !FastString,
           srcSpanSLine    :: {-# UNPACK #-} !Int,
           srcSpanSCol     :: {-# UNPACK #-} !Int,
           srcSpanELine    :: {-# UNPACK #-} !Int,
           srcSpanECol     :: {-# UNPACK #-} !Int
         }
+  deriving Eq
 
-  | SrcSpanPoint
-        { srcSpanFile     :: !FastString,
-          srcSpanLine     :: {-# UNPACK #-} !Int,
-          srcSpanCol      :: {-# UNPACK #-} !Int
-        }
-  deriving (Eq, Typeable)
-
+-- | Source Span
+--
+-- A 'SrcSpan' identifies either a specific portion of a text file
+-- or a human-readable description of a location.
 data SrcSpan =
     RealSrcSpan !RealSrcSpan
   | UnhelpfulSpan !FastString   -- Just a general indication
                                 -- also used to indicate an empty span
 
-  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we
-                                -- derive Show for Token
+  deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
+                           -- derive Show for Token
+
+instance ToJson SrcSpan where
+  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
+  json (RealSrcSpan rss)  = json rss
+
+instance ToJson RealSrcSpan where
+  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
+                                     , ("startLine", JSInt srcSpanSLine)
+                                     , ("startCol", JSInt srcSpanSCol)
+                                     , ("endLine", JSInt srcSpanELine)
+                                     , ("endCol", JSInt srcSpanECol)
+                                     ]
+
+instance NFData SrcSpan where
+  rnf x = x `seq` ()
 
 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
-noSrcSpan, wiredInSrcSpan :: SrcSpan
-noSrcSpan      = UnhelpfulSpan (fsLit "<no location info>")
-wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>")
+noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
+noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")
+wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")
+interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")
 
 -- | Create a "bad" 'SrcSpan' that has not location information
 mkGeneralSrcSpan :: FastString -> SrcSpan
@@ -282,15 +277,11 @@ srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
 srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
 
 realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
-realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
+realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col
 
 -- | Create a 'SrcSpan' between two points in a file
 mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
-mkRealSrcSpan loc1 loc2
-  | line1 == line2 = if col1 == col2
-                        then SrcSpanPoint file line1 col1
-                        else SrcSpanOneLine file line1 col1 col2
-  | otherwise      = SrcSpanMultiLine file line1 col1 line2 col2
+mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
   where
         line1 = srcLocLine loc1
         line2 = srcLocLine loc2
@@ -298,6 +289,16 @@ mkRealSrcSpan loc1 loc2
         col2 = srcLocCol loc2
         file = srcLocFile loc1
 
+-- | 'True' if the span is known to straddle only one line.
+isOneLineRealSpan :: RealSrcSpan -> Bool
+isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
+  = line1 == line2
+
+-- | 'True' if the span is a single point
+isPointRealSpan :: RealSrcSpan -> Bool
+isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
+  = line1 == line2 && col1 == col2
+
 -- | Create a 'SrcSpan' between two points in a file
 mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
 mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
@@ -317,11 +318,7 @@ combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
 -- within both spans. Assumes the "file" part is the same in both inputs
 combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
 combineRealSrcSpans span1 span2
- = if line_start == line_end
-   then if col_start == col_end
-        then SrcSpanPoint     file line_start col_start
-        else SrcSpanOneLine   file line_start col_start col_end
-   else      SrcSpanMultiLine file line_start col_start line_end col_end
+  = RealSrcSpan' file line_start col_start line_end col_end
   where
     (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
                                   (srcSpanStartLine span2, srcSpanStartCol span2)
@@ -329,6 +326,14 @@ combineRealSrcSpans span1 span2
                                   (srcSpanEndLine span2, srcSpanEndCol span2)
     file = srcSpanFile span1
 
+-- | Convert a SrcSpan into one that represents only its first character
+srcSpanFirstCharacter :: SrcSpan -> SrcSpan
+srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l
+srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2
+  where
+    loc1@(SrcLoc f l c) = realSrcSpanStart span
+    loc2 = SrcLoc f l (c+1)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -348,9 +353,20 @@ isOneLineSpan :: SrcSpan -> Bool
 isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
 isOneLineSpan (UnhelpfulSpan _) = False
 
+-- | Tests whether the first span "contains" the other span, meaning
+-- that it covers at least as much source code. True where spans are equal.
+containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool
+containsSpan s1 s2
+  = (srcSpanStartLine s1, srcSpanStartCol s1)
+       <= (srcSpanStartLine s2, srcSpanStartCol s2)
+    && (srcSpanEndLine s1, srcSpanEndCol s1)
+       >= (srcSpanEndLine s2, srcSpanEndCol s2)
+    && (srcSpanFile s1 == srcSpanFile s2)
+    -- We check file equality last because it is (presumably?) least
+    -- likely to fail.
 {-
-************************************************************************
-*                                                                      *
+%************************************************************************
+%*                                                                      *
 \subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
 *                                                                      *
 ************************************************************************
@@ -361,21 +377,10 @@ srcSpanEndLine :: RealSrcSpan -> Int
 srcSpanStartCol :: RealSrcSpan -> Int
 srcSpanEndCol :: RealSrcSpan -> Int
 
-srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
-srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
-srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l
-
-srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l
-srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l
-srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l
-
-srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l
-srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l
-srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l
-
-srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
-srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
-srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
+srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l
+srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l
+srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l
+srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c
 
 {-
 ************************************************************************
@@ -418,11 +423,12 @@ srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
 ************************************************************************
 -}
 
--- We want to order SrcSpans first by the start point, then by the end point.
-instance Ord SrcSpan where
+-- We want to order RealSrcSpans first by the start point, then by the
+-- end point.
+instance Ord RealSrcSpan where
   a `compare` b =
-     (srcSpanStart a `compare` srcSpanStart b) `thenCmp`
-     (srcSpanEnd   a `compare` srcSpanEnd   b)
+     (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
+     (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)
 
 instance Show RealSrcLoc where
   show (SrcLoc filename row col)
@@ -430,14 +436,17 @@ instance Show RealSrcLoc where
 
 -- Show is used by Lexer.x, because we derive Show for Token
 instance Show RealSrcSpan where
-  show (SrcSpanOneLine file l sc ec)
+  show span@(RealSrcSpan' file sl sc el ec)
+    | isPointRealSpan span
+    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])
+
+    | isOneLineRealSpan span
     = "SrcSpanOneLine " ++ show file ++ " "
-                        ++ intercalate " " (map show [l,sc,ec])
-  show (SrcSpanMultiLine file sl sc el ec)
+                        ++ intercalate " " (map show [sl,sc,ec])
+
+    | otherwise
     = "SrcSpanMultiLine " ++ show file ++ " "
                           ++ intercalate " " (map show [sl,sc,el,ec])
-  show (SrcSpanPoint file l c)
-    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [l,c])
 
 
 instance Outputable RealSrcSpan where
@@ -463,23 +472,27 @@ instance Outputable SrcSpan where
 --           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
 --           RealSrcSpan s -> ppr s
 
-showUserSpan :: Bool -> SrcSpan -> String
-showUserSpan show_path span = showSDocSimple (pprUserSpan show_path span)
-
 pprUserSpan :: Bool -> SrcSpan -> SDoc
 pprUserSpan _         (UnhelpfulSpan s) = ftext s
 pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s
 
 pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
-pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col)
+pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)
+  | isPointRealSpan span
+  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
+         , int line <> colon
+         , int col ]
+
+pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)
+  | isOneLineRealSpan span
   = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
          , int line <> colon
-         , int start_col
-         , ppUnless (end_col - start_col <= 1) (char '-' <> int (end_col - 1)) ]
+         , int scol
+         , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]
             -- For single-character or point spans, we just
             -- output the starting column number
 
-pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
+pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
   = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
          , parens (int sline <> comma <> int scol)
          , char '-'
@@ -487,11 +500,6 @@ pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
  where
    ecol' = if ecol == 0 then ecol else ecol - 1
 
-pprUserRealSpan show_path (SrcSpanPoint src_path line col)
-  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
-         , int line <> colon
-         , int col ]
-
 {-
 ************************************************************************
 *                                                                      *
@@ -502,10 +510,10 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col)
 
 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
 data GenLocated l e = L l e
-  deriving (Eq, Ord, Typeable, Data)
+  deriving (Eq, Ord, Data, Functor, Foldable, Traversable)
 
-type Located e = GenLocated SrcSpan e
-type RealLocated e = GenLocated RealSrcSpan e
+type Located = GenLocated SrcSpan
+type RealLocated = GenLocated RealSrcSpan
 
 unLoc :: GenLocated l e -> e
 unLoc (L _ e) = e
@@ -538,15 +546,12 @@ eqLocated a b = unLoc a == unLoc b
 cmpLocated :: Ord a => Located a -> Located a -> Ordering
 cmpLocated a b = unLoc a `compare` unLoc b
 
-instance Functor (GenLocated l) where
-  fmap f (L l e) = L l (f e)
-
 instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
   ppr (L l e) = -- TODO: We can't do this since Located was refactored into
                 -- GenLocated:
                 -- Print spans without the file name etc
                 -- ifPprDebug (braces (pprUserSpan False l))
-                ifPprDebug (braces (ppr l))
+                whenPprDebug (braces (ppr l))
              $$ ppr e
 
 {-