content: {-# LANGUAGE DefaultSignatures #-}
  
  module Language.Fortran.Util.Position where
  
  import Data.Data
  import Text.PrettyPrint.GenericPretty
  import Text.PrettyPrint
  import Data.Binary
  import Control.DeepSeq
  import Data.List.NonEmpty ( NonEmpty(..) )
  
  import Language.Fortran.Util.SecondParameter
  
  class Loc a where
    getPos :: a -> Position
  
  data Position = Position
    { posAbsoluteOffset   :: Int
    , posColumn           :: Int
    , posLine             :: Int
    , posFilePath         :: String
    , posPragmaOffset     :: Maybe (Int, String)  -- ^ line-offset and filename as given by a pragma.
    } deriving (Eq, Ord, Data, Typeable, Generic)
  
  instance Binary Position
  instance NFData Position
  
  instance Show Position where
    -- Column number decrement by 1 as the lexer generates column numbers
    -- starting at position 1
    -- See PR https://github.com/camfort/fortran-src/pull/292
    show (Position _ c l _ _) = show l ++ ':' : show (c - 1)
  
  initPosition :: Position
  initPosition = Position
    { posAbsoluteOffset = 0
    , posColumn = 1
    , posLine = 1
    , posFilePath = ""
    , posPragmaOffset = Nothing
    }
  
  lineCol :: Position -> (Int, Int)
  lineCol p = (fromIntegral $ posLine p, fromIntegral $ posColumn p)
  
  -- | (line, column) number taking into account any specified line pragmas.
  apparentLineCol :: Position -> (Int, Int)
  apparentLineCol (Position _ c l _ (Just (o, _))) = (l + o, c)
  apparentLineCol (Position _ c l _ Nothing)       = (l, c)
  
  -- | Path of file taking into account any specified line pragmas.
  apparentFilePath :: Position -> String
  apparentFilePath p | Just (_, f) <- posPragmaOffset p = f
                     | otherwise                        = posFilePath p
  
  data SrcSpan = SrcSpan
    { ssFrom :: Position
    , ssTo   :: Position
    } deriving (Eq, Ord, Typeable, Data, Generic)
  
  instance Binary SrcSpan
  instance NFData SrcSpan
  instance Show SrcSpan where
    show (SrcSpan s1 s2)= '(' : show s1 ++ ")-(" ++ show s2 ++ ")"
  
  instance Out SrcSpan where
    doc s = text $ show s
    docPrec _ = doc
  
  -- Difference between the column of the upper and lower positions in a span
  columnDistance :: SrcSpan -> Int
  columnDistance (SrcSpan (Position _ c1 _ _ _) (Position _ c2 _ _ _)) = c2 - c1
  
  -- Difference between the lines of the upper and lower positions in a span
  lineDistance :: SrcSpan -> Int
  lineDistance (SrcSpan (Position _ _ l1 _ _) (Position _ _ l2 _ _)) = l2 - l1
  
  -- List of lines that are spanned
  spannedLines :: SrcSpan -> [Int]
  spannedLines (SrcSpan (Position _ _ l1 _ _) (Position _ _ l2 _ _)) = [l1..l2]
  
  initSrcSpan :: SrcSpan
  initSrcSpan = SrcSpan initPosition initPosition
  
  -- | Return the empty span at a given position (span between itself).
  emptySpan :: Position -> SrcSpan
  emptySpan pos = SrcSpan pos pos
  
  class Spanned a where
    getSpan :: a -> SrcSpan
    setSpan :: SrcSpan -> a -> a
  
    default getSpan :: (SecondParameter a SrcSpan) => a -> SrcSpan
    getSpan = getSecondParameter
  
    default setSpan :: (SecondParameter a SrcSpan) => SrcSpan -> a -> a
    setSpan = setSecondParameter
  
  instance Spanned SrcSpan where
    getSpan = id
    setSpan = const
  
  class (Spanned a, Spanned b) => SpannedPair a b where
    getTransSpan :: a -> b -> SrcSpan
  
  --------------------------------------------------------------------------------
  
  instance (Spanned a) => Spanned [a] where
    getSpan [] = error "Trying to find how long an empty list spans for."
    getSpan [x]   = getSpan x
    getSpan (x:xs) = getTransSpan x (last xs)
    setSpan _ _ = error "Cannot set span to an array"
  
  instance (Spanned a) => Spanned (NonEmpty a) where
    getSpan (x :| [])     = getSpan x
    getSpan (x :| (y:ys)) = getTransSpan x (last (y:ys))
    setSpan _ _ = error "Cannot set span to a non-empty list"
  
  instance (Spanned a, Spanned b) => Spanned (a, Maybe b) where
    getSpan (x, Just y) = getTransSpan x y
    getSpan (x,_) = getSpan x
    setSpan _ = undefined
  
  instance (Spanned a, Spanned b) => Spanned (Maybe a, b) where
    getSpan (Just x,y) = getTransSpan x y
    getSpan (_,y) = getSpan y
    setSpan _ = undefined
  
  instance (Spanned a, Spanned b) => Spanned (Either a b) where
    getSpan (Left x) = getSpan x
    getSpan (Right x) = getSpan x
    setSpan _ = undefined
  
  instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b) => Spanned (a, b) where
    getSpan (x,y) = getTransSpan x y
    setSpan _ = undefined
  
  instance {-# OVERLAPPING #-}(Spanned a, Spanned b, Spanned c) => Spanned (Maybe a, Maybe b, Maybe c) where
    getSpan (Just x,_,Just z) = getTransSpan x z
    getSpan (Just x,Just y,Nothing) = getTransSpan x y
    getSpan (Nothing,Just y,Just z) = getTransSpan y z
    getSpan (Just x,Nothing,Nothing) = getSpan x
    getSpan (Nothing,Just y,Nothing) = getSpan y
    getSpan (Nothing,Nothing,Just z) = getSpan z
    getSpan (Nothing,Nothing,Nothing) = undefined
    setSpan _ = undefined
  
  instance {-# OVERLAPPING #-}(Spanned a, Spanned b, Spanned c) => Spanned (a, Maybe b, Maybe c) where
    getSpan (x,_,Just z) = getTransSpan x z
    getSpan (x,Just y,Nothing) = getTransSpan x y
    getSpan (x,Nothing,Nothing) = getSpan x
    setSpan _ = undefined
  
  instance {-# OVERLAPPING #-} (Spanned a, Spanned b, Spanned c) => Spanned (Maybe a, b, c) where
    getSpan (Just x,_,z) = getTransSpan x z
    getSpan (_,y,z) = getSpan (y,z)
    setSpan _ = undefined
  
  instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b, Spanned c) => Spanned (a, b, c) where
    getSpan (x,_,z) = getTransSpan x z
    setSpan _ = undefined
  
  instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b) => SpannedPair a b where
    getTransSpan x y = SrcSpan l1 l2'
      where SrcSpan l1 _ = getSpan x
            SrcSpan _ l2' = getSpan y
  
  instance {-# OVERLAPS #-} (Spanned a, Spanned b) => SpannedPair a [b] where
    getTransSpan x [] = getSpan x
    getTransSpan x y = SrcSpan l1 l2'
      where SrcSpan l1 _ = getSpan x
            SrcSpan _ l2' = getSpan y
  
  instance {-# OVERLAPS #-} (Spanned a, Spanned b) => SpannedPair a [[b]] where
    getTransSpan x [] = getSpan x
    getTransSpan x y | all null y = getSpan x
    getTransSpan x y | any null y = getTransSpan x (filter (not . null) y)
    getTransSpan x y = SrcSpan l1 l2'
      where SrcSpan l1 _ = getSpan x
            SrcSpan _ l2' = getSpan y
  