-- Prints (if mod information is available) "Defined at <loc>" or
-- "Defined in <mod>" information for a Name.
pprNameLoc :: Name -> SDoc
-pprNameLoc name
- | isGoodSrcSpan loc = pprDefnLoc loc
- | isInternalName name || isSystemName name
- = ptext (sLit "<no location info>")
- | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name)
- where loc = nameSrcSpan name
+pprNameLoc name = case nameSrcSpan name of
+ RealSrcSpan s ->
+ pprDefnLoc s
+ UnhelpfulSpan _
+ | isInternalName name || isSystemName name ->
+ ptext (sLit "<no location info>")
+ | otherwise ->
+ ptext (sLit "Defined in ") <> ppr (nameModule name)
\end{code}
%************************************************************************
-- If we know the exact definition point (which we may do with GHCi)
-- then show that too. But not if it's just "imported from X".
ppr_defn :: SrcLoc -> SDoc
-ppr_defn loc | isGoodSrcLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
- | otherwise = empty
+ppr_defn (RealSrcLoc loc) = parens (ptext (sLit "defined at") <+> ppr loc)
+ppr_defn (UnhelpfulLoc _) = empty
instance Outputable ImportSpec where
ppr imp_spec
= ptext (sLit "imported from") <+> ppr (importSpecModule imp_spec)
- <+> if isGoodSrcSpan loc then ptext (sLit "at") <+> ppr loc
- else empty
+ <+> pprLoc
where
loc = importSpecLoc imp_spec
+ pprLoc = case loc of
+ RealSrcSpan s -> ptext (sLit "at") <+> ppr s
+ UnhelpfulSpan _ -> empty
\end{code}
-- in source files, and allow tagging of those things with locations
module SrcLoc (
-- * SrcLoc
- SrcLoc, -- Abstract
+ RealSrcLoc, -- Abstract
+ SrcLoc(..),
-- ** Constructing SrcLoc
- mkSrcLoc, mkGeneralSrcLoc,
+ mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
noSrcLoc, -- "I'm sorry, I haven't a clue"
generatedSrcLoc, -- Code generated within the compiler
-- ** Misc. operations on SrcLoc
pprDefnLoc,
-
- -- ** Predicates on SrcLoc
- isGoodSrcLoc,
-- * SrcSpan
- SrcSpan, -- Abstract
+ RealSrcSpan, -- Abstract
+ SrcSpan(..),
-- ** Constructing SrcSpan
- mkGeneralSrcSpan, mkSrcSpan,
+ mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
noSrcSpan,
wiredInSrcSpan, -- Something wired into the compiler
- srcLocSpan,
+ srcLocSpan, realSrcLocSpan,
combineSrcSpans,
-- ** Deconstructing SrcSpan
srcSpanStart, srcSpanEnd,
+ realSrcSpanStart, realSrcSpanEnd,
srcSpanFileName_maybe,
-- ** Unsafely deconstructing SrcSpan
isGoodSrcSpan, isOneLineSpan,
-- * Located
- Located(..),
+ Located,
+ RealLocated,
+ GenLocated(..),
-- ** Constructing Located
noLoc,
this is the obvious stuff:
\begin{code}
-- | Represents a single point within a file
-data SrcLoc
+data RealSrcLoc
= SrcLoc FastString -- A precise location (file name)
{-# UNPACK #-} !Int -- line number, begins at 1
{-# UNPACK #-} !Int -- column number, begins at 1
+
+data SrcLoc
+ = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
| UnhelpfulLoc FastString -- Just a general indication
\end{code}
\begin{code}
mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
-mkSrcLoc x line col = SrcLoc x line col
+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)
+
+mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
+mkRealSrcLoc x line col = SrcLoc x line col
-- | Built-in "bad" 'SrcLoc' values for particular locations
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
mkGeneralSrcLoc :: FastString -> SrcLoc
mkGeneralSrcLoc = UnhelpfulLoc
--- | "Good" 'SrcLoc's have precise information about their location
-isGoodSrcLoc :: SrcLoc -> Bool
-isGoodSrcLoc (SrcLoc _ _ _) = True
-isGoodSrcLoc _other = False
-
--- | Gives the filename of the 'SrcLoc' if it is available, otherwise returns a dummy value
-srcLocFile :: SrcLoc -> FastString
+-- | Gives the filename of the 'RealSrcLoc'
+srcLocFile :: RealSrcLoc -> FastString
srcLocFile (SrcLoc fname _ _) = fname
-srcLocFile _other = (fsLit "<unknown file")
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocLine :: SrcLoc -> Int
+srcLocLine :: RealSrcLoc -> Int
srcLocLine (SrcLoc _ l _) = l
-srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s)
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocCol :: SrcLoc -> Int
+srcLocCol :: RealSrcLoc -> Int
srcLocCol (SrcLoc _ _ c) = c
-srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s)
-- | Move the 'SrcLoc' down by one line if the character is a newline,
-- to the next 8-char tabstop if it is a tab, and across by one
-- character in any other case
-advanceSrcLoc :: SrcLoc -> Char -> SrcLoc
+advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1)
`shiftL` 3) + 1)
advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
-advanceSrcLoc loc _ = loc -- Better than nothing
\end{code}
%************************************************************************
-- 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
+ 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
+
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
-cmpSrcLoc (UnhelpfulLoc _) (SrcLoc _ _ _) = GT
-cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulLoc _) = LT
+cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT
+cmpSrcLoc (RealSrcLoc _) (UnhelpfulLoc _) = LT
+cmpSrcLoc (RealSrcLoc l1) (RealSrcLoc l2) = (l1 `compare` l2)
-cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
+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 SrcLoc where
+instance Outputable RealSrcLoc where
ppr (SrcLoc src_path src_line src_col)
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
hcat [text "{-# LINE ", int src_line, space,
char '\"', pprFastFilePath src_path, text " #-}"]
+instance Outputable SrcLoc where
+ ppr (RealSrcLoc l) = ppr l
ppr (UnhelpfulLoc s) = ftext s
+instance Data RealSrcSpan where
+ -- don't traverse?
+ toConstr _ = abstractConstr "RealSrcSpan"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "RealSrcSpan"
+
instance Data SrcSpan where
-- don't traverse?
toConstr _ = abstractConstr "SrcSpan"
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 SrcSpan
+data RealSrcSpan
= SrcSpanOneLine -- a common case: a single line
{ srcSpanFile :: !FastString,
srcSpanLine :: {-# UNPACK #-} !Int,
srcSpanLine :: {-# UNPACK #-} !Int,
srcSpanCol :: {-# UNPACK #-} !Int
}
+#ifdef DEBUG
+ deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
+ -- derive Show for Token
+#else
+ deriving (Eq, Typeable)
+#endif
+data SrcSpan =
+ RealSrcSpan !RealSrcSpan
| UnhelpfulSpan !FastString -- Just a general indication
-- also used to indicate an empty span
-- | Create a 'SrcSpan' corresponding to a single point
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
-srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
+srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
+
+realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
+realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
-- | Create a 'SrcSpan' between two points in a file
-mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
-mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
-mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
-mkSrcSpan loc1 loc2
+mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
+mkRealSrcSpan loc1 loc2
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
col2 = srcLocCol loc2
file = srcLocFile loc1
+-- | Create a 'SrcSpan' between two points in a file
+mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
+mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
+ = RealSrcSpan (mkRealSrcSpan loc1 loc2)
+
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
combineSrcSpans l (UnhelpfulSpan _) = l
-combineSrcSpans span1 span2
+combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
+ = RealSrcSpan (combineRealSrcSpans span1 span2)
+
+-- | Combines two 'SrcSpan' into one that spans at least all the characters
+-- 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
\begin{code}
-- | Test if a 'SrcSpan' is "good", i.e. has precise location information
isGoodSrcSpan :: SrcSpan -> Bool
-isGoodSrcSpan SrcSpanOneLine{} = True
-isGoodSrcSpan SrcSpanMultiLine{} = True
-isGoodSrcSpan SrcSpanPoint{} = True
-isGoodSrcSpan _ = False
+isGoodSrcSpan (RealSrcSpan _) = True
+isGoodSrcSpan (UnhelpfulSpan _) = False
isOneLineSpan :: SrcSpan -> Bool
-- ^ True if the span is known to straddle only one line.
-- For "bad" 'SrcSpan', it returns False
-isOneLineSpan s
- | isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s
- | otherwise = False
+isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
+isOneLineSpan (UnhelpfulSpan _) = False
\end{code}
\begin{code}
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanStartLine :: SrcSpan -> Int
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanEndLine :: SrcSpan -> Int
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanStartCol :: SrcSpan -> Int
--- | Raises an error when used on a "bad" 'SrcSpan'
-srcSpanEndCol :: SrcSpan -> Int
+srcSpanStartLine :: RealSrcSpan -> Int
+srcSpanEndLine :: RealSrcSpan -> Int
+srcSpanStartCol :: RealSrcSpan -> Int
+srcSpanEndCol :: RealSrcSpan -> Int
srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l
-srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine"
srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l
srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l
-srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine"
srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l
-srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol"
srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
-srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
\end{code}
-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanStart :: SrcSpan -> SrcLoc
+srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)
+
-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanEnd :: SrcSpan -> SrcLoc
+srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)
-srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
-srcSpanStart s = mkSrcLoc (srcSpanFile s)
- (srcSpanStartLine s)
- (srcSpanStartCol s)
+realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
+realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
+ (srcSpanStartLine s)
+ (srcSpanStartCol s)
-srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
-srcSpanEnd s =
- mkSrcLoc (srcSpanFile s)
- (srcSpanEndLine s)
- (srcSpanEndCol s)
+realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
+realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
+ (srcSpanEndLine s)
+ (srcSpanEndCol s)
-- | Obtains the filename for a 'SrcSpan' if it is "good"
srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
-srcSpanFileName_maybe (SrcSpanOneLine { srcSpanFile = nm }) = Just nm
-srcSpanFileName_maybe (SrcSpanMultiLine { srcSpanFile = nm }) = Just nm
-srcSpanFileName_maybe (SrcSpanPoint { srcSpanFile = nm}) = Just nm
-srcSpanFileName_maybe _ = Nothing
+srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s)
+srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
\end{code}
(srcSpanEnd a `compare` srcSpanEnd b)
-instance Outputable SrcSpan where
+instance Outputable RealSrcSpan where
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
- pprUserSpan True span
+ pprUserRealSpan True span
else
hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
+instance Outputable SrcSpan where
+ ppr span
+ = getPprStyle $ \ sty ->
+ if userStyle sty || debugStyle sty then
+ pprUserSpan True span
+ else
+ case span of
+ UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
+ RealSrcSpan s -> ppr s
+
pprUserSpan :: Bool -> SrcSpan -> SDoc
-pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col)
+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)
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, int line, char ':', int start_col
, ppUnless (end_col - start_col <= 1)
]
-pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
+pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
= hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
, parens (int sline <> char ',' <> int scol)
, char '-'
if ecol == 0 then int ecol else int (ecol-1))
]
-pprUserSpan show_path (SrcSpanPoint src_path line col)
+pprUserRealSpan show_path (SrcSpanPoint src_path line col)
= hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon)
, int line, char ':', int col ]
-pprUserSpan _ (UnhelpfulSpan s) = ftext s
-
-pprDefnLoc :: SrcSpan -> SDoc
+pprDefnLoc :: RealSrcSpan -> SDoc
-- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..."
-pprDefnLoc loc
- | isGoodSrcSpan loc = ptext (sLit "Defined at") <+> ppr loc
- | otherwise = ppr loc
+pprDefnLoc loc = ptext (sLit "Defined at") <+> ppr loc
\end{code}
%************************************************************************
\begin{code}
-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
-data Located e = L SrcSpan e
+data GenLocated l e = L l e
deriving (Eq, Ord, Typeable, Data)
-unLoc :: Located e -> e
+type Located e = GenLocated SrcSpan e
+type RealLocated e = GenLocated RealSrcSpan e
+
+unLoc :: GenLocated l e -> e
unLoc (L _ e) = e
-getLoc :: Located e -> SrcSpan
+getLoc :: GenLocated l e -> l
getLoc (L l _) = l
noLoc :: e -> Located e
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
-instance Functor Located where
+instance Functor (GenLocated l) where
fmap f (L l e) = L l (f e)
-instance Outputable e => Outputable (Located e) where
- ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) $$ ppr e
- -- Print spans without the file name etc
+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))
+ $$ ppr e
\end{code}
%************************************************************************
`thenCmp`
(srcSpanEnd b `compare` srcSpanEnd a)
-
-- | Determines whether a span encloses a given line and column index
spans :: SrcSpan -> (Int, Int) -> Bool
-spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
- where loc = mkSrcLoc (srcSpanFile span) l c
+spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
+spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
+ where loc = mkRealSrcLoc (srcSpanFile span) l c
-- | Determines whether a span is enclosed by another one
isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
-- -----------------------------------------------------------------------------
-- Lexer actions
-type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
+type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken)
begin :: Int -> Action
begin code _span _str _len = do pushLexState code; lexToken
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
- setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+ setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
-- trace ("setLine " ++ show line) $ do
popLexState
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
- setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
popLexState
pushLexState code
lexToken
cmmlex :: (Located CmmToken -> P a) -> P a
cmmlex cont = do
- tok@(L _ tok__) <- lexToken
- --trace ("token: " ++ show tok__) $ do
- cont tok
+ (L span tok) <- lexToken
+ --trace ("token: " ++ show tok) $ do
+ cont (L (RealSrcSpan span) tok)
-lexToken :: P (Located CmmToken)
+lexToken :: P (RealLocated CmmToken)
lexToken = do
inp@(loc1,buf) <- getInput
sc <- getLexState
case alexScan inp sc of
- AlexEOF -> do let span = mkSrcSpan loc1 loc1
+ AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
return (L span CmmT_EOF)
AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
lexToken
AlexToken inp2@(end,buf2) len t -> do
setInput inp2
- let span = mkSrcSpan loc1 end
+ let span = mkRealSrcSpan loc1 end
span `seq` setLastToken span len
t span buf len
-- Monad stuff
-- Stuff that Alex needs to know about our input type:
-type AlexInput = (SrcLoc,StringBuffer)
+type AlexInput = (RealSrcLoc,StringBuffer)
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (_,s) = prevChar s '\n'
showPass dflags "ParseCmm"
buf <- hGetStringBuffer filename
let
- init_loc = mkSrcLoc (mkFastString filename) 1 1
+ init_loc = mkRealSrcLoc (mkFastString filename) 1 1
init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
-- | A module concerned with finding the free variables of an expression.
module CoreFVs (
-- * Free variables of expressions and binding groups
- exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
- exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
- exprsFreeVars, -- [CoreExpr] -> VarSet
- bindFreeVars, -- CoreBind -> VarSet
+ exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
+ exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids
+ exprsFreeVars, -- [CoreExpr] -> VarSet
+ bindFreeVars, -- CoreBind -> VarSet
-- * Selective free variables of expressions
InterestingVarFun,
- exprSomeFreeVars, exprsSomeFreeVars,
+ exprSomeFreeVars, exprsSomeFreeVars,
-- * Free variables of Rules, Vars and Ids
varTypeTyVars, varTypeTcTyVars,
- idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+ idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
- ruleRhsFreeVars, rulesFreeVars,
- ruleLhsOrphNames, ruleLhsFreeIds,
+ ruleRhsFreeVars, rulesFreeVars,
+ ruleLhsOrphNames, ruleLhsFreeIds,
+ vectsFreeVars,
-- * Core syntax tree annotation with free variables
- CoreExprWithFVs, -- = AnnExpr Id VarSet
- CoreBindWithFVs, -- = AnnBind Id VarSet
- freeVars, -- CoreExpr -> CoreExprWithFVs
- freeVarsOf -- CoreExprWithFVs -> IdSet
+ CoreExprWithFVs, -- = AnnExpr Id VarSet
+ CoreBindWithFVs, -- = AnnBind Id VarSet
+ freeVars, -- CoreExpr -> CoreExprWithFVs
+ freeVarsOf -- CoreExprWithFVs -> IdSet
) where
#include "HsVersions.h"
\end{code}
%************************************************************************
-%* *
+%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%* *
+%* *
%************************************************************************
\begin{code}
ruleRhsFreeVars :: CoreRule -> VarSet
ruleRhsFreeVars (BuiltinRule {}) = noFVs
ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
- = delFromUFM fvs fn -- Note [Rule free var hack]
+ = delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
ruleFreeVars :: CoreRule -> VarSet
ruleFreeVars (BuiltinRule {}) = noFVs
ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
- = delFromUFM fvs fn -- Note [Rule free var hack]
+ = delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
, ru_rhs = rhs, ru_act = act })
| is_active act
- -- See Note [Finding rule RHS free vars] in OccAnal.lhs
- = delFromUFM fvs fn -- Note [Rule free var hack]
+ -- See Note [Finding rule RHS free vars] in OccAnal.lhs
+ = delFromUFM fvs fn -- Note [Rule free var hack]
where
fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
get_fvs _ = noFVs
= addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
\end{code}
+
Note [Rule free var hack]
~~~~~~~~~~~~~~~~~~~~~~~~~
Don't include the Id in its own rhs free-var set.
Otherwise the occurrence analyser makes bindings recursive
that shoudn't be. E.g.
- RULE: f (f x y) z ==> f x (f y z)
+ RULE: f (f x y) z ==> f x (f y z)
Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM.
+
+\begin{code}
+-- |Free variables of a vectorisation declaration
+vectsFreeVars :: [CoreVect] -> VarSet
+vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
+ where
+ vectFreeVars (Vect _ Nothing) = noFVs
+ vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
+\end{code}
+
+
%************************************************************************
-%* *
+%* *
\section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%* *
+%* *
%************************************************************************
The free variable pass annotates every node in the expression with its
-- - Rules for *imported* Ids never change ru_fn
-- - Rules for *local* Ids are in the IdInfo for that Id,
-- and the ru_fn field is simply replaced by the new name
--- of the Id
+-- of the Id
substRule _ _ rule@(BuiltinRule {}) = rule
substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
, ru_fn = fn_name, ru_rhs = rhs
, ru_local = is_local })
= rule { ru_bndrs = bndrs',
- ru_fn = if is_local
- then subst_ru_fn fn_name
- else fn_name,
- ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
+ ru_fn = if is_local
+ then subst_ru_fn fn_name
+ else fn_name,
+ ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
ru_rhs = simpleOptExprWith subst' rhs }
-- Do simple optimisation on RHS, in case substitution lets
-- you improve it. The real simplifier never gets to look at it.
(subst', bndrs') = substBndrs subst bndrs
------------------
+substVects :: Subst -> [CoreVect] -> [CoreVect]
+substVects subst = map (substVect subst)
+
+------------------
+substVect :: Subst -> CoreVect -> CoreVect
+substVect _subst (Vect v Nothing) = Vect v Nothing
+substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs))
+
+------------------
substVarSet :: Subst -> VarSet -> VarSet
substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
subst_fv subst fv
- | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
- | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
+ | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
+ | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
\end{code}
Note [Worker inlining]
simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
----------------------
-simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule])
-simpleOptPgm dflags binds rules
+simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> [CoreVect]
+ -> IO ([CoreBind], [CoreRule], [CoreVect])
+simpleOptPgm dflags binds rules vects
= do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
- (pprCoreBindings occ_anald_binds);
+ (pprCoreBindings occ_anald_binds);
- ; return (reverse binds', substRulesForImportedIds subst' rules) }
+ ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
where
occ_anald_binds = occurAnalysePgm Nothing {- No rules active -}
- rules binds
+ rules vects binds
(subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
do_one (subst, binds') bind
allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
isGoodSrcSpan' :: SrcSpan -> Bool
-isGoodSrcSpan' pos
- | not (isGoodSrcSpan pos) = False
- | start == end = False
- | otherwise = True
- where
- start = srcSpanStart pos
- end = srcSpanEnd pos
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
mkHpcPos :: SrcSpan -> HpcPos
-mkHpcPos pos
- | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
- | otherwise = hpcPos
- where
- start = srcSpanStart pos
- end = srcSpanEnd pos
- hpcPos = toHpcPos ( srcLocLine start
- , srcLocCol start
- , srcLocLine end
- , srcLocCol end - 1
- )
+mkHpcPos pos@(RealSrcSpan s)
+ | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
+ srcSpanStartCol s,
+ srcSpanEndLine s,
+ srcSpanEndCol s)
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
hpcSrcSpan :: SrcSpan
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do
+ Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
- { -- Add export flags to bindings
- keep_alive <- readIORef keep_var
- ; let (rules_for_locals, rules_for_imps)
+ { -- Add export flags to bindings
+ keep_alive <- readIORef keep_var
+ ; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
final_prs = addExportFlagsAndRules target
- export_set keep_alive rules_for_locals (fromOL all_prs)
+ export_set keep_alive rules_for_locals (fromOL all_prs)
final_pgm = combineEvBinds ds_ev_binds final_prs
- -- Notice that we put the whole lot in a big Rec, even the foreign binds
- -- When compiling PrelFloat, which defines data Float = F# Float#
- -- we want F# to be in scope in the foreign marshalling code!
- -- You might think it doesn't matter, but the simplifier brings all top-level
- -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+ -- Notice that we put the whole lot in a big Rec, even the foreign binds
+ -- When compiling PrelFloat, which defines data Float = F# Float#
+ -- we want F# to be in scope in the foreign marshalling code!
+ -- You might think it doesn't matter, but the simplifier brings all top-level
+ -- things into the in-scope set before simplifying; so we get no unfolding for F#!
- -- Lint result if necessary, and print
+ -- Lint result if necessary, and print
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
(vcat [ pprCoreBindings final_pgm
, pprRules rules_for_imps ])
- ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
- -- The simpleOptPgm gets rid of type
- -- bindings plus any stupid dead code
+ ; (ds_binds, ds_rules_for_imps, ds_vects)
+ <- simpleOptPgm dflags final_pgm rules_for_imps vects0
+ -- The simpleOptPgm gets rid of type
+ -- bindings plus any stupid dead code
- ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
+ ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
- ; deps <- mkDependencies tcg_env
+ ; deps <- mkDependencies tcg_env
; let mod_guts = ModGuts {
mg_module = mod,
import Outputable
import FastString
-import SrcLoc ( Located(..), noLoc )
+import SrcLoc
import Data.Data
\end{code}
-- others:
import IfaceSyn ( IfaceBinding )
import Outputable
-import SrcLoc ( Located(..) )
+import SrcLoc
import Module ( Module, ModuleName )
import FastString
compareFixity,
-- ** Source locations
- SrcLoc, pprDefnLoc,
- mkSrcLoc, isGoodSrcLoc, noSrcLoc,
+ SrcLoc(..), RealSrcLoc, pprDefnLoc,
+ mkSrcLoc, noSrcLoc,
srcLocFile, srcLocLine, srcLocCol,
- SrcSpan,
+ SrcSpan(..), RealSrcSpan,
mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
srcSpanStart, srcSpanEnd,
srcSpanFile,
srcSpanStartCol, srcSpanEndCol,
-- ** Located
- Located(..),
+ GenLocated(..), Located,
-- *** Constructing Located
noLoc, mkGeneralLocated,
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
getRichTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
- let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
+ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
-- tokens.
-addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
addSourceToTokens loc buf (t@(L span _) : ts)
- | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
- | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
- where
- (newLoc, newBuf, str) = go "" loc buf
- start = srcSpanStart span
- end = srcSpanEnd span
- go acc loc buf | loc < start = go acc nLoc nBuf
- | start <= loc && loc < end = go (ch:acc) nLoc nBuf
- | otherwise = (loc, buf, reverse acc)
- where (ch, nBuf) = nextChar buf
- nLoc = advanceSrcLoc loc ch
+ = case span of
+ UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
+ RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
+ where
+ (newLoc, newBuf, str) = go "" loc buf
+ start = realSrcSpanStart s
+ end = realSrcSpanEnd s
+ go acc loc buf | loc < start = go acc nLoc nBuf
+ | start <= loc && loc < end = go (ch:acc) nLoc nBuf
+ | otherwise = (loc, buf, reverse acc)
+ where (ch, nBuf) = nextChar buf
+ nLoc = advanceSrcLoc loc ch
-- | Take a rich token stream such as produced from 'getRichTokenStream' and
-- insignificant whitespace.)
showRichTokenStream :: [(Located Token, String)] -> String
showRichTokenStream ts = go startLoc ts ""
- where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
- startLoc = mkSrcLoc sourceFile 1 1
+ where sourceFile = getFile $ map (getLoc . fst) ts
+ getFile [] = panic "showRichTokenStream: No source file found"
+ getFile (UnhelpfulSpan _ : xs) = getFile xs
+ getFile (RealSrcSpan s : _) = srcSpanFile s
+ startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
go loc ((L span _, str):ts)
- | not (isGoodSrcSpan span) = go loc ts
- | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
- . (str ++)
- . go tokEnd ts
- | otherwise = ((replicate (tokLine - locLine) '\n') ++)
- . ((replicate tokCol ' ') ++)
- . (str ++)
- . go tokEnd ts
- where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
- (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
- tokEnd = srcSpanEnd span
+ = case span of
+ UnhelpfulSpan _ -> go loc ts
+ RealSrcSpan s
+ | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
+ . (str ++)
+ . go tokEnd ts
+ | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
+ . ((replicate tokCol ' ') ++)
+ . (str ++)
+ . go tokEnd ts
+ where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
+ (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
+ tokEnd = realSrcSpanEnd s
-- -----------------------------------------------------------------------------
-- Interactive evaluation
parser str dflags filename =
let
- loc = mkSrcLoc (mkFastString filename) 1 1
+ loc = mkRealSrcLoc (mkFastString filename) 1 1
buf = stringToStringBuffer str
in
case unP Parser.parseModule (mkPState dflags buf loc) of
-> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
- let loc = mkSrcLoc (mkFastString filename) 1 1
+ let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
PFailed span err -> parseError span err
POk pst rdr_module -> do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
- loc = mkSrcLoc (mkFastString filename) 1 1
+ loc = mkRealSrcLoc (mkFastString filename) 1 1
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
- | otherwise -> return [L (last_loc state) ITeof]
+ | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
-- parser assumes an ITeof sentinel at the end
getMore :: Handle -> PState -> IO [Located Token]
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
- loc = mkSrcLoc (mkFastString filename) 1 1
+ loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer return) state of
POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
- _ -> [L (last_loc state) ITeof]
+ _ -> [L (RealSrcSpan (last_loc state)) ITeof]
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
- let loc = mkSrcLoc (mkFastString src_filename) 1 1
+ let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
case unP parseModule (mkPState dflags buf loc) of
PFailed span err ->
liftIO $ showPass dflags "Parser"
let buf = stringToStringBuffer str
- loc = mkSrcLoc (fsLit source) linenumber 1
+ loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
import Maybes ( orElse, expectJust, catMaybes )
import Outputable
import BreakArray
-import SrcLoc ( SrcSpan, Located(..) )
+import SrcLoc
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString
where
hide pkg = pkg{ exposed = False }
+-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
munge_urls = map munge_url
munge_path p
- | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
- | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
+ | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
+ | otherwise = p
munge_url p
- | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
- | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
+ | otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
- ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
-
- stripVarPrefix var (root:path')
- | Just [sep] <- stripPrefix var root
- , isPathSeparator sep
- = Just (joinPath path')
-
- stripVarPrefix _ _ = Nothing
+ ++ FilePath.Posix.joinPath
+ (r : -- We need to drop a leading "/" or "\\"
+ -- if there is one:
+ dropWhile (all isPathSeparator)
+ (FilePath.splitDirectories p))
+
+ -- We could drop the separator here, and then use </> above. However,
+ -- by leaving it in and using ++ we keep the same path separator
+ -- rather than letting FilePath change it to use \ as the separator
+ stripVarPrefix var path = case stripPrefix var path of
+ Just [] -> Just []
+ Just cs@(c : _) | isPathSeparator c -> Just cs
+ _ -> Nothing
-- -----------------------------------------------------------------------------
-- definition, with some hand-coded bits.
--
-- Completely accurate information about token-spans within the source
--- file is maintained. Every token has a start and end SrcLoc attached to it.
+-- file is maintained. Every token has a start and end RealSrcLoc
+-- attached to it.
--
-----------------------------------------------------------------------------
| ITparenEscape -- $(
| ITvarQuote -- '
| ITtyQuote -- ''
- | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
+ | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|]
-- Arrow notation extension
| ITproc
-- -----------------------------------------------------------------------------
-- Lexer actions
-type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
+type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
special :: Token -> Action
special tok span _buf _len = return (L span tok)
Layout prev_off : _ -> prev_off < offset
_ -> True
if isOK then pop_and open_brace span buf len
- else failSpanMsgP span (text "Missing block")
+ else failSpanMsgP (RealSrcSpan span) (text "Missing block")
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
nested comments require traversing by hand, they can't be parsed
using regular expressions.
-}
-nested_comment :: P (Located Token) -> Action
+nested_comment :: P (RealLocated Token) -> Action
nested_comment cont span _str _len = do
input <- getInput
go "" (1::Int) input
Just (_,_) -> go ('\123':commentAcc) input docType False
Just (c,input) -> go (c:commentAcc) input docType False
-withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token))
- -> P (Located Token)
+withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
+ -> P (RealLocated Token)
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
-- called afterwards, so it can just update the state.
docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
- SrcSpan -> P (Located Token)
+ RealSrcSpan -> P (RealLocated Token)
docCommentEnd input commentAcc docType buf span = do
setInput input
let (AI loc nextBuf) = input
comment = reverse commentAcc
- span' = mkSrcSpan (srcSpanStart span) loc
+ span' = mkRealSrcSpan (realSrcSpanStart span) loc
last_len = byteDiff buf nextBuf
span `seq` setLastToken span' last_len
return (L span' (docType comment))
-errBrace :: AlexInput -> SrcSpan -> P a
-errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
+errBrace :: AlexInput -> RealSrcSpan -> P a
+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
open_brace, close_brace :: Action
open_brace span _str _len = do
varsym = sym ITvarsym
consym = sym ITconsym
-sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int
- -> P (Located Token)
+sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
+ -> P (RealLocated Token)
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword,exts) -> do
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
- setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+ setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
_ <- popLexState
pushLexState code
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
- setAlrLastLoc noSrcSpan
- setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ setAlrLastLoc $ alrInitialLoc file
+ setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
_ <- popLexState
pushLexState code
lexToken
+alrInitialLoc :: FastString -> RealSrcSpan
+alrInitialLoc file = mkRealSrcSpan loc loc
+ where -- This is a hack to ensure that the first line in a file
+ -- looks like it is after the initial location:
+ loc = mkRealSrcLoc file (-1) (-1)
-- -----------------------------------------------------------------------------
-- Options, includes and language pragmas.
start <- getSrcLoc
tok <- go [] input
end <- getSrcLoc
- return (L (mkSrcSpan start end) tok)
+ return (L (mkRealSrcSpan start end) tok)
where go acc input
= if isString input "#-}"
then do setInput input
= case alexGetChar i of
Just (c,i') | c == x -> isString i' xs
_other -> False
- err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
+ err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
-- -----------------------------------------------------------------------------
lex_string_tok span _buf _len = do
tok <- lex_string ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end) tok)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok)
lex_string :: String -> P Token
lex_string s = do
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
- let loc = srcSpanStart span
+ let loc = realSrcSpanStart span
case alexGetChar' i1 of
Nothing -> lit_error i1
th_exts <- extension thEnabled
if th_exts then do
setInput i2
- return (L (mkSrcSpan loc end2) ITtyQuote)
+ return (L (mkRealSrcSpan loc end2) ITtyQuote)
else lit_error i1
Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash
-- If TH is on, just parse the quote only
th_exts <- extension thEnabled
let (AI end _) = i1
- if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
+ if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
else lit_error i2
-finish_char_tok :: SrcLoc -> Char -> P (Located Token)
+finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- extension magicHashEnabled
case alexGetChar' i of
Just ('#',i@(AI end _)) -> do
setInput i
- return (L (mkSrcSpan loc end) (ITprimchar ch))
+ return (L (mkRealSrcSpan loc end) (ITprimchar ch))
_other ->
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
else do
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
isAny :: Char -> Bool
isAny c | c > '\x7f' = isPrint c
quoteStart <- getSrcLoc
quote <- lex_quasiquote ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end)
(ITquasiQuote (mkFastString quoter,
mkFastString (reverse quote),
- mkSrcSpan quoteStart end)))
+ mkRealSrcSpan quoteStart end)))
lex_quasiquote :: String -> P String
lex_quasiquote s = do
warn :: DynFlag -> SDoc -> Action
warn option warning srcspan _buf _len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
lexToken
warnThen :: DynFlag -> SDoc -> Action -> Action
warnThen option warning action srcspan buf len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
action srcspan buf len
-- -----------------------------------------------------------------------------
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
- last_loc :: SrcSpan, -- pos of previous token
+ last_loc :: RealSrcSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
- loc :: SrcLoc, -- current loc (end of prev token + 1)
+ loc :: RealSrcLoc, -- current loc (end of prev token + 1)
extsBitmap :: !Int, -- bitmap that determines permitted extensions
context :: [LayoutContext],
lex_state :: [Int],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
- alr_pending_implicit_tokens :: [Located Token],
+ alr_pending_implicit_tokens :: [RealLocated Token],
-- This is the next token to be considered or, if it is Nothing,
-- we need to get the next token from the input stream:
- alr_next_token :: Maybe (Located Token),
+ alr_next_token :: Maybe (RealLocated Token),
-- This is what we consider to be the locatino of the last token
-- emitted:
- alr_last_loc :: SrcSpan,
+ alr_last_loc :: RealSrcSpan,
-- The stack of layout contexts:
alr_context :: [ALRContext],
-- Are we expecting a '{'? If it's Just, then the ALRLayout tells
PFailed span err -> PFailed span err
failP :: String -> P a
-failP msg = P $ \s -> PFailed (last_loc s) (text msg)
+failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
failMsgP :: String -> P a
-failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
+failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
-failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
-failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
+failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg = P $ \_ -> PFailed span msg
setExts :: (Int -> Int) -> P ()
setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
-setSrcLoc :: SrcLoc -> P ()
+setSrcLoc :: RealSrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
-getSrcLoc :: P SrcLoc
+getSrcLoc :: P RealSrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
-setLastToken :: SrcSpan -> Int -> P ()
+setLastToken :: RealSrcSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
last_len=len
} ()
-data AlexInput = AI SrcLoc StringBuffer
+data AlexInput = AI RealSrcLoc StringBuffer
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (AI _ buf) = prevChar buf '\n'
getLexState :: P Int
getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
-popNextToken :: P (Maybe (Located Token))
+popNextToken :: P (Maybe (RealLocated Token))
popNextToken
= P $ \s@PState{ alr_next_token = m } ->
POk (s {alr_next_token = Nothing}) m
([],Nothing) -> return impt
_other -> return True
-setAlrLastLoc :: SrcSpan -> P ()
+setAlrLastLoc :: RealSrcSpan -> P ()
setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
-getAlrLastLoc :: P SrcSpan
+getAlrLastLoc :: P RealSrcSpan
getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
getALRContext :: P [ALRContext]
setJustClosedExplicitLetBlock b
= P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
-setNextToken :: Located Token -> P ()
+setNextToken :: RealLocated Token -> P ()
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
implicitTokenPending :: P Bool
[] -> POk s False
_ -> POk s True
-popPendingImplicitToken :: P (Maybe (Located Token))
+popPendingImplicitToken :: P (Maybe (RealLocated Token))
popPendingImplicitToken
= P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
case ts of
[] -> POk s Nothing
(t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
-setPendingImplicitTokens :: [Located Token] -> P ()
+setPendingImplicitTokens :: [RealLocated Token] -> P ()
setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
getAlrExpectingOCurly :: P (Maybe ALRLayout)
-- PState for parsing options pragmas
--
-pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
pragState dynflags buf loc = (mkPState dynflags buf loc) {
lex_state = [bol, option_prags, 0]
}
-- create a parse state
--
-mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
messages = emptyMessages,
- last_loc = mkSrcSpan loc loc,
+ last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
extsBitmap = fromIntegral bitmap,
lex_state = [bol, 0],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
- alr_last_loc = noSrcSpan,
+ alr_last_loc = alrInitialLoc (fsLit "<no file>"),
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False
last_len = len, last_loc = last_loc }) ->
case ctx of
(_:tl) -> POk s{ context = tl } ()
- [] -> PFailed last_loc (srcParseErr buf len)
+ [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- Push a new layout context at the indentation of the last token read.
-- This is only used at the outer level of a module when the 'module'
srcParseFail :: P a
srcParseFail = P $ \PState{ buffer = buf, last_len = len,
last_loc = last_loc } ->
- PFailed last_loc (srcParseErr buf len)
+ PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
lexer cont = do
alr <- extension alternativeLayoutRule
let lexTokenFun = if alr then lexTokenAlr else lexToken
- tok@(L _span _tok__) <- lexTokenFun
- --trace ("token: " ++ show _tok__) $ do
- cont tok
+ (L span tok) <- lexTokenFun
+ --trace ("token: " ++ show tok) $ do
+ cont (L (RealSrcSpan span) tok)
-lexTokenAlr :: P (Located Token)
+lexTokenAlr :: P (RealLocated Token)
lexTokenAlr = do mPending <- popPendingImplicitToken
t <- case mPending of
Nothing ->
_ -> return ()
return t
-alternativeLayoutRuleToken :: Located Token -> P (Located Token)
+alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
alternativeLayoutRuleToken t
= do context <- getALRContext
lastLoc <- getAlrLastLoc
let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
- newLine = (lastLoc == noSrcSpan)
- || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
+ newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
case (unLoc t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- thisLoc
+ (RealSrcSpan thisLoc)
(transitionalAlternativeLayoutWarning
"`where' clause at the same depth as implicit layout block")
setALRContext ls
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- thisLoc
+ (RealSrcSpan thisLoc)
(transitionalAlternativeLayoutWarning
"`|' at the same depth as implicit layout block")
setALRContext ls
topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
-lexToken :: P (Located Token)
+lexToken :: P (RealLocated Token)
lexToken = do
inp@(AI loc1 buf) <- getInput
sc <- getLexState
exts <- getExts
case alexScanUser exts inp sc of
AlexEOF -> do
- let span = mkSrcSpan loc1 loc1
+ let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
lexToken
AlexToken inp2@(AI end buf2) _ t -> do
setInput inp2
- let span = mkSrcSpan loc1 end
+ let span = mkRealSrcSpan loc1 end
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
t span buf bytes
-reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a
+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
reportLexError loc1 loc2 buf str
| atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
| otherwise =
then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
-lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
+lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState
where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
initState = mkPState dflags' buf loc
)
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
-import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
- SrcSpan, combineLocs, srcLocFile,
- mkSrcLoc, mkSrcSpan )
+import SrcLoc
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, liftedTypeKind, unliftedTypeKind )
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
- in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+ in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
where
pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = quotes (ppr rdr) <+> -- Locally defined
- parens (ptext (sLit "line") <+> int (srcSpanStartLine loc))
+ parens (ptext (sLit "line") <+> int (srcSpanStartLine loc'))
+ where loc' = case loc of
+ UnhelpfulSpan _ ->
+ panic "unknownNameSuggestErr UnhelpfulSpan"
+ RealSrcSpan l -> l
pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
import TcRnTypes
import HsSyn
-import SrcLoc ( Located(..) )
+import SrcLoc
rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
-import SrcLoc ( Located(..), unLoc )
+import SrcLoc
\end{code}
%************************************************************************
; ifDOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
where
- explicit_import (L loc _) = isGoodSrcSpan loc
+ explicit_import (L loc _) = case loc of
+ UnhelpfulSpan _ -> False
+ RealSrcSpan _ -> True
-- Filter out the implicit Prelude import
-- which we do not want to bleat about
\end{code}
Here's the externally-callable interface:
\begin{code}
-occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
+occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect]
-> [CoreBind] -> [CoreBind]
-occurAnalysePgm active_rule imp_rules binds
+occurAnalysePgm active_rule imp_rules vects binds
= snd (go (initOccEnv active_rule imp_rules) binds)
where
- initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)
- -- The RULES keep things alive!
+ initial_uds = addIdOccs emptyDetails
+ (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects)
+ -- The RULES and VECTORISE declarations keep things alive!
go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
go _ []
= do {
-- Occurrence analysis
let { tagged_binds = {-# SCC "OccAnal" #-}
- occurAnalysePgm active_rule rules binds } ;
+ occurAnalysePgm active_rule rules [] binds } ;
Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
, ptext (sLit "(or you compiled its defining module without -O)")])
--------------
-tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId]
+tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
tcVectDecls decls
= do { decls' <- mapM (wrapLocM tcVect) decls
; let ids = [unLoc id | L _ (HsVect id _) <- decls']
dups = findDupsEq (==) ids
; mapM_ reportVectDups dups
+ ; traceTcConstraints "End of tcVectDecls"
; return decls'
}
where
tcVect (HsVect name Nothing)
= addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name
- ; return (HsVect id Nothing)
+ ; return $ HsVect id Nothing
}
tcVect (HsVect name@(L loc _) (Just rhs))
= addErrCtxt (vectCtxt name) $
; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
; traceTc "tcVect inferred type" $ ppr (varType id')
+ ; traceTc "tcVect bindings" $ ppr binds
- -- add the type variable and dictionary bindings produced by type generalisation to the
- -- right-hand side of the vectorisation declaration
+ -- add all bindings, including the type variable and dictionary bindings produced by type
+ -- generalisation to the right-hand side of the vectorisation declaration
; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
; let [bind'] = bagToList actualBinds
MatchGroup
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-setSrcSpan loc thing_inside
- | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
- | otherwise = thing_inside -- Don't overwrite useful info with useless
+setSrcSpan loc@(RealSrcSpan _) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
+-- Don't overwrite useful info with useless:
+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
= do { lie_var <- newTcRef emptyWC ;
- res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
- thing_inside ;
- lie <- readTcRef lie_var ;
- return (res, lie) }
+ res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
+ thing_inside ;
+ lie <- readTcRef lie_var ;
+ return (res, lie) }
captureUntouchables :: TcM a -> TcM (a, Untouchables)
captureUntouchables thing_inside
= updLclEnv upd thing_inside
where
upd env = env { tcl_env = tcl_env lcl_env,
- tcl_tyvars = tcl_tyvars lcl_env }
+ tcl_tyvars = tcl_tyvars lcl_env }
+
+traceTcConstraints :: String -> TcM ()
+traceTcConstraints msg
+ = do { lie_var <- getConstraintVar
+ ; lie <- readTcRef lie_var
+ ; traceTc (msg ++ "LIE:") (ppr lie)
+ }
\end{code}
%************************************************************************
-%* *
- Template Haskell context
-%* *
+%* *
+ Template Haskell context
+%* *
%************************************************************************
\begin{code}
qReport False msg = addReport (text msg) empty
qLocation = do { m <- getModule
- ; l <- getSrcSpanM
- ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
- , TH.loc_module = moduleNameString (moduleName m)
- , TH.loc_package = packageIdString (modulePackageId m)
- , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
- , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
-
+ ; l <- getSrcSpanM
+ ; r <- case l of
+ UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+ (ppr l)
+ RealSrcSpan s -> return s
+ ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+ , TH.loc_module = moduleNameString (moduleName m)
+ , TH.loc_package = packageIdString (modulePackageId m)
+ , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+ , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
+
qReify v = reify v
qClassInstances = lookupClassInstances
let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
let localNames = filter ((m==) . nameModule) names
mbTyThings <- mapM GHC.lookupName localNames
- return $! [ tagInfo unqual exported kind name loc
+ return $! [ tagInfo unqual exported kind name realLoc
| tyThing <- catMaybes mbTyThings
, let name = getName tyThing
, let exported = GHC.modInfoIsExportedName mInfo name
, let kind = tyThing2TagKind tyThing
, let loc = srcSpanStart (nameSrcSpan name)
- , isGoodSrcLoc loc
+ , RealSrcLoc realLoc <- [loc]
]
where
-- get tag info, for later translation into Vim or Emacs style
-tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> SrcLoc -> TagInfo
+tagInfo :: PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc -> TagInfo
tagInfo unqual exported kind name loc
= TagInfo exported kind
(showSDocForUser unqual $ pprOccName (nameOccName name))
let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
st <- lift $ getGHCiState
let buf = stringToStringBuffer stmt
- loc = mkSrcLoc (fsLit (progname st)) (line_number st) 1
+ loc = mkRealSrcLoc (fsLit (progname st)) (line_number st) 1
pstate = Lexer.mkPState dflags buf loc
case Lexer.unP goToEnd pstate of
(Lexer.POk _ False) -> return $ Just stmt
-- | Returns the span of the largest tick containing the srcspan given
enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
-enclosingTickSpan mod src = do
+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+enclosingTickSpan mod (RealSrcSpan src) = do
ticks <- getTickArray mod
let line = srcSpanStartLine src
ASSERT (inRange (bounds ticks) line) do
- let enclosing_spans = [ span | (_,span) <- ticks ! line
- , srcSpanEnd span >= srcSpanEnd src]
+ let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+ toRealSrcSpan (RealSrcSpan s) = s
+ enclosing_spans = [ span | (_,span) <- ticks ! line
+ , realSrcSpanEnd (toRealSrcSpan span) >= realSrcSpanEnd src]
return . head . sortBy leftmost_largest $ enclosing_spans
traceCmd :: String -> GHCi ()
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then ASSERT( isExternalName name )
+ case loc of
+ RealSrcLoc l ->
+ ASSERT( isExternalName name )
findBreakAndSet (GHC.nameModule name) $
- findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc,
- GHC.srcLocCol loc)
- else noCanDo name $ text "can't find its location: " <> ppr loc
+ findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l,
+ GHC.srcLocCol l)
+ UnhelpfulLoc _ ->
+ noCanDo name $ text "can't find its location: " <> ppr loc
where
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
ticks = arr ! line
starts_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line ]
+ GHC.srcSpanStartLine (toRealSpan span) == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (_,span) = GHC.srcSpanEndLine span == line
+ where ends_here (_,span) = GHC.srcSpanEndLine (toRealSpan span) == line
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan"
findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
-> Maybe (BreakIndex,SrcSpan)
is_correct_file span ]
is_correct_file span
- | Just f <- mb_file = GHC.srcSpanFile span == f
+ | Just f <- mb_file = GHC.srcSpanFile (toRealSpan span) == f
| otherwise = True
after_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line,
- GHC.srcSpanStartCol span >= col ]
+ let span' = toRealSpan span,
+ GHC.srcSpanStartLine span' == line,
+ GHC.srcSpanStartCol span' >= col ]
+
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan"
-- For now, use ANSI bold on terminals that we know support it.
-- Otherwise, we add a line of carets under the active expression instead.
case mb_span of
Nothing ->
printForUser $ text "Not stopped at a breakpoint; nothing to list"
- Just span
- | GHC.isGoodSrcSpan span -> listAround span True
- | otherwise ->
+ Just (RealSrcSpan span) ->
+ listAround span True
+ Just span@(UnhelpfulSpan _) ->
do resumes <- GHC.getResumeContext
case resumes of
[] -> panic "No resumes"
list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then do
- tickArray <- ASSERT( isExternalName name )
+ case loc of
+ RealSrcLoc l ->
+ do tickArray <- ASSERT( isExternalName name )
lift $ getTickArray (GHC.nameModule name)
- let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc, GHC.srcLocCol loc)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
+ (GHC.srcLocLine l, GHC.srcLocCol l)
tickArray
case mb_span of
- Nothing -> listAround (GHC.srcLocSpan loc) False
- Just (_,span) -> listAround span False
- else
+ Nothing -> listAround (realSrcLocSpan l) False
+ Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan"
+ Just (_, RealSrcSpan span) -> listAround span False
+ UnhelpfulLoc _ ->
noCanDo name $ text "can't find its location: " <>
ppr loc
where
[] -> panic "listModuleLine"
summ:_ -> do
let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
- loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
- listAround (GHC.srcLocSpan loc) False
+ loc = mkRealSrcLoc (mkFastString (filename)) line 0
+ listAround (realSrcLocSpan loc) False
-- | list a section of a source file around a particular SrcSpan.
-- If the highlight flag is True, also highlight the span using
-- 2) convert the BS to String using utf-string, and write it out.
-- It would be better if we could convert directly between UTF-8 and the
-- console encoding, of course.
-listAround :: MonadIO m => SrcSpan -> Bool -> InputT m ()
+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
listAround span do_highlight = do
contents <- liftIO $ BS.readFile (unpackFS file)
let
mkTickArray ticks
= accumArray (flip (:)) [] (1, max_line)
[ (line, (nm,span)) | (nm,span) <- ticks,
- line <- srcSpanLines span ]
+ let span' = toRealSpan span,
+ line <- srcSpanLines span' ]
where
- max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
+ max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks)
srcSpanLines span = [ GHC.srcSpanStartLine span ..
GHC.srcSpanEndLine span ]
+ toRealSpan (RealSrcSpan span) = span
+ toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan"
lookupModule :: GHC.GhcMonad m => String -> m Module
lookupModule modName
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
+
-- files and "package.conf.d" dirs) the pkgroot is the parent directory
-- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
+-- TODO: This code is duplicated in compiler/main/Packages.lhs
mungePackagePaths :: FilePath -> FilePath
-> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
libraryDirs = munge_paths (libraryDirs pkg),
frameworkDirs = munge_paths (frameworkDirs pkg),
haddockInterfaces = munge_paths (haddockInterfaces pkg),
- haddockHTMLs = munge_urls (haddockHTMLs pkg)
+ -- haddock-html is allowed to be either a URL or a file
+ haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
}
where
munge_paths = map munge_path
munge_urls = map munge_url
munge_path p
- | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
- | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
+ | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
+ | otherwise = p
munge_url p
- | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
- | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
- | otherwise = p
- where
- sp = splitPath p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
+ | otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
- ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
-
- stripVarPrefix var (root:path')
- | Just [sep] <- stripPrefix var root
- , isPathSeparator sep
- = Just (joinPath path')
-
- stripVarPrefix _ _ = Nothing
+ ++ FilePath.Posix.joinPath
+ (r : -- We need to drop a leading "/" or "\\"
+ -- if there is one:
+ dropWhile (all isPathSeparator)
+ (FilePath.splitDirectories p))
+
+ -- We could drop the separator here, and then use </> above. However,
+ -- by leaving it in and using ++ we keep the same path separator
+ -- rather than letting FilePath change it to use \ as the separator
+ stripVarPrefix var path = case stripPrefix var path of
+ Just [] -> Just []
+ Just cs@(c : _) | isPathSeparator c -> Just cs
+ _ -> Nothing
-- -----------------------------------------------------------------------------
import Exception
import FastString
import MonadUtils ( liftIO )
+import SrcLoc
-- Every GHC comes with Cabal anyways, so this is not a bad new dependency
import Distribution.Simple.GHC ( ghcOptions )
type ThingName = String -- name of a defined entity in a Haskell program
-- A definition we have found (we know its containing module, name, and location)
-data FoundThing = FoundThing ModuleName ThingName SrcLoc
+data FoundThing = FoundThing ModuleName ThingName RealSrcLoc
-- Data we have obtained from a file (list of things we found)
data FileData = FileData FileName [FoundThing] (Map Int String)
in vals ++ tys ++ fors
where found = foundOfLName mod
-startOfLocated :: Located a -> SrcLoc
-startOfLocated lHs = srcSpanStart $ getLoc lHs
+startOfLocated :: Located a -> RealSrcLoc
+startOfLocated lHs = case getLoc lHs of
+ RealSrcSpan l -> realSrcSpanStart l
+ UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan"
foundOfLName :: ModuleName -> Located Name -> FoundThing
foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id)