{-# LANGUAGE DeriveGeneric, OverloadedStrings, RankNTypes #-}
-- | Source position and span information
--
--   Mostly taken from purescript's SourcePos definition.
module Source.Span
( Span(..)
, point
, spanFromSrcLoc
, Pos(..)
, line_
, column_
, HasSpan(..)
) where

import           Control.DeepSeq (NFData)
import           Data.Aeson ((.:), (.=))
import qualified Data.Aeson as A
import           Data.Hashable (Hashable)
import           Data.Semilattice.Lower (Lower(..))
import           GHC.Generics (Generic)
import           GHC.Stack (SrcLoc(..))

-- | A Span of position information
data Span = Span
  { Span -> Pos
start :: {-# UNPACK #-} !Pos
  , Span -> Pos
end   :: {-# UNPACK #-} !Pos
  }
  deriving (Span -> Span -> Bool
(Span -> Span -> Bool) -> (Span -> Span -> Bool) -> Eq Span
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Span -> Span -> Bool
$c/= :: Span -> Span -> Bool
== :: Span -> Span -> Bool
$c== :: Span -> Span -> Bool
Eq, Eq Span
Eq Span =>
(Span -> Span -> Ordering)
-> (Span -> Span -> Bool)
-> (Span -> Span -> Bool)
-> (Span -> Span -> Bool)
-> (Span -> Span -> Bool)
-> (Span -> Span -> Span)
-> (Span -> Span -> Span)
-> Ord Span
Span -> Span -> Bool
Span -> Span -> Ordering
Span -> Span -> Span
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Span -> Span -> Span
$cmin :: Span -> Span -> Span
max :: Span -> Span -> Span
$cmax :: Span -> Span -> Span
>= :: Span -> Span -> Bool
$c>= :: Span -> Span -> Bool
> :: Span -> Span -> Bool
$c> :: Span -> Span -> Bool
<= :: Span -> Span -> Bool
$c<= :: Span -> Span -> Bool
< :: Span -> Span -> Bool
$c< :: Span -> Span -> Bool
compare :: Span -> Span -> Ordering
$ccompare :: Span -> Span -> Ordering
$cp1Ord :: Eq Span
Ord, (forall x. Span -> Rep Span x)
-> (forall x. Rep Span x -> Span) -> Generic Span
forall x. Rep Span x -> Span
forall x. Span -> Rep Span x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Span x -> Span
$cfrom :: forall x. Span -> Rep Span x
Generic, Int -> Span -> ShowS
[Span] -> ShowS
Span -> String
(Int -> Span -> ShowS)
-> (Span -> String) -> ([Span] -> ShowS) -> Show Span
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Span] -> ShowS
$cshowList :: [Span] -> ShowS
show :: Span -> String
$cshow :: Span -> String
showsPrec :: Int -> Span -> ShowS
$cshowsPrec :: Int -> Span -> ShowS
Show)

instance Hashable Span
instance NFData   Span

instance Semigroup Span where
  Span start1 :: Pos
start1 end1 :: Pos
end1 <> :: Span -> Span -> Span
<> Span start2 :: Pos
start2 end2 :: Pos
end2 = Pos -> Pos -> Span
Span (Pos -> Pos -> Pos
forall a. Ord a => a -> a -> a
min Pos
start1 Pos
start2) (Pos -> Pos -> Pos
forall a. Ord a => a -> a -> a
max Pos
end1 Pos
end2)

instance A.ToJSON Span where
  toJSON :: Span -> Value
toJSON s :: Span
s = [Pair] -> Value
A.object
    [ "start" Text -> Pos -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Span -> Pos
start Span
s
    , "end"   Text -> Pos -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Span -> Pos
end   Span
s
    ]

instance A.FromJSON Span where
  parseJSON :: Value -> Parser Span
parseJSON = String -> (Object -> Parser Span) -> Value -> Parser Span
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject "Span" ((Object -> Parser Span) -> Value -> Parser Span)
-> (Object -> Parser Span) -> Value -> Parser Span
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> Pos -> Pos -> Span
Span
    (Pos -> Pos -> Span) -> Parser Pos -> Parser (Pos -> Span)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Pos
forall a. FromJSON a => Object -> Text -> Parser a
.: "start"
    Parser (Pos -> Span) -> Parser Pos -> Parser Span
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Pos
forall a. FromJSON a => Object -> Text -> Parser a
.: "end"

instance Lower Span where
  lowerBound :: Span
lowerBound = Pos -> Pos -> Span
Span Pos
forall s. Lower s => s
lowerBound Pos
forall s. Lower s => s
lowerBound


-- | Construct a Span with a given value for both its start and end positions.
point :: Pos -> Span
point :: Pos -> Span
point p :: Pos
p = Pos -> Pos -> Span
Span Pos
p Pos
p

spanFromSrcLoc :: SrcLoc -> Span
spanFromSrcLoc :: SrcLoc -> Span
spanFromSrcLoc s :: SrcLoc
s = Pos -> Pos -> Span
Span (Int -> Int -> Pos
Pos (SrcLoc -> Int
srcLocStartLine SrcLoc
s) (SrcLoc -> Int
srcLocStartCol SrcLoc
s)) (Int -> Int -> Pos
Pos (SrcLoc -> Int
srcLocEndLine SrcLoc
s) (SrcLoc -> Int
srcLocEndCol SrcLoc
s))


-- | Source position information (1-indexed)
data Pos = Pos
  { Pos -> Int
line   :: {-# UNPACK #-} !Int
  , Pos -> Int
column :: {-# UNPACK #-} !Int
  }
  deriving (Pos -> Pos -> Bool
(Pos -> Pos -> Bool) -> (Pos -> Pos -> Bool) -> Eq Pos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pos -> Pos -> Bool
$c/= :: Pos -> Pos -> Bool
== :: Pos -> Pos -> Bool
$c== :: Pos -> Pos -> Bool
Eq, Eq Pos
Eq Pos =>
(Pos -> Pos -> Ordering)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Bool)
-> (Pos -> Pos -> Pos)
-> (Pos -> Pos -> Pos)
-> Ord Pos
Pos -> Pos -> Bool
Pos -> Pos -> Ordering
Pos -> Pos -> Pos
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Pos -> Pos -> Pos
$cmin :: Pos -> Pos -> Pos
max :: Pos -> Pos -> Pos
$cmax :: Pos -> Pos -> Pos
>= :: Pos -> Pos -> Bool
$c>= :: Pos -> Pos -> Bool
> :: Pos -> Pos -> Bool
$c> :: Pos -> Pos -> Bool
<= :: Pos -> Pos -> Bool
$c<= :: Pos -> Pos -> Bool
< :: Pos -> Pos -> Bool
$c< :: Pos -> Pos -> Bool
compare :: Pos -> Pos -> Ordering
$ccompare :: Pos -> Pos -> Ordering
$cp1Ord :: Eq Pos
Ord, (forall x. Pos -> Rep Pos x)
-> (forall x. Rep Pos x -> Pos) -> Generic Pos
forall x. Rep Pos x -> Pos
forall x. Pos -> Rep Pos x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Pos x -> Pos
$cfrom :: forall x. Pos -> Rep Pos x
Generic, Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
(Int -> Pos -> ShowS)
-> (Pos -> String) -> ([Pos] -> ShowS) -> Show Pos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pos] -> ShowS
$cshowList :: [Pos] -> ShowS
show :: Pos -> String
$cshow :: Pos -> String
showsPrec :: Int -> Pos -> ShowS
$cshowsPrec :: Int -> Pos -> ShowS
Show)

instance Hashable Pos
instance NFData   Pos

instance A.ToJSON Pos where
  toJSON :: Pos -> Value
toJSON p :: Pos
p = [Int] -> Value
forall a. ToJSON a => a -> Value
A.toJSON
    [ Pos -> Int
line   Pos
p
    , Pos -> Int
column Pos
p
    ]

instance A.FromJSON Pos where
  parseJSON :: Value -> Parser Pos
parseJSON arr :: Value
arr = do
    [ line :: Int
line, col :: Int
col ] <- Value -> Parser [Int]
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
arr
    Pos -> Parser Pos
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos -> Parser Pos) -> Pos -> Parser Pos
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pos
Pos Int
line Int
col

instance Lower Pos where
  lowerBound :: Pos
lowerBound = Int -> Int -> Pos
Pos 1 1


line_, column_ :: Lens' Pos Int
line_ :: (Int -> f Int) -> Pos -> f Pos
line_   = (Pos -> Int) -> (Pos -> Int -> Pos) -> Lens' Pos Int
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens Pos -> Int
line   (\p :: Pos
p l :: Int
l -> Pos
p { line :: Int
line   = Int
l })
column_ :: (Int -> f Int) -> Pos -> f Pos
column_ = (Pos -> Int) -> (Pos -> Int -> Pos) -> Lens' Pos Int
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens Pos -> Int
column (\p :: Pos
p l :: Int
l -> Pos
p { column :: Int
column = Int
l })


-- | "Classy-fields" interface for data types that have spans.
class HasSpan a where
  span_ :: Lens' a Span

  start_ :: Lens' a Pos
  start_ = (Span -> f Span) -> a -> f a
forall a. HasSpan a => Lens' a Span
span_((Span -> f Span) -> a -> f a)
-> ((Pos -> f Pos) -> Span -> f Span) -> (Pos -> f Pos) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Pos -> f Pos) -> Span -> f Span
forall a. HasSpan a => Lens' a Pos
start_
  {-# INLINE start_ #-}

  end_ :: Lens' a Pos
  end_ = (Span -> f Span) -> a -> f a
forall a. HasSpan a => Lens' a Span
span_((Span -> f Span) -> a -> f a)
-> ((Pos -> f Pos) -> Span -> f Span) -> (Pos -> f Pos) -> a -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Pos -> f Pos) -> Span -> f Span
forall a. HasSpan a => Lens' a Pos
end_
  {-# INLINE end_ #-}

instance HasSpan Span where
  span_ :: (Span -> f Span) -> Span -> f Span
span_  = (Span -> f Span) -> Span -> f Span
forall a. a -> a
id
  {-# INLINE span_ #-}

  start_ :: (Pos -> f Pos) -> Span -> f Span
start_ = (Span -> Pos) -> (Span -> Pos -> Span) -> Lens' Span Pos
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens Span -> Pos
start (\s :: Span
s t :: Pos
t -> Span
s { start :: Pos
start = Pos
t })
  {-# INLINE start_ #-}

  end_ :: (Pos -> f Pos) -> Span -> f Span
end_   = (Span -> Pos) -> (Span -> Pos -> Span) -> Lens' Span Pos
forall s a. (s -> a) -> (s -> a -> s) -> Lens' s a
lens Span -> Pos
end   (\s :: Span
s t :: Pos
t -> Span
s { end :: Pos
end   = Pos
t })
  {-# INLINE end_ #-}


type Lens' s a = forall f . Functor f => (a -> f a) -> (s -> f s)

lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens get :: s -> a
get put :: s -> a -> s
put afa :: a -> f a
afa s :: s
s = (a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s -> a -> s
put s
s) (a -> f a
afa (s -> a
get s
s))
{-# INLINE lens #-}