module FrontEnd.SrcLoc where
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Writer
import Data.Foldable
import Data.Traversable
import Data.Binary
import Data.Generics
import PackedString
data SrcLoc = SrcLoc {
srcLocFileName :: PackedString,
srcLocLine :: !Int,
srcLocColumn :: !Int
}
deriving(Data,Typeable,Eq,Ord)
data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc }
deriving(Data,Typeable,Eq,Ord)
fileNameCommandLine = packString "(command line)"
fileNameUnknown = packString "(unknown)"
fileNameGenerated = packString "(generated)"
bogusASrcLoc = SrcLoc fileNameUnknown (1) (1)
bogusSrcSpan = SrcSpan bogusASrcLoc bogusASrcLoc
instance Monoid SrcLoc where
mempty = bogusASrcLoc
mappend a b
| a == bogusASrcLoc = b
| otherwise = a
class HasLocation a where
srcLoc :: a -> SrcLoc
srcSpan :: a -> SrcSpan
srcSpan x = bogusSrcSpan { srcSpanBegin = slx, srcSpanEnd = slx } where slx = srcLoc x
srcLoc x = srcSpanBegin (srcSpan x)
instance HasLocation a => HasLocation [a] where
srcLoc xs = mconcat (map srcLoc xs)
instance HasLocation SrcLoc where
srcLoc x = x
instance HasLocation SrcSpan where
srcSpan x = x
instance HasLocation (SrcLoc,SrcLoc) where
srcSpan (x,y) = SrcSpan x y
instance HasLocation (Located a) where
srcSpan (Located x _) = x
data Located x = Located SrcSpan x
deriving(Ord,Show,Data,Typeable,Eq)
fromLocated :: Located x -> x
fromLocated (Located _ x) = x
instance Functor Located where
fmap f (Located l x) = Located l (f x)
instance Foldable Located where
foldMap f (Located l x) = f x
instance Traversable Located where
traverse f (Located l x) = Located l <$> f x
located ss x = Located (srcSpan ss) x
class Monad m => MonadSrcLoc m where
getSrcLoc :: m SrcLoc
getSrcSpan :: m SrcSpan
getSrcSpan = getSrcLoc >>= return . srcSpan
getSrcLoc = getSrcSpan >>= return . srcLoc
class MonadSrcLoc m => MonadSetSrcLoc m where
withSrcLoc :: SrcLoc -> m a -> m a
withSrcSpan :: SrcSpan -> m a -> m a
withSrcLoc sl a = withSrcSpan (srcSpan sl) a
withSrcSpan ss a = withSrcLoc (srcLoc ss) a
withLocation :: (HasLocation l,MonadSetSrcLoc m) => l -> m a -> m a
withLocation l = withSrcSpan (srcSpan l)
instance Monoid w => MonadSrcLoc (Writer w) where
getSrcLoc = return mempty
instance Monoid w => MonadSetSrcLoc (Writer w) where
withSrcLoc _ a = a
instance MonadSrcLoc Identity where
getSrcLoc = return mempty
instance MonadSetSrcLoc Identity where
withSrcLoc _ a = a
instance Show SrcLoc where
show (SrcLoc fn l c) = unpackPS fn ++ f l ++ f c where
f (1) = ""
f n = ':':show n
instance Show SrcSpan where
show SrcSpan { srcSpanBegin = sl1, srcSpanEnd = sl2 }
| sl1 == sl2 = show sl1
| otherwise = show sl1 ++ "-" ++ show sl2
srcLocColumn_u f r@SrcLoc{srcLocColumn = x} = r{srcLocColumn = f x}
srcLocFileName_u f r@SrcLoc{srcLocFileName = x} = r{srcLocFileName = f x}
srcLocLine_u f r@SrcLoc{srcLocLine = x} = r{srcLocLine = f x}
srcLocColumn_s v = srcLocColumn_u (const v)
srcLocFileName_s v = srcLocFileName_u (const v)
srcLocLine_s v = srcLocLine_u (const v)
instance Data.Binary.Binary SrcLoc where
put (SrcLoc aa ab ac) = do
Data.Binary.put aa
Data.Binary.put ab
Data.Binary.put ac
get = do
aa <- get
ab <- get
ac <- get
return (SrcLoc aa ab ac)
srcSpanBegin_u f r@SrcSpan{srcSpanBegin = x} = r{srcSpanBegin = f x}
srcSpanEnd_u f r@SrcSpan{srcSpanEnd = x} = r{srcSpanEnd = f x}
srcSpanBegin_s v = srcSpanBegin_u (const v)
srcSpanEnd_s v = srcSpanEnd_u (const v)
instance Data.Binary.Binary SrcSpan where
put (SrcSpan aa ab) = do
Data.Binary.put aa
Data.Binary.put ab
get = do
aa <- get
ab <- get
return (SrcSpan aa ab)
instance (Data.Binary.Binary x) => Data.Binary.Binary (Located x) where
put (Located aa ab) = do
Data.Binary.put aa
Data.Binary.put ab
get = do
aa <- get
ab <- get
return (Located aa ab)