module FrontEnd.SrcLoc where import Control.Monad.Writer import Control.Monad.Identity import Control.Monad import Control.Applicative import Data.Traversable import Data.Foldable import Data.Monoid import Data.Generics import Data.Binary data SrcLoc = SrcLoc { srcLocFileName :: String, srcLocLine :: !Int, srcLocColumn :: !Int} deriving(Data,Typeable,Eq,Ord) {-! derive: update, Binary !-} data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc } deriving(Data,Typeable,Eq,Ord) {-! derive: update !-} bogusASrcLoc = SrcLoc "bogus#" (-1) (-1) bogusSrcSpan = SrcSpan bogusASrcLoc bogusASrcLoc instance Monoid SrcLoc where mempty = bogusASrcLoc mappend a b | a == bogusASrcLoc = b | otherwise = a -------------------- -- haslocation class -------------------- 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 ----------------------- -- srcloc monad classes ----------------------- 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 ----------------- -- show instances ----------------- instance Show SrcLoc where show (SrcLoc fn l c) = 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