content: -- | This module contains utilities for calculating positions and offsets. While
  -- tokens are annotated with ranges, CST nodes are not, but they can be
  -- dynamically derived with the functions in this module, which will return the
  -- first and last tokens for a given node.
  
  module Language.PureScript.CST.Positions where
  
  import Prelude
  
  import Data.Foldable (foldl')
  import Data.List.NonEmpty qualified as NE
  import Data.Maybe (fromMaybe)
  import Data.Text (Text)
  import Data.Void (Void)
  import Data.Text qualified as Text
  import Language.PureScript.CST.Types
  
  advanceToken :: SourcePos -> Token -> SourcePos
  advanceToken pos = applyDelta pos . tokenDelta
  
  advanceLeading :: SourcePos -> [Comment LineFeed] -> SourcePos
  advanceLeading = foldl' $ \a -> applyDelta a . commentDelta lineDelta
  
  advanceTrailing :: SourcePos -> [Comment Void] -> SourcePos
  advanceTrailing = foldl' $ \a -> applyDelta a . commentDelta (const (0, 0))
  
  tokenDelta :: Token -> (Int, Int)
  tokenDelta = \case
    TokLeftParen             -> (0, 1)
    TokRightParen            -> (0, 1)
    TokLeftBrace             -> (0, 1)
    TokRightBrace            -> (0, 1)
    TokLeftSquare            -> (0, 1)
    TokRightSquare           -> (0, 1)
    TokLeftArrow ASCII       -> (0, 2)
    TokLeftArrow Unicode     -> (0, 1)
    TokRightArrow ASCII      -> (0, 2)
    TokRightArrow Unicode    -> (0, 1)
    TokRightFatArrow ASCII   -> (0, 2)
    TokRightFatArrow Unicode -> (0, 1)
    TokDoubleColon ASCII     -> (0, 2)
    TokDoubleColon Unicode   -> (0, 1)
    TokForall ASCII          -> (0, 6)
    TokForall Unicode        -> (0, 1)
    TokEquals                -> (0, 1)
    TokPipe                  -> (0, 1)
    TokTick                  -> (0, 1)
    TokDot                   -> (0, 1)
    TokComma                 -> (0, 1)
    TokUnderscore            -> (0, 1)
    TokBackslash             -> (0, 1)
    TokLowerName qual name   -> (0, qualDelta qual + Text.length name)
    TokUpperName qual name   -> (0, qualDelta qual + Text.length name)
    TokOperator qual sym     -> (0, qualDelta qual + Text.length sym)
    TokSymbolName qual sym   -> (0, qualDelta qual + Text.length sym + 2)
    TokSymbolArr Unicode     -> (0, 3)
    TokSymbolArr ASCII       -> (0, 4)
    TokHole hole             -> (0, Text.length hole + 1)
    TokChar raw _            -> (0, Text.length raw + 2)
    TokInt raw _             -> (0, Text.length raw)
    TokNumber raw _          -> (0, Text.length raw)
    TokString raw _          -> multiLine 1 $ textDelta raw
    TokRawString raw         -> multiLine 3 $ textDelta raw
    TokLayoutStart           -> (0, 0)
    TokLayoutSep             -> (0, 0)
    TokLayoutEnd             -> (0, 0)
    TokEof                   -> (0, 0)
  
  qualDelta :: [Text] -> Int
  qualDelta = foldr ((+) . (+ 1) . Text.length) 0
  
  multiLine :: Int -> (Int, Int) -> (Int, Int)
  multiLine n (0, c) = (0, c + n + n)
  multiLine n (l, c) = (l, c + n)
  
  commentDelta :: (a -> (Int, Int)) -> Comment a -> (Int, Int)
  commentDelta k = \case
    Comment raw -> textDelta raw
    Space n -> (0, n)
    Line a -> k a
  
  lineDelta :: LineFeed -> (Int, Int)
  lineDelta _ = (1, 1)
  
  textDelta :: Text -> (Int, Int)
  textDelta = Text.foldl' go (0, 0)
    where
    go (!l, !c) = \case
      '\n' -> (l + 1, 1)
      _    -> (l, c + 1)
  
  applyDelta :: SourcePos -> (Int, Int) -> SourcePos
  applyDelta (SourcePos l c) = \case
    (0, n) -> SourcePos l (c + n)
    (k, d) -> SourcePos (l + k) d
  
  sepLast :: Separated a -> a
  sepLast (Separated hd []) = hd
  sepLast (Separated _ tl) = snd $ last tl
  
  type TokenRange = (SourceToken, SourceToken)
  
  toSourceRange :: TokenRange -> SourceRange
  toSourceRange (a, b) = widen (srcRange a) (srcRange b)
  
  widen :: SourceRange -> SourceRange -> SourceRange
  widen (SourceRange s1 _) (SourceRange _ e2) = SourceRange s1 e2
  
  srcRange :: SourceToken -> SourceRange
  srcRange = tokRange . tokAnn
  
  nameRange :: Name a -> TokenRange
  nameRange a = (nameTok a, nameTok a)
  
  qualRange :: QualifiedName a -> TokenRange
  qualRange a = (qualTok a, qualTok a)
  
  wrappedRange :: Wrapped a -> TokenRange
  wrappedRange Wrapped { wrpOpen, wrpClose } = (wrpOpen, wrpClose)
  
  moduleRange :: Module a -> TokenRange
  moduleRange Module { modKeyword, modWhere, modImports, modDecls } =
    case (modImports, modDecls) of
      ([], []) -> (modKeyword, modWhere)
      (is, []) -> (modKeyword, snd . importDeclRange $ last is)
      (_,  ds) -> (modKeyword, snd . declRange $ last ds)
  
  exportRange :: Export a -> TokenRange
  exportRange = \case
    ExportValue _ a -> nameRange a
    ExportOp _ a -> nameRange a
    ExportType _ a b
      | Just b' <- b -> (nameTok a, snd $ dataMembersRange b')
      | otherwise -> nameRange a
    ExportTypeOp _ a b -> (a, nameTok b)
    ExportClass _ a b -> (a, nameTok b)
    ExportModule _ a b -> (a, nameTok b)
  
  importDeclRange :: ImportDecl a -> TokenRange
  importDeclRange ImportDecl { impKeyword, impModule, impNames, impQual }
    | Just (_, modName) <- impQual = (impKeyword, nameTok modName)
    | Just (_, imports) <- impNames = (impKeyword, wrpClose imports)
    | otherwise = (impKeyword, nameTok impModule)
  
  importRange :: Import a -> TokenRange
  importRange = \case
    ImportValue _ a -> nameRange a
    ImportOp _ a -> nameRange a
    ImportType _ a b
      | Just b' <- b -> (nameTok a, snd $ dataMembersRange b')
      | otherwise -> nameRange a
    ImportTypeOp _ a b -> (a, nameTok b)
    ImportClass _ a b -> (a, nameTok b)
  
  dataMembersRange :: DataMembers a -> TokenRange
  dataMembersRange = \case
    DataAll _ a -> (a, a)
    DataEnumerated _ (Wrapped a _ b) -> (a, b)
  
  declRange :: Declaration a -> TokenRange
  declRange = \case
    DeclData _ hd ctors
      | Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs)
      | otherwise -> start
      where start = dataHeadRange hd
    DeclType _ a _ b -> (fst $ dataHeadRange a,  snd $ typeRange b)
    DeclNewtype _ a _ _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
    DeclClass _ hd body
      | Just (_, ts) <- body -> (fst start, snd . typeRange . lblValue $ NE.last ts)
      | otherwise -> start
      where start = classHeadRange hd
    DeclInstanceChain _ a -> (fst . instanceRange $ sepHead a, snd . instanceRange $ sepLast a)
    DeclDerive _ a _ b -> (a, snd $ instanceHeadRange b)
    DeclKindSignature _ a (Labeled _ _ b) -> (a, snd $ typeRange b)
    DeclSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
    DeclValue _ a -> valueBindingFieldsRange a
    DeclFixity _ (FixityFields a _ (FixityValue _ _ b)) -> (fst a, nameTok b)
    DeclFixity _ (FixityFields a _ (FixityType _ _ _ b)) -> (fst a, nameTok b)
    DeclForeign _ a _ b -> (a, snd $ foreignRange b)
    DeclRole _ a _ _ b -> (a, roleTok $ NE.last b)
  
  dataHeadRange :: DataHead a -> TokenRange
  dataHeadRange (DataHead kw name vars)
    | [] <- vars = (kw, nameTok name)
    | otherwise = (kw, snd . typeVarBindingRange $ last vars)
  
  dataCtorRange :: DataCtor a -> TokenRange
  dataCtorRange (DataCtor _ name fields)
    | [] <- fields = nameRange name
    | otherwise = (nameTok name, snd . typeRange $ last fields)
  
  classHeadRange :: ClassHead a -> TokenRange
  classHeadRange (ClassHead kw _ name vars fdeps)
    | Just (_, fs) <- fdeps = (kw, snd . classFundepRange $ sepLast fs)
    | [] <- vars = (kw, snd $ nameRange name)
    | otherwise = (kw, snd . typeVarBindingRange $ last vars)
  
  classFundepRange :: ClassFundep -> TokenRange
  classFundepRange = \case
    FundepDetermined arr bs -> (arr, nameTok $ NE.last bs)
    FundepDetermines as _ bs -> (nameTok $ NE.head as, nameTok $ NE.last bs)
  
  instanceRange :: Instance a -> TokenRange
  instanceRange (Instance hd bd)
    | Just (_, ts) <- bd = (fst start, snd . instanceBindingRange $ NE.last ts)
    | otherwise = start
    where start = instanceHeadRange hd
  
  instanceHeadRange :: InstanceHead a -> TokenRange
  instanceHeadRange (InstanceHead kw _ _ cls types)
    | [] <- types = (kw, qualTok cls)
    | otherwise = (kw, snd . typeRange $ last types)
  
  instanceBindingRange :: InstanceBinding a -> TokenRange
  instanceBindingRange = \case
    InstanceBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
    InstanceBindingName _ a -> valueBindingFieldsRange a
  
  foreignRange :: Foreign a -> TokenRange
  foreignRange = \case
    ForeignValue (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
    ForeignData a (Labeled _ _ b) -> (a, snd $ typeRange b)
    ForeignKind a b -> (a, nameTok b)
  
  valueBindingFieldsRange :: ValueBindingFields a -> TokenRange
  valueBindingFieldsRange (ValueBindingFields a _ b) = (nameTok a, snd $ guardedRange b)
  
  guardedRange :: Guarded a -> TokenRange
  guardedRange = \case
    Unconditional a b -> (a, snd $ whereRange b)
    Guarded as -> (fst . guardedExprRange $ NE.head as, snd . guardedExprRange $ NE.last as)
  
  guardedExprRange :: GuardedExpr a -> TokenRange
  guardedExprRange (GuardedExpr a _ _ b) = (a, snd $ whereRange b)
  
  whereRange :: Where a -> TokenRange
  whereRange (Where a bs)
    | Just (_, ls) <- bs = (fst $ exprRange a, snd . letBindingRange $ NE.last ls)
    | otherwise = exprRange a
  
  typeRange :: Type a -> TokenRange
  typeRange = \case
    TypeVar _ a -> nameRange a
    TypeConstructor _ a -> qualRange a
    TypeWildcard _ a -> (a, a)
    TypeHole _ a -> nameRange a
    TypeString _ a _ -> (a, a)
    TypeInt _ a b _ -> (fromMaybe b a, b)
    TypeRow _ a -> wrappedRange a
    TypeRecord _ a -> wrappedRange a
    TypeForall _ a _ _ b -> (a, snd $ typeRange b)
    TypeKinded _ a _ b -> (fst $ typeRange a, snd $ typeRange b)
    TypeApp _ a b -> (fst $ typeRange a, snd $ typeRange b)
    TypeOp _ a _ b -> (fst $ typeRange a, snd $ typeRange b)
    TypeOpName _ a -> qualRange a
    TypeArr _ a _ b -> (fst $ typeRange a, snd $ typeRange b)
    TypeArrName _ a -> (a, a)
    TypeConstrained _ a _ b -> (fst $ constraintRange a, snd $ typeRange b)
    TypeParens _ a -> wrappedRange a
    TypeUnaryRow _ a b -> (a, snd $ typeRange b)
  
  constraintRange :: Constraint a -> TokenRange
  constraintRange = \case
    Constraint _ name args
      | [] <- args -> qualRange name
      | otherwise -> (qualTok name, snd . typeRange $ last args)
    ConstraintParens _ wrp -> wrappedRange wrp
  
  typeVarBindingRange :: TypeVarBinding a -> TokenRange
  typeVarBindingRange = \case
    TypeVarKinded a -> wrappedRange a
    TypeVarName (atSign, a) -> (fromMaybe (nameTok a) atSign, nameTok a)
  
  exprRange :: Expr a -> TokenRange
  exprRange = \case
    ExprHole _ a -> nameRange a
    ExprSection _ a -> (a, a)
    ExprIdent _ a -> qualRange a
    ExprConstructor _ a -> qualRange a
    ExprBoolean _ a _ -> (a, a)
    ExprChar _ a _ -> (a, a)
    ExprString _ a _ -> (a, a)
    ExprNumber _ a _ -> (a, a)
    ExprArray _ a -> wrappedRange a
    ExprRecord _ a -> wrappedRange a
    ExprParens _ a -> wrappedRange a
    ExprTyped _ a _ b -> (fst $ exprRange a, snd $ typeRange b)
    ExprInfix _ a _ b -> (fst $ exprRange a, snd $ exprRange b)
    ExprOp _ a _ b -> (fst $ exprRange a, snd $ exprRange b)
    ExprOpName _ a -> qualRange a
    ExprNegate _ a b -> (a, snd $ exprRange b)
    ExprRecordAccessor _ (RecordAccessor a _ b) -> (fst $ exprRange a, lblTok $ sepLast b)
    ExprRecordUpdate _ a b -> (fst $ exprRange a, snd $ wrappedRange b)
    ExprApp _ a b -> (fst $ exprRange a, snd $ exprRange b)
    ExprVisibleTypeApp _ a _ b -> (fst $ exprRange a, snd $ typeRange b)
    ExprLambda _ (Lambda a _ _ b) -> (a, snd $ exprRange b)
    ExprIf _ (IfThenElse a _ _ _ _ b) -> (a, snd $ exprRange b)
    ExprCase _ (CaseOf a _ _ c) -> (a, snd . guardedRange . snd $ NE.last c)
    ExprLet _ (LetIn a _ _ b) -> (a, snd $ exprRange b)
    ExprDo _ (DoBlock a b) -> (a,  snd . doStatementRange $ NE.last b)
    ExprAdo _ (AdoBlock a _ _ b) -> (a, snd $ exprRange b)
  
  letBindingRange :: LetBinding a -> TokenRange
  letBindingRange = \case
    LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
    LetBindingName _ a -> valueBindingFieldsRange a
    LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
  
  doStatementRange :: DoStatement a -> TokenRange
  doStatementRange = \case
    DoLet a bs -> (a, snd . letBindingRange $ NE.last bs)
    DoDiscard a -> exprRange a
    DoBind a _ b -> (fst $ binderRange a, snd $ exprRange b)
  
  binderRange :: Binder a -> TokenRange
  binderRange = \case
    BinderWildcard _ a -> (a, a)
    BinderVar _ a -> nameRange a
    BinderNamed _ a _ b -> (nameTok a, snd $ binderRange b)
    BinderConstructor _ a bs
      | [] <- bs -> qualRange a
      | otherwise -> (qualTok a, snd . binderRange $ last bs)
    BinderBoolean _ a _ -> (a, a)
    BinderChar _ a _ -> (a, a)
    BinderString _ a _ -> (a, a)
    BinderNumber _ a b _
      | Just a' <- a -> (a', b)
      | otherwise -> (b, b)
    BinderArray _ a -> wrappedRange a
    BinderRecord _ a -> wrappedRange a
    BinderParens _ a -> wrappedRange a
    BinderTyped _ a _ b -> (fst $ binderRange a, snd $ typeRange b)
    BinderOp _ a _ b -> (fst $ binderRange a, snd $ binderRange b)
  
  recordUpdateRange :: RecordUpdate a -> TokenRange
  recordUpdateRange = \case
    RecordUpdateLeaf a _ b -> (lblTok a, snd $ exprRange b)
    RecordUpdateBranch a (Wrapped _ _ b) -> (lblTok a, b)
  