-- |
-- Module      :  Cryptol.Parser.Position
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE Safe #-}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.Position where

import           Data.Text(Text)
import qualified Data.Text as T

import GHC.Generics (Generic)
import Control.DeepSeq

import Cryptol.Utils.PP

data Located a  = Located { Located a -> Range
srcRange :: !Range, Located a -> a
thing :: !a }
                  deriving (Located a -> Located a -> Bool
(Located a -> Located a -> Bool)
-> (Located a -> Located a -> Bool) -> Eq (Located a)
forall a. Eq a => Located a -> Located a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Located a -> Located a -> Bool
$c/= :: forall a. Eq a => Located a -> Located a -> Bool
== :: Located a -> Located a -> Bool
$c== :: forall a. Eq a => Located a -> Located a -> Bool
Eq, Eq (Located a)
Eq (Located a)
-> (Located a -> Located a -> Ordering)
-> (Located a -> Located a -> Bool)
-> (Located a -> Located a -> Bool)
-> (Located a -> Located a -> Bool)
-> (Located a -> Located a -> Bool)
-> (Located a -> Located a -> Located a)
-> (Located a -> Located a -> Located a)
-> Ord (Located a)
Located a -> Located a -> Bool
Located a -> Located a -> Ordering
Located a -> Located a -> Located a
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
forall a. Ord a => Eq (Located a)
forall a. Ord a => Located a -> Located a -> Bool
forall a. Ord a => Located a -> Located a -> Ordering
forall a. Ord a => Located a -> Located a -> Located a
min :: Located a -> Located a -> Located a
$cmin :: forall a. Ord a => Located a -> Located a -> Located a
max :: Located a -> Located a -> Located a
$cmax :: forall a. Ord a => Located a -> Located a -> Located a
>= :: Located a -> Located a -> Bool
$c>= :: forall a. Ord a => Located a -> Located a -> Bool
> :: Located a -> Located a -> Bool
$c> :: forall a. Ord a => Located a -> Located a -> Bool
<= :: Located a -> Located a -> Bool
$c<= :: forall a. Ord a => Located a -> Located a -> Bool
< :: Located a -> Located a -> Bool
$c< :: forall a. Ord a => Located a -> Located a -> Bool
compare :: Located a -> Located a -> Ordering
$ccompare :: forall a. Ord a => Located a -> Located a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Located a)
Ord, Int -> Located a -> ShowS
[Located a] -> ShowS
Located a -> String
(Int -> Located a -> ShowS)
-> (Located a -> String)
-> ([Located a] -> ShowS)
-> Show (Located a)
forall a. Show a => Int -> Located a -> ShowS
forall a. Show a => [Located a] -> ShowS
forall a. Show a => Located a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Located a] -> ShowS
$cshowList :: forall a. Show a => [Located a] -> ShowS
show :: Located a -> String
$cshow :: forall a. Show a => Located a -> String
showsPrec :: Int -> Located a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Located a -> ShowS
Show, (forall x. Located a -> Rep (Located a) x)
-> (forall x. Rep (Located a) x -> Located a)
-> Generic (Located a)
forall x. Rep (Located a) x -> Located a
forall x. Located a -> Rep (Located a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Located a) x -> Located a
forall a x. Located a -> Rep (Located a) x
$cto :: forall a x. Rep (Located a) x -> Located a
$cfrom :: forall a x. Located a -> Rep (Located a) x
Generic, Located a -> ()
(Located a -> ()) -> NFData (Located a)
forall a. NFData a => Located a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Located a -> ()
$crnf :: forall a. NFData a => Located a -> ()
NFData)


data Position   = Position { Position -> Int
line :: !Int, Position -> Int
col :: !Int }
                  deriving (Position -> Position -> Bool
(Position -> Position -> Bool)
-> (Position -> Position -> Bool) -> Eq Position
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Eq Position
Eq Position
-> (Position -> Position -> Ordering)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Bool)
-> (Position -> Position -> Position)
-> (Position -> Position -> Position)
-> Ord Position
Position -> Position -> Bool
Position -> Position -> Ordering
Position -> Position -> Position
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 :: Position -> Position -> Position
$cmin :: Position -> Position -> Position
max :: Position -> Position -> Position
$cmax :: Position -> Position -> Position
>= :: Position -> Position -> Bool
$c>= :: Position -> Position -> Bool
> :: Position -> Position -> Bool
$c> :: Position -> Position -> Bool
<= :: Position -> Position -> Bool
$c<= :: Position -> Position -> Bool
< :: Position -> Position -> Bool
$c< :: Position -> Position -> Bool
compare :: Position -> Position -> Ordering
$ccompare :: Position -> Position -> Ordering
$cp1Ord :: Eq Position
Ord, Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
(Int -> Position -> ShowS)
-> (Position -> String) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show, (forall x. Position -> Rep Position x)
-> (forall x. Rep Position x -> Position) -> Generic Position
forall x. Rep Position x -> Position
forall x. Position -> Rep Position x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Position x -> Position
$cfrom :: forall x. Position -> Rep Position x
Generic, Position -> ()
(Position -> ()) -> NFData Position
forall a. (a -> ()) -> NFData a
rnf :: Position -> ()
$crnf :: Position -> ()
NFData)

data Range      = Range { Range -> Position
from   :: !Position
                        , Range -> Position
to     :: !Position
                        , Range -> String
source :: FilePath }
                  deriving (Range -> Range -> Bool
(Range -> Range -> Bool) -> (Range -> Range -> Bool) -> Eq Range
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Range -> Range -> Bool
$c/= :: Range -> Range -> Bool
== :: Range -> Range -> Bool
$c== :: Range -> Range -> Bool
Eq, Eq Range
Eq Range
-> (Range -> Range -> Ordering)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Range)
-> (Range -> Range -> Range)
-> Ord Range
Range -> Range -> Bool
Range -> Range -> Ordering
Range -> Range -> Range
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 :: Range -> Range -> Range
$cmin :: Range -> Range -> Range
max :: Range -> Range -> Range
$cmax :: Range -> Range -> Range
>= :: Range -> Range -> Bool
$c>= :: Range -> Range -> Bool
> :: Range -> Range -> Bool
$c> :: Range -> Range -> Bool
<= :: Range -> Range -> Bool
$c<= :: Range -> Range -> Bool
< :: Range -> Range -> Bool
$c< :: Range -> Range -> Bool
compare :: Range -> Range -> Ordering
$ccompare :: Range -> Range -> Ordering
$cp1Ord :: Eq Range
Ord, Int -> Range -> ShowS
[Range] -> ShowS
Range -> String
(Int -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Range] -> ShowS
$cshowList :: [Range] -> ShowS
show :: Range -> String
$cshow :: Range -> String
showsPrec :: Int -> Range -> ShowS
$cshowsPrec :: Int -> Range -> ShowS
Show, (forall x. Range -> Rep Range x)
-> (forall x. Rep Range x -> Range) -> Generic Range
forall x. Rep Range x -> Range
forall x. Range -> Rep Range x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Range x -> Range
$cfrom :: forall x. Range -> Rep Range x
Generic, Range -> ()
(Range -> ()) -> NFData Range
forall a. (a -> ()) -> NFData a
rnf :: Range -> ()
$crnf :: Range -> ()
NFData)

-- | An empty range.
--
-- Caution: using this on the LHS of a use of rComb will cause the empty source
-- to propagate.
emptyRange :: Range
emptyRange :: Range
emptyRange  = Range :: Position -> Position -> String -> Range
Range { from :: Position
from = Position
start, to :: Position
to = Position
start, source :: String
source = String
"" }

start :: Position
start :: Position
start = Position :: Int -> Int -> Position
Position { line :: Int
line = Int
1, col :: Int
col = Int
1 }

move :: Position -> Char -> Position
move :: Position -> Char -> Position
move Position
p Char
c = case Char
c of
            Char
'\t' -> Position
p { col :: Int
col = ((Position -> Int
col Position
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
            Char
'\n' -> Position
p { col :: Int
col = Int
1, line :: Int
line = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Position -> Int
line Position
p }
            Char
_    -> Position
p { col :: Int
col = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Position -> Int
col Position
p }

moves :: Position -> Text -> Position
moves :: Position -> Text -> Position
moves Position
p Text
cs = (Position -> Char -> Position) -> Position -> Text -> Position
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Position -> Char -> Position
move Position
p Text
cs

rComb :: Range -> Range -> Range
rComb :: Range -> Range -> Range
rComb Range
r1 Range
r2  = Range :: Position -> Position -> String -> Range
Range { from :: Position
from = Position
rFrom, to :: Position
to = Position
rTo, source :: String
source = Range -> String
source Range
r1 }
  where rFrom :: Position
rFrom = Position -> Position -> Position
forall a. Ord a => a -> a -> a
min (Range -> Position
from Range
r1) (Range -> Position
from Range
r2)
        rTo :: Position
rTo   = Position -> Position -> Position
forall a. Ord a => a -> a -> a
max (Range -> Position
to Range
r1)   (Range -> Position
to Range
r2)

rCombs :: [Range] -> Range
rCombs :: [Range] -> Range
rCombs  = (Range -> Range -> Range) -> [Range] -> Range
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Range -> Range -> Range
rComb

instance Functor Located where
  fmap :: (a -> b) -> Located a -> Located b
fmap a -> b
f Located a
l = Located a
l { thing :: b
thing = a -> b
f (Located a -> a
forall a. Located a -> a
thing Located a
l) }

--------------------------------------------------------------------------------

instance PP Position where
  ppPrec :: Int -> Position -> Doc
ppPrec Int
_ Position
p = Int -> Doc
int (Position -> Int
line Position
p) Doc -> Doc -> Doc
<.> Doc
colon Doc -> Doc -> Doc
<.> Int -> Doc
int (Position -> Int
col Position
p)

instance PP Range where
  ppPrec :: Int -> Range -> Doc
ppPrec Int
_ Range
r = String -> Doc
text (Range -> String
source Range
r) Doc -> Doc -> Doc
<.> Char -> Doc
char Char
':'
            Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp (Range -> Position
from Range
r) Doc -> Doc -> Doc
<.> String -> Doc
text String
"--" Doc -> Doc -> Doc
<.> Position -> Doc
forall a. PP a => a -> Doc
pp (Range -> Position
to Range
r)

instance PP a => PP (Located a) where
  ppPrec :: Int -> Located a -> Doc
ppPrec Int
_ Located a
l = Doc -> Doc
parens (String -> Doc
text String
"at" Doc -> Doc -> Doc
<+> Range -> Doc
forall a. PP a => a -> Doc
pp (Located a -> Range
forall a. Located a -> Range
srcRange Located a
l) Doc -> Doc -> Doc
<.> Doc
comma Doc -> Doc -> Doc
<+> a -> Doc
forall a. PP a => a -> Doc
pp (Located a -> a
forall a. Located a -> a
thing Located a
l))

instance PPName a => PPName (Located a) where
  ppNameFixity :: Located a -> Maybe Fixity
ppNameFixity  Located { a
Range
thing :: a
srcRange :: Range
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
.. } = a -> Maybe Fixity
forall a. PPName a => a -> Maybe Fixity
ppNameFixity a
thing
  ppPrefixName :: Located a -> Doc
ppPrefixName  Located { a
Range
thing :: a
srcRange :: Range
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
.. } = a -> Doc
forall a. PPName a => a -> Doc
ppPrefixName a
thing
  ppInfixName :: Located a -> Doc
ppInfixName   Located { a
Range
thing :: a
srcRange :: Range
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
.. } = a -> Doc
forall a. PPName a => a -> Doc
ppInfixName  a
thing

--------------------------------------------------------------------------------

class HasLoc t where
  getLoc :: t -> Maybe Range

instance HasLoc Range where
  getLoc :: Range -> Maybe Range
getLoc Range
r = Range -> Maybe Range
forall a. a -> Maybe a
Just Range
r

instance HasLoc (Located a) where
  getLoc :: Located a -> Maybe Range
getLoc Located a
r = Range -> Maybe Range
forall a. a -> Maybe a
Just (Located a -> Range
forall a. Located a -> Range
srcRange Located a
r)

instance (HasLoc a, HasLoc b) => HasLoc (a,b) where
  getLoc :: (a, b) -> Maybe Range
getLoc (a
f,b
t) = case a -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc a
f of
                   Maybe Range
Nothing -> b -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc b
t
                   Just Range
l ->
                      case b -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc b
t of
                        Maybe Range
Nothing -> Range -> Maybe Range
forall (m :: * -> *) a. Monad m => a -> m a
return Range
l
                        Just Range
l1 -> Range -> Maybe Range
forall (m :: * -> *) a. Monad m => a -> m a
return (Range -> Range -> Range
rComb Range
l Range
l1)

instance HasLoc a => HasLoc [a] where
  getLoc :: [a] -> Maybe Range
getLoc = Maybe Range -> [a] -> Maybe Range
forall t. HasLoc t => Maybe Range -> [t] -> Maybe Range
go Maybe Range
forall a. Maybe a
Nothing
    where
    go :: Maybe Range -> [t] -> Maybe Range
go Maybe Range
x [] = Maybe Range
x
    go Maybe Range
Nothing (t
x : [t]
xs)  = Maybe Range -> [t] -> Maybe Range
go (t -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc t
x) [t]
xs
    go (Just Range
l) (t
x : [t]
xs) = case t -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc t
x of
                             Maybe Range
Nothing -> Maybe Range -> [t] -> Maybe Range
go (Range -> Maybe Range
forall a. a -> Maybe a
Just Range
l) [t]
xs
                             Just Range
l1 -> Maybe Range -> [t] -> Maybe Range
go (Range -> Maybe Range
forall a. a -> Maybe a
Just (Range -> Range -> Range
rComb Range
l Range
l1)) [t]
xs

class HasLoc t => AddLoc t where
  addLoc  :: t -> Range -> t
  dropLoc :: t -> t

instance AddLoc (Located a) where
  addLoc :: Located a -> Range -> Located a
addLoc Located a
t Range
r = Located a
t { srcRange :: Range
srcRange = Range
r }
  dropLoc :: Located a -> Located a
dropLoc Located a
r  = Located a
r

at :: (HasLoc l, AddLoc t) => l -> t -> t
at :: l -> t -> t
at l
l t
e = t -> (Range -> t) -> Maybe Range -> t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe t
e (t -> Range -> t
forall t. AddLoc t => t -> Range -> t
addLoc t
e) (l -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc l
l)

combLoc :: (a -> b -> c) -> Located a -> Located b -> Located c
combLoc :: (a -> b -> c) -> Located a -> Located b -> Located c
combLoc a -> b -> c
f Located a
l1 Located b
l2 = Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range -> Range -> Range
rComb (Located a -> Range
forall a. Located a -> Range
srcRange Located a
l1) (Located b -> Range
forall a. Located a -> Range
srcRange Located b
l2)
                          , thing :: c
thing    = a -> b -> c
f (Located a -> a
forall a. Located a -> a
thing Located a
l1) (Located b -> b
forall a. Located a -> a
thing Located b
l2)
                          }