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


data Position   = Position { line :: !Int, col :: !Int }
                  deriving (Eq, Ord, Show, Generic, NFData)

data Range      = Range { from   :: !Position
                        , to     :: !Position
                        , source :: FilePath }
                  deriving (Eq, Show, Generic, 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 { from = start, to = start, source = "" }

start :: Position
start = Position { line = 1, col = 1 }

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

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

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)

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

instance Functor Located where
  fmap f l = l { thing = f (thing l) }

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

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

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)
                          }