{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
module Ivory.Language.Syntax.Concrete.Location where
import Prelude ()
import Prelude.Compat
import Control.Monad (mplus)
import Data.Function (on)
import Data.List (foldl')
import Data.Maybe (maybeToList)
import Data.Semigroup (Semigroup(..))
import qualified Text.PrettyPrint as P
import Ivory.Language.Syntax.Concrete.Pretty
class HasLocation a where
getLoc :: a -> SrcLoc
stripLoc :: a -> a
instance HasLocation a => HasLocation [a] where
{-# INLINE getLoc #-}
getLoc = foldMap getLoc
{-# INLINE stripLoc #-}
stripLoc = fmap stripLoc
instance (HasLocation a, HasLocation b) => HasLocation (a,b) where
{-# INLINE getLoc #-}
getLoc (a,b) = getLoc a `mappend` getLoc b
{-# INLINE stripLoc #-}
stripLoc (a,b) = (stripLoc a, stripLoc b)
instance HasLocation a => HasLocation (Maybe a) where
{-# INLINE getLoc #-}
getLoc = foldMap getLoc
{-# INLINE stripLoc #-}
stripLoc = fmap stripLoc
locStart :: HasLocation a => a -> Position
locStart a = srcStart (getLoc a)
locEnd :: HasLocation a => a -> Position
locEnd a = srcEnd (getLoc a)
data Located a = Located
{ locRange :: !SrcLoc
, locValue :: a
} deriving (Show,Read,Functor,Ord,Eq,Foldable,Traversable)
instance HasLocation (Located a) where
{-# INLINE getLoc #-}
getLoc = locRange
{-# INLINE stripLoc #-}
stripLoc l = l { locRange = NoLoc }
noLoc :: a -> Located a
noLoc a = Located
{ locRange = NoLoc
, locValue = a
}
at :: HasLocation loc => a -> loc -> Located a
at a loc = Located
{ locRange = getLoc loc
, locValue = a
}
atBin :: (HasLocation loc0, HasLocation loc1)
=> a -> loc0 -> loc1 -> Located a
atBin a l0 l1 = a `at` (getLoc l0 <> getLoc l1)
atList :: a -> [SrcLoc] -> Located a
atList a locs = a `at` mconcat locs
unLoc :: Located a -> a
unLoc = locValue
extendLoc :: SrcLoc -> Located a -> Located a
extendLoc r loc = loc { locRange = locRange loc `mappend` r }
type Source = Maybe String
data SrcLoc = NoLoc | SrcLoc !Range Source
deriving (Show,Read,Ord,Eq)
instance Pretty SrcLoc where
pretty NoLoc = P.lbrack P.<+> P.text "No location available" P.<+> P.rbrack
pretty (SrcLoc rng msrc) =
case msrc of
Nothing -> pretty rng
Just src -> pretty src P.<> P.colon P.<> pretty rng
instance HasLocation SrcLoc where
{-# INLINE getLoc #-}
getLoc = id
{-# INLINE stripLoc #-}
stripLoc _ = NoLoc
instance Semigroup SrcLoc where
SrcLoc lr ls <> SrcLoc rr rs = SrcLoc (lr <> rr) (mplus ls rs)
NoLoc <> r = r
l <> NoLoc = l
instance Monoid SrcLoc where
mempty = NoLoc
mappend = (<>)
srcLoclinePragma :: SrcLoc -> Maybe (Int, String)
srcLoclinePragma srcloc = case srcloc of
NoLoc -> Nothing
SrcLoc _ src -> Just ( posLine (srcStart srcloc)
, concat (maybeToList src))
srcRange :: SrcLoc -> Range
srcRange loc = case loc of
SrcLoc r _ -> r
NoLoc -> mempty
srcStart :: SrcLoc -> Position
srcStart loc = case loc of
SrcLoc r _ -> rangeStart r
NoLoc -> zeroPosition
srcEnd :: SrcLoc -> Position
srcEnd loc = case loc of
SrcLoc r _ -> rangeStart r
NoLoc -> zeroPosition
data Range = Range
{ rangeStart :: !Position
, rangeEnd :: !Position
} deriving (Show,Read,Eq,Ord)
instance Semigroup Range where
Range ls le <> Range rs re = Range (smallerOf ls rs) (largerOf le re)
instance Monoid Range where
mempty = Range zeroPosition zeroPosition
mappend = (<>)
instance Pretty Range where
pretty (Range st end) =
if st == end
then pretty st
else pretty st P.<+> P.char '-' P.<+> pretty end
data Position = Position
{ posOff :: !Int
, posLine :: !Int
, posCol :: !Int
} deriving (Show,Read,Eq)
instance Ord Position where
compare = compare `on` posOff
instance Pretty Position where
pretty (Position _ ln col) =
pretty ln P.<> P.colon P.<> pretty col
zeroPosition :: Position
zeroPosition = Position
{ posOff = 0
, posLine = 1
, posCol = 1
}
smallerOf :: Position -> Position -> Position
smallerOf l r
| l < r && l /= zeroPosition = l
| otherwise = r
largerOf :: Position -> Position -> Position
largerOf l r
| l > r = l
| otherwise = r
movePos :: Position -> Char -> Position
movePos (Position off line col) c =
case c of
'\t' -> Position (off+1) line (col+8)
'\n' -> Position (off+1) (line+1) 1
_ -> Position (off+1) line (col+1)
movesPos :: Position -> String -> Position
movesPos pos = foldl' movePos pos