module Data.Loc (
Pos(..),
posFile,
posLine,
posCol,
posCoff,
startPos,
linePos,
advancePos,
Loc(..),
locStart,
locEnd,
noLoc,
SrcLoc(..),
noSrcLoc,
locOf,
(<-->),
mergeLoc,
Location(..),
Located(..),
Relocatable(..),
L(..),
unLoc
) where
#ifdef __GLASGOW_HASKELL__
import Data.Generics (Data(..),Typeable(..))
#endif
import Data.List (foldl1')
import Data.Symbol
data Pos =
Pos !Symbol
!Int
!Int
!Int
#ifdef __GLASGOW_HASKELL__
deriving (Eq, Show, Data, Typeable)
#else
deriving (Eq, Show)
#endif
instance Ord Pos where
compare (Pos f1 l1 c1 _) (Pos f2 l2 c2 _) =
compare (f1, l1, c1) (f2, l2, c2)
posFile :: Pos -> String
posFile (Pos f _ _ _) = unintern f
posLine :: Pos -> Int
posLine (Pos _ l _ _) = l
posCol :: Pos -> Int
posCol (Pos _ _ c _) = c
posCoff :: Pos -> Int
posCoff (Pos _ _ _ coff) = coff
startLine :: Int
startLine = 1
startCol :: Int
startCol = 0
startCoff :: Int
startCoff = 0
startPos :: String -> Pos
startPos f = Pos (intern f) startLine startCol startCoff
linePos :: String -> Int -> Pos
linePos f l = Pos (intern f) l startCol startCoff
advancePos :: Pos -> Char -> Pos
advancePos (Pos f l _ coff) '\n' = Pos f (l+1) startCol (coff + 1)
advancePos (Pos f l c coff) _ = Pos f l (c + 1) (coff + 1)
data Loc = NoLoc
|
Loc !Pos
!Pos
#ifdef __GLASGOW_HASKELL__
deriving (Eq, Show, Data, Typeable)
#else
deriving (Eq, Show)
#endif
locStart :: Loc -> Loc
locStart NoLoc = NoLoc
locStart (Loc p _) = Loc p p
locEnd :: Loc -> Loc
locEnd NoLoc = NoLoc
locEnd (Loc _ p) = Loc p p
noLoc :: Location a => a
noLoc = fromLoc NoLoc
newtype SrcLoc = SrcLoc Loc
deriving (Data, Typeable)
instance Eq SrcLoc where
_ == _ = True
instance Ord SrcLoc where
compare _ _ = EQ
noSrcLoc :: SrcLoc
noSrcLoc = SrcLoc NoLoc
locOf :: (Located a, Location b) => a -> b
locOf = fromLoc . getLoc
infixl 6 <-->
(<-->) :: (Located a, Located b, Location c)
=> a -> b -> c
x <--> y = fromLoc $ mergeLoc (getLoc x) (getLoc y)
mergeLoc :: Loc -> Loc -> Loc
mergeLoc NoLoc l = l
mergeLoc l NoLoc = l
mergeLoc (Loc b1 e1) (Loc b2 e2) = Loc (min b1 b2) (max e1 e2)
class Location a where
fromLoc :: Loc -> a
instance Location Loc where
fromLoc = id
instance Location SrcLoc where
fromLoc = SrcLoc
class Located a where
getLoc :: a -> Loc
instance Located a => Located [a] where
getLoc [] = NoLoc
getLoc xs = foldl1' mergeLoc (map getLoc xs)
instance Located Pos where
getLoc p = Loc p p
instance Located Loc where
getLoc = id
instance Located SrcLoc where
getLoc (SrcLoc loc) = loc
class Relocatable a where
reloc :: Located b => b -> a -> a
data L x = L Loc x
unLoc :: L a -> a
unLoc (L _ a) = a
instance Eq x => Eq (L x) where
(L _ x) == (L _ y) = x == y
instance Ord x => Ord (L x) where
compare (L _ x) (L _ y) = compare x y
instance Located (L a) where
getLoc (L loc _) = loc
instance Show x => Show (L x) where
show (L _ x) = show x