{- |
    Module      :  AST.PositionUtils
    Description :  Auxiliary functions for positions

    This module provides some auxiliary functions concerning positions.
-}





module AST.PositionUtils where

import qualified AST.Ident     as I
import           AST.Span (Pos, Span, start, virtualPos)
import           AST.SpanAST
import           AST.Token

-- |Return the line of a position
line :: Pos -> Int
line pos = fst pos

-- |Return the column of a position
col :: Pos -> Int
col pos = snd pos

-- |Check whether the columns in a list of positions are all equal
allColEq :: [Pos] -> Bool
allColEq xs = case xs of
  [] -> True
  _  -> all (== col (head xs)) (map col (tail xs))

-- |Check whether the lines in a list of positions are all equal
allLinesEq :: [Pos] -> Bool
allLinesEq xs = case xs of
  [] -> True
  _  -> all (== line (head xs)) (map line (tail xs))

-- |move given position by n columns
moveColBy :: Pos -> Int -> Pos
moveColBy (l,c) n = (l, c + n)

--- |Change a position by a delta
--- @param l  -  line
--- @param c  -  column
--- @param ml -  delta line
--- @param mc -  delta column
--- @return   -  input position changed by delta line and delta column

relocate :: Pos -> (Int, Int) -> Pos
relocate (l, c) (ml, mc) = (l + ml, c + mc)

-- ----------------------------------------------------------------------------
-- Get positions of AST elements
-- ----------------------------------------------------------------------------

-- |Get start position of QualIdent
qidPos :: I.QualIdent -> Pos
qidPos (I.QualIdent _ i) = idPos i

-- |Get start position of Ident
idPos :: I.Ident -> Pos
idPos (I.Ident sp _ _) = start sp

-- |Get start position of Ident that might be surrounded by
-- |some kind of symbols, e.g. parens or backticks
sidPos :: I.SymIdent -> Pos
sidPos (I.SymIdent mpl i _) = case mpl of
  Just pl -> start pl
  Nothing -> idPos i

-- |Get start position of QualIdent that might be surrounded by
-- |some kind of symbols, e.g. parens or backticks
sqidPos :: I.SymQualIdent -> Pos
sqidPos (I.SymQualIdent mpl qi _) = case mpl of
  Just pl -> start pl
  Nothing -> qidPos qi

-- |Get start position of Export
exportPos :: Export -> Pos
exportPos e = case e of
  Export         qi          -> sqidPos qi
  ExportTypeWith qi _  _ _ _ -> qidPos  qi
  ExportTypeAll  qi _  _ _   -> qidPos  qi
  ExportModule   _  mi       -> start (I.midSpan mi)

-- |Get start position of Decl
declPos :: Decl -> Pos
declPos d = case d of
  PatternDecl pat _ -> patPos pat
  _                 -> virtualPos

-- |Get position of equality sign in Decl
declPosEq :: Decl -> Pos
declPosEq d = case d of
  PatternDecl _ rhs -> rhsPos rhs
  _                 -> virtualPos

-- |Get position of Infix Keyword
infPos :: Infix -> Pos
infPos i = case i of
  InfixL s -> start s
  InfixR s -> start s
  Infix  s -> start s

-- |Get start position of ConstrDecl
constrDeclPos :: ConstrDecl -> Pos
constrDeclPos c = case c of
  ConstrDecl _ i  _       -> idPos i
  ConOpDecl  _ te _ _     -> typeExprPos te
  RecordDecl _ i  _ _ _ _ -> idPos i

-- |Get Type positions of ConstrDecl
constrDeclConstrTypePos :: ConstrDecl -> [Pos]
constrDeclConstrTypePos cd = case cd of
  ConstrDecl _ _ cts       -> if null cts
                                then [virtualPos]
                                else map typeExprPos cts
  RecordDecl _ _ _ fds _ _ -> if null fds
                                then [virtualPos]
                                else map fieldDeclTEPos fds
  _                        -> [virtualPos]

-- |Get position of first Type in ConstrDecl
firstCDConstrTypePos :: ConstrDecl -> Pos
firstCDConstrTypePos cd = case cd of
  ConstrDecl _ _ cts -> if null cts then virtualPos else typeExprPos $ head cts
  _                  -> virtualPos

-- |Get position of commas in FieldDecl
fieldDeclCPos :: FieldDecl -> [Pos]
fieldDeclCPos (FieldDecl _ sps _ _) = map start sps

-- | Get position of doublecolon in FieldDecl
fieldDeclDCPos :: FieldDecl -> Pos
fieldDeclDCPos (FieldDecl _ _ sp _) = start sp

-- |Get position of first constructor in FieldDecl
fieldDeclIDPos :: FieldDecl -> Pos
fieldDeclIDPos (FieldDecl ids _ _ _) = idPos $ head ids

-- |Get position of TypeExpression in FieldDecl
fieldDeclTEPos :: FieldDecl -> Pos
fieldDeclTEPos (FieldDecl _ _ _ te) = typeExprPos te

-- |Get start position of TypeExpr
typeExprPos :: TypeExpr -> Pos
typeExprPos te = case te of
  ConstructorType msp qi _ _ -> case msp of
                                    Just sp -> start sp
                                    Nothing -> qidPos qi
  VariableType    i          -> idPos i
  TupleType       sp   _ _ _ -> start sp
  ListType        sp   _ _   -> start sp
  ArrowType       te1 _ _    -> typeExprPos te1
  ParenType       sp   _ _   -> start sp

-- |Get position of equality sign or rightarrow in Rhs
rhsPos :: Rhs -> Pos
rhsPos rhs = case rhs of
  SimpleRhs  sp _ _ _   -> start sp
  GuardedRhs sp _ _ _ _ -> start sp

-- |Get start position of Lhs
lhsPos :: Lhs -> Pos
lhsPos lhs = case lhs of
  FunLhs si _   -> sidPos si
  OpLhs  p  _ _ -> patPos p
  ApLhs  l  _   -> lhsPos l

-- |Get start position of CondExpr
condExprPos :: CondExpr -> Pos
condExprPos (CondExpr _ sp _) = start sp

-- |Get start position of Literal
litPos :: Literal -> Pos
litPos l = case l of
  Char   sp _ -> start sp
  Int    sp _ -> start sp
  Float  sp _ -> start sp
  String sp _ -> start sp

-- |Get start position of Pattern
patPos :: Pattern -> Pos
patPos p = case p of
  LiteralPattern     l             -> litPos l
  NegativePattern    i   _         -> idPos  i
  VariablePattern    i             -> idPos  i
  ConstructorPattern qi  _         -> qidPos qi
  InfixPattern       pat _   _     -> patPos pat
  ParenPattern       _   pat _     -> patPos pat
  RecordPattern      qi  _   _ _ _ -> qidPos qi
  TuplePattern       spl  _   _ _  -> start spl
  ListPattern        spl  _   _ _  -> start spl
  AsPattern          i   _   _     -> idPos  i
  LazyPattern        sp  _         -> start sp
  FunctionPattern    qi  _         -> qidPos qi
  InfixFuncPattern   pat _   _     -> patPos pat

-- |Get start position of Expression
exprPos :: Expression -> Pos
exprPos e = case e of
  Literal        l               -> litPos   l
  Variable       v               -> sqidPos  v
  Constructor    qi              -> sqidPos  qi
  Paren          spl _ _         -> start spl
  Typed          e1 _ _          -> exprPos  e1
  Record         qi _ _ _ _      -> qidPos   qi
  RecordUpdate   e1 _ _ _ _      -> exprPos  e1
  Tuple          spl _ _ _       -> start spl
  List           spl _ _ _       -> start spl
  ListCompr      spl _ _ _ _ _   -> start spl
  EnumFrom       spl _ _ _       -> start spl
  EnumFromThen   spl _ _ _ _ _   -> start spl
  EnumFromTo     spl _ _ _ _     -> start spl
  EnumFromThenTo spl _ _ _ _ _ _ -> start spl
  UnaryMinus     i  _            -> idPos    i
  Apply          e1 _            -> exprPos  e1
  InfixApply     e1 _ _          -> exprPos  e1
  LeftSection    spl _ _ _       -> start spl
  RightSection   spl _ _ _       -> start spl
  Lambda         sp  _ _ _       -> start sp
  Let            sp  _ _ _       -> start sp
  Do             sp  _ _         -> start sp
  IfThenElse     spi _ _ _ _ _   -> start spi
  Case           _  sp _ _ _     -> start sp

-- |Get start position of Statement
stmtPos :: Statement -> Pos
stmtPos s = case s of
  StmtExpr       e -> exprPos e
  StmtDecl     sp _ -> start sp
  StmtBind _ pat _ -> patPos pat

-- |Get position of rightarrow in Alt
altPos :: Alt -> Pos
altPos (Alt _ rhs) = rhsPos rhs

-- span computation

-- TODO: Remove when curry-frontend was extended correspondingly

-- | Compute for a given token and its starting position a corresponding span
spanToken :: (Pos,Token) -> (Span,Token)
spanToken posTok = case posTok of
  (p,   CharTok c) -> ((p, moveColBy p (length (show c) - 1)), CharTok c)
  (p,    IntTok i) -> ((p, moveColBy p (length (show i) - 1)), IntTok i)
  (p,  FloatTok f) -> ((p, moveColBy p (length (show f) - 1)), FloatTok f)
  (p, StringTok s) -> ((p, moveColBy p (length (show s) - 1)), StringTok s)

  (p,        Id i) -> ((p, moveColBy p (length i - 1)), Id i)
  (p,      QId qi) -> ((p, moveColBy p (length qi - 1)), QId qi)
  (p,       Sym s) -> ((p, moveColBy p (length s - 1)), Sym s)
  (p,     QSym qs) -> ((p, moveColBy p (length qs - 1)), QSym qs)

  (p,     KW_case) -> ((p, moveColBy p 3), KW_case)
  (p,     KW_data) -> ((p, moveColBy p 3), KW_data)
  (p,       KW_do) -> ((p, moveColBy p 1), KW_do)
  (p,     KW_else) -> ((p, moveColBy p 3), KW_else)
  (p, KW_external) -> ((p, moveColBy p 7), KW_external)
  (p,    KW_fcase) -> ((p, moveColBy p 4), KW_fcase)
  (p,  KW_foreign) -> ((p, moveColBy p 6), KW_foreign)
  (p,     KW_free) -> ((p, moveColBy p 3), KW_free)
  (p,       KW_if) -> ((p, moveColBy p 1), KW_if)
  (p,   KW_import) -> ((p, moveColBy p 5), KW_import)
  (p,       KW_in) -> ((p, moveColBy p 1), KW_in)
  (p,    KW_infix) -> ((p, moveColBy p 4), KW_infix)
  (p,   KW_infixl) -> ((p, moveColBy p 5), KW_infixl)
  (p,   KW_infixr) -> ((p, moveColBy p 5), KW_infixr)
  (p,      KW_let) -> ((p, moveColBy p 2), KW_let)
  (p,   KW_module) -> ((p, moveColBy p 5), KW_module)
  (p,  KW_newtype) -> ((p, moveColBy p 6), KW_newtype)
  (p,       KW_of) -> ((p, moveColBy p 1), KW_of)
  (p,     KW_then) -> ((p, moveColBy p 3), KW_then)
  (p,     KW_type) -> ((p, moveColBy p 3), KW_type)
  (p,    KW_where) -> ((p, moveColBy p 4), KW_where)

  (p,      DotDot) -> ((p, moveColBy p 1), DotDot)
  (p, DoubleColon) -> ((p, moveColBy p 1), DoubleColon)
  (p,   LeftArrow) -> ((p, moveColBy p 1), LeftArrow)
  (p,  RightArrow) -> ((p, moveColBy p 1), RightArrow)
  (p,        Bind) -> ((p, moveColBy p 1), Bind)
  (p,      Select) -> ((p, moveColBy p 1), Select)

  (p,        Id_as) -> ((p, moveColBy p 1), Id_as)
  (p,     Id_ccall) -> ((p, moveColBy p 4), Id_ccall)
  (p,    Id_forall) -> ((p, moveColBy p 5), Id_forall)
  (p,    Id_hiding) -> ((p, moveColBy p 5), Id_hiding)
  (p, Id_interface) -> ((p, moveColBy p 8), Id_interface)
  (p, Id_primitive) -> ((p, moveColBy p 8), Id_primitive)
  (p, Id_qualified) -> ((p, moveColBy p 8), Id_qualified)

  (p, SymMinusDot) -> ((p, moveColBy p 1), SymMinusDot)

  (p, PragmaLanguage    ) -> ((p, moveColBy p 11), PragmaLanguage)
  (p, PragmaOptions ms s) -> ((p, moveColBy p (length s + 11)), PragmaOptions ms s)
  (p, PragmaHiding      ) -> ((p, moveColBy p 9), PragmaHiding)
  (p, PragmaEnd         ) -> ((p, moveColBy p 2), PragmaEnd)

  (p,             tok) -> ((p, p), tok)