Position.hs

-- |
-- 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 DeriveTraversable #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.Parser.Position (
  -- * Position
  Position,
  line, col, colOffset,
  start,
  startOfLine, beforeStartOfLine,
  move, moves, advanceColBy,
  replPosition,

  -- * Range
  Range(..),
  emptyRange,
  rComb, rCombs, rCombMaybe,
  rangeWithin,

  -- * Located
  Located(..),
  HasLoc(..), AddLoc(..),
  at,
  combLoc

) 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 { srcRange :: !Range, thing :: !a }
                  deriving (Eq, Ord, Show, Generic, NFData
                           , Functor, Foldable, Traversable )

data Position = Position {
  pLine :: !Int,
  -- ^ 1 based

  pCol :: !Int,
  -- ^ 1 based. Interpreting tabs.
  -- This is used for layout processing and pretty printing.

  pColOffset :: !Int
  -- ^ 0 based. UTF-32 offset in the line.
  -- Note that this does not interpret tabs.
  -- It is used for comparisons.
} deriving (Show, Generic, NFData)

line :: Position -> Int
line = pLine

col :: Position -> Int
col = pCol

colOffset :: Position -> Int
colOffset = pColOffset

instance Eq Position where
  x == y = line x == line y && colOffset x == colOffset y

instance Ord Position where
  compare x y =
    case compare (line x) (line y) of
      LT -> LT
      EQ -> compare (colOffset x) (colOffset y)
      GT -> GT

data Range      = Range { from   :: !Position
                        , to     :: !Position
                        , source :: FilePath }
                  deriving (Eq, Ord, Show, Generic, NFData)

-- | Returns `True` if the first range is contained in the second one.
rangeWithin :: Range -> Range -> Bool
a `rangeWithin` b =
  source a == source b && from a >= from b && to a <= to b

-- | 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 { from = start, to = start, source = "" }

replPosition :: (Int,Int) -> Position
replPosition (l,c) = Position { pLine = l, pCol = c, pColOffset = c }

start :: Position
start = Position { pLine = 1, pCol = 1, pColOffset = 0 }

startOfLine :: Int -> Position
startOfLine n = start { pLine = n }

beforeStartOfLine :: Int -> Position
beforeStartOfLine n = Position { pLine = n, pCol = 0, pColOffset = -1 }

advanceColBy :: Int -> Position -> Position
advanceColBy n p = p { pCol = pCol p + n, pColOffset = pColOffset p + n }

move :: Position -> Char -> Position
move p c = case c of
            '\t' -> p { pCol = ((col p + 7) `div` 8) * 8 + 1, pColOffset = colOffset p + 1 }
            '\n' -> p { pCol = 1, pLine = 1 + line p, pColOffset = 0 }
            _    -> p { pCol = 1 + col p, pColOffset = colOffset p + 1 }

moves :: Position -> Text -> Position
moves = T.foldl' move

rComb :: Range -> Range -> Range
rComb r1 r2  = Range { from = rFrom, to = rTo, source = source r1 }
  where rFrom = min (from r1) (from r2)
        rTo   = max (to r1)   (to r2)

rCombMaybe :: Maybe Range -> Maybe Range -> Maybe Range
rCombMaybe Nothing y = y
rCombMaybe x Nothing = x
rCombMaybe (Just x) (Just y) = Just (rComb x y)

rCombs :: [Range] -> Range
rCombs  = foldl1 rComb


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

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

instance PP Range where
  ppPrec _ r = text (source r) <.> char ':'
            <.> pp (from r) <.> text "--" <.> pp (to r)

instance PP a => PP (Located a) where
  ppPrec _ l = parens (text "at" <+> pp (srcRange l) <.> comma <+> pp (thing l))

instance PPName a => PPName (Located a) where
  ppNameFixity  Located { .. } = ppNameFixity thing
  ppPrefixName  Located { .. } = ppPrefixName thing
  ppInfixName   Located { .. } = ppInfixName  thing

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

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

instance HasLoc Range where
  getLoc r = Just r

instance HasLoc (Located a) where
  getLoc r = Just (srcRange r)

instance (HasLoc a, HasLoc b) => HasLoc (a,b) where
  getLoc (f,t) = case getLoc f of
                   Nothing -> getLoc t
                   Just l ->
                      case getLoc t of
                        Nothing -> return l
                        Just l1 -> return (rComb l l1)

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

instance HasLoc a => HasLoc (Maybe a) where
  getLoc Nothing = Nothing
  getLoc (Just x) = getLoc x

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

instance AddLoc (Located a) where
  addLoc t r = t { srcRange = r }
  dropLoc r  = r

at :: (HasLoc l, AddLoc t) => l -> t -> t
at l e = maybe e (addLoc e) (getLoc l)

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