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 Data.DeriveTH
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
$(derive makeUpdate ''SrcLoc)
$(derive makeBinary ''SrcLoc)
$(derive makeUpdate ''SrcSpan)
$(derive makeBinary ''SrcSpan)
$(derive makeBinary ''Located)