{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-
Module      :  $Header$
Description :  Source Location
Copyright   :  (c) SMART Team / HASLab
License     :  GPL

Maintainer  :  Paulo Silva <paufil@di.uminho.pt>
Stability   :  experimental
Portability :  non-portable (<reason>)

Source location
-}

module Language.CAO.Common.SrcLoc
    ( -- * Source Location (point)
      SrcLoc
      -- * SrcLoc construction
    , srcLoc
    , defSrcLoc
    , unkSrcLoc
    , genSrcLoc
      -- * Located Type
    , Located(..)
    -- * Located Construction
    , noLoc
    , genLoc
      -- * Located Destruction
    , getLoc
    , unLoc
    , mapML
    ) where

import Control.Monad

import Data.Foldable
import Data.Traversable

import Language.CAO.Common.Outputable

-- | Source location
--
data SrcLoc
    -- | Normal Source location line:col - offset
    = SrcLoc !Int     -- line number
             !Int     -- column number
             !Int     -- offset
    -- | General information
    | UnhelpfulLoc String
    deriving (Show, Read, Eq)

instance PP SrcLoc where
    ppr (SrcLoc ln cn _o)  = int ln <> char ':' <> int cn
    ppr (UnhelpfulLoc txt) = text txt

-- | Create a 'SrcLoc'
--
{-# INLINE srcLoc #-}
srcLoc :: Int -> Int -> Int -> SrcLoc
srcLoc = SrcLoc

-- | Create default 'SrcLoc'
--
defSrcLoc :: SrcLoc
defSrcLoc = UnhelpfulLoc "<no location info>"

-- | Create unknown 'SrcLoc'
--
{-# INLINE unkSrcLoc #-}
unkSrcLoc :: SrcLoc
unkSrcLoc = defSrcLoc

-- | Create generated 'SrcLoc'
--
genSrcLoc :: SrcLoc
genSrcLoc = UnhelpfulLoc "<compiler-generated code>"


-- | Located element
--
data Located e = L SrcLoc e
    deriving (Show, Read, Eq, Foldable, Traversable)

instance Functor Located where
    fmap f (L l a) = L l (f a)

instance PP e => PP (Located e) where
    ppr (L _ e) = ppr e

-- | "Unlocated" element
--
{-# INLINE noLoc #-}
noLoc :: e -> Located e
noLoc = L unkSrcLoc

-- | "Unlocated" element
--
{-# INLINE genLoc #-}
genLoc :: e -> Located e
genLoc = L genSrcLoc

-- | Get 'SrcLoc' from 'Located'
--
{-# INLINE getLoc #-}
getLoc :: Located e -> SrcLoc
getLoc (L loc _) = loc

-- | Get element in 'Located'
--
{-# INLINE unLoc #-}
unLoc :: Located e -> e
unLoc (L _ e) = e

{-# INLINE mapML #-}
mapML :: Monad m => (a -> m b) -> Located a -> m (Located b)
mapML f (L loc e) = liftM (L loc) $ f e