{- Generated by DrIFT (Automatic class derivations for Haskell) -}
{-# LINE 1 "src/FrontEnd/SrcLoc.hs" #-}
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 :: {-# UNPACK #-} !Int,
        srcLocColumn :: {-# UNPACK #-} !Int
        }
    deriving(Data,Typeable,Eq,Ord)
    {-! derive: update, Binary !-}

data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc }
    deriving(Data,Typeable,Eq,Ord)
    {-! derive: update, Binary !-}

-- Useful bogus file names used to indicate where non file based errors are.
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

--------------------
-- 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)
    {-! derive: Binary !-}

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) = 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
{-* Generated by DrIFT : Look, but Don't Touch. *-}
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)

--  Imported from other files :-