content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}
  module Position where
  
  import Data.List(partition)
  import qualified Data.Generics as Generic
  
  import Eval
  import PPrint
  import PVPrint
  import FStringCompat
  import PreStrings(fsEmpty)
  import FileNameUtil(getRelativeFilePath)
  
  data Position = Position {
      pos_file :: !FString,
      pos_line :: !Int,
      pos_column :: !Int,
      pos_is_stdlib :: !Bool
  } deriving (Generic.Data, Generic.Typeable)
  
  mkPosition :: FString -> Int -> Int -> Position
  mkPosition f l c = Position f l c False
  
  mkPositionFull :: FString -> Int -> Int -> Bool -> Position
  mkPositionFull f l c is_stdlib = Position f l c is_stdlib
  
  instance Eq Position where
    (Position f1 l1 c1 _) == (Position f2 l2 c2 _) = (f1, l1, c1) == (f2, l2, c2)
  
  instance Ord Position where
    compare (Position f1 l1 c1 _) (Position f2 l2 c2 _) = compare (f1, l1, c1) (f2, l2, c2)
  
  class HasPosition a where
      getPosition :: a -> Position
  
  instance Show Position where
      show p = prPosition p
  
  instance Hyper Position where
      hyper p y = p `seq` y
  
  prPosition :: Position -> String
  prPosition (Position fs l c pred) =
      let f = getFString fs
          f' = getRelativeFilePath f
      in
      if l==(-2) && c<0 && f=="" then "Command line" else
      if l<0 && c<0 && f=="" then "Unknown position" else
      let lc = if l<0 then "" else "line " ++ show3 l ++ (if c < 0 then "" else ", column "++show3 c)
          show3 = show --until ((>=3) . length) (' ':) . show
      in        case f of
              "" -> lc
              _ -> show f' ++ (if null lc then "" else ", "++lc)
  
  prPositionConcise :: Position -> String
  prPositionConcise (Position fs l c pred) =
      let f = getFString fs
          f' = getRelativeFilePath f
      in
      if l==(-2) && c<0 && f=="" then "Command line" else
      if l<0 && c<0 && f=="" then "Unknown position" else
      let lc = if l<0 then "" else ":" ++ show3 l ++ (if c < 0 then "" else ":"++show3 c)
          show3 = show --until ((>=3) . length) (' ':) . show
      in        case f of
              "" -> lc
              _ -> f' ++ lc
  
  instance HasPosition Position where
      getPosition p = p
  
  -- #############################################################################
  -- #
  -- #############################################################################
  
  
  firstPos :: [Position] -> Position
  firstPos ps = case filter (/= noPosition) ps of
                []  -> noPosition
                [p] -> p
                psf -> firstPos2 psf
  
  firstPos2 :: [Position] -> Position
  firstPos2 [] = noPosition
  firstPos2 ps = case filter isUsefulPosition ps of
                []  -> -- trace("none " ++ (show (length ps)) ++ "\n") $
                       head ps
                [p] -> p
                filtered -> -- trace("first " ++ (show (length filtered)) ++ "\n") $
                            head filtered
  
  -- #############################################################################
  -- #
  -- #############################################################################
  
  isUsefulPosition :: Position -> Bool
  isUsefulPosition pos@(Position fs line column pred) =
      (not pred) -- && (not ((getFString fs) == "INTERNAL"))
  
  
  -- if no useful position is found in the list, returns first non-empty pos.
  -- takes a default if no non-empty position is found
  getMostUsefulPosition :: [Position] -> Position -> Position
  getMostUsefulPosition [] dflt = dflt
  getMostUsefulPosition xs dflt =
      let nonempty_xs = filter (/= noPosition) xs
          (useful,nonuseful) = partition isUsefulPosition nonempty_xs
      in  case (useful) of
              (p:_) -> p
              [] -> case (nonuseful) of
                        (p:_) -> p
                        _ -> dflt
  
  -- #############################################################################
  -- #
  -- #############################################################################
  
  isPreludePosition :: Position -> Bool
  isPreludePosition = pos_is_stdlib
  
  -- #############################################################################
  -- #
  -- #############################################################################
  
  cmdPosition :: Position
  cmdPosition = mkPosition fsEmpty (-2) (-1)
  
  noPosition :: Position
  noPosition = mkPosition fsEmpty (-1) (-1)
  
  remPositionFile :: Position -> Position
  remPositionFile (Position _ l c _) = mkPosition fsEmpty l c
  
  filePosition :: FString -> Position
  filePosition f = mkPosition f (-1) (-1)
  
  
  initialPosition :: String -> Position
  initialPosition f = mkPosition (mkFString f) 1 1
  
  
  newPosition :: String -> Int -> Int -> Position
  newPosition f l c = mkPosition (mkFString f) l c
  
  newLinePosition :: String -> Int -> Position
  newLinePosition f l = mkPosition (mkFString f) l 1
  
  
  updatePosChar :: Position -> Char -> Position
  updatePosChar specialPos@(Position _ _ (-1) _) _ = specialPos
  updatePosChar (Position file line column pred) '\n' = Position file (line+1) 1 pred
  updatePosChar (Position file line column pred) '\t' = Position file line (column + 8 - ((column - 1) `mod` 8)) pred
  updatePosChar (Position file line column pred) _ = Position file line (column + 1) pred
  
  isFirstColumn :: Position -> Bool
  isFirstColumn pos = (getPositionColumn pos) == 1
  
  -- backspace one column (only works for same-line when column > 1)
  updatePosBackspace :: Position -> Position
  updatePosBackspace pos@(Position file line column pred)
      | column > 1 = Position file line (column - 1) pred
      | otherwise = pos
  
  
  updatePosLineCol :: Position -> Int -> Int -> Position
  updatePosLineCol (Position f _ _ pred) newl newc =
          Position f newl newc pred
  
  updatePosFile :: Position -> FString -> Position
  updatePosFile (Position _ l c pred) newf =
          Position newf l c pred
  
  updatePosFileLineCol :: Position -> FString -> Int -> Int -> Position
  updatePosFileLineCol (Position _ _ _ pred) newf newl newc =
          Position newf newl newc pred
  
  updatePosString :: Position -> String -> Position
  updatePosString pos str = foldl updatePosChar pos str
  
  updatePosStdlib :: Position -> Bool -> Position
  updatePosStdlib pos is_stdlib = pos { pos_is_stdlib = is_stdlib }
  
  -- returns a pair of positions (pos1, pos2) where
  --   pos1 points at the last character of the input string
  --   pos2 points at the first character beyond the input string
  posAtEndAndAfterString :: Position -> String -> (Position, Position)
  posAtEndAndAfterString pos "" = (updatePosBackspace pos, pos)
  posAtEndAndAfterString pos [char] = (pos, updatePosChar pos char)
  posAtEndAndAfterString pos (char:chars) =
      posAtEndAndAfterString (updatePosChar pos char) chars
  
  
  getPositionColumn :: Position -> Int
  getPositionColumn (Position _ _ c _) = c
  
  getPositionLine :: Position -> Int
  getPositionLine (Position _ l _ _) = l
  
  
  getPositionFile :: Position -> String
  getPositionFile (Position fs _ _ _) = getFString fs
  
  instance PPrint Position where
      pPrint _ _ p = text (prPosition p)
  
  instance PVPrint Position where
      pvPrint _ _ p = text (prPosition p)
  
  bestPosition :: Position -> Position -> Position
  bestPosition p1 p2 = if p1 == noPosition then p2 else p1
  
  instance (HasPosition a) => HasPosition (Maybe a) where
      getPosition (Just x) = getPosition x
      getPosition Nothing = noPosition
  
  instance (HasPosition a, HasPosition b) => HasPosition (Either a b) where
      getPosition (Right x) = getPosition x
      getPosition (Left x) = getPosition x
  
  instance (HasPosition a) => HasPosition [a] where
      getPosition [] = noPosition
      getPosition (x:xs) = getPosition x `bestPosition` getPosition xs
  
  instance (HasPosition a, HasPosition b) => HasPosition (a, b) where
      getPosition (x, y) = getPosition x `bestPosition` getPosition y
  
  instance (HasPosition a, HasPosition b, HasPosition c) => HasPosition (a, b, c) where
      getPosition (x, y, z) = getPosition x `bestPosition` getPosition y `bestPosition` getPosition z
  
  instance (HasPosition a, HasPosition b, HasPosition c, HasPosition d) => HasPosition (a, b, c, d) where
      getPosition (x, y, z, w) = getPosition x `bestPosition` getPosition y `bestPosition` getPosition z `bestPosition` getPosition w
  
  instance HasPosition String where
      getPosition x = noPosition
  