{-# LANGUAGE MultiParamTypeClasses , FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-overlapping-patterns #-}

module GHC.Util.Brackets (Brackets(..), isApp,isOpApp,isAnyApp) where

import GHC.Hs
import GHC.Types.SrcLoc
import GHC.Types.SourceText
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Refact.Types

class Brackets a where
  remParen :: a -> Maybe a -- Remove one paren or nothing if there is no paren.
  addParen :: a -> a -- Write out a paren.
  -- | Is this item lexically requiring no bracketing ever i.e. is
  -- totally atomic.
  isAtom :: a -> Bool
  -- | Is the child safe free from brackets in the parent
  -- position. Err on the side of caution, True = don't know.
  needBracket :: Int -> a -> a -> Bool
  findType :: a -> RType

instance Brackets (LocatedA (HsExpr GhcPs)) where
  -- When GHC parses a section in concrete syntax, it will produce an
  -- 'HsPar (Section[L|R])'. There is no concrete syntax that will
  -- result in a "naked" section. Consequently, given an expression,
  -- when stripping brackets (c.f. 'Hint.Brackets), don't remove the
  -- paren's surrounding a section - they are required.
  remParen :: LocatedA (HsExpr GhcPs) -> Maybe (LocatedA (HsExpr GhcPs))
remParen (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ (L SrcSpanAnnA
_ SectionL{}) LHsToken ")" GhcPs
_)) = Maybe (LocatedA (HsExpr GhcPs))
forall a. Maybe a
Nothing
  remParen (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ (L SrcSpanAnnA
_ SectionR{}) LHsToken ")" GhcPs
_)) = Maybe (LocatedA (HsExpr GhcPs))
forall a. Maybe a
Nothing
  remParen (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ LHsExpr GhcPs
x LHsToken ")" GhcPs
_)) = LocatedA (HsExpr GhcPs) -> Maybe (LocatedA (HsExpr GhcPs))
forall a. a -> Maybe a
Just LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
x
  remParen LocatedA (HsExpr GhcPs)
_ = Maybe (LocatedA (HsExpr GhcPs))
forall a. Maybe a
Nothing

  addParen :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
addParen = LHsExpr GhcPs -> LHsExpr GhcPs
LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar

  isAtom :: LocatedA (HsExpr GhcPs) -> Bool
isAtom (L SrcSpanAnnA
_ HsExpr GhcPs
x) = case HsExpr GhcPs
x of
      HsVar{} -> Bool
True
      HsUnboundVar{} -> Bool
True
      -- Technically atomic, but lots of people think it shouldn't be
      HsRecSel{} -> Bool
False
      -- Only relevant for OverloadedRecordDot extension
      HsGetField{} -> Bool
True
      HsOverLabel{} -> Bool
True
      HsIPVar{} -> Bool
True
      -- Note that sections aren't atoms (but parenthesized sections are).
      HsPar{} -> Bool
True
      ExplicitTuple{} -> Bool
True
      ExplicitSum{} -> Bool
True
      ExplicitList{} -> Bool
True
      RecordCon{} -> Bool
True
      RecordUpd{} -> Bool
True
      ArithSeq{}-> Bool
True
      HsTypedBracket{} -> Bool
True
      HsUntypedBracket{} -> Bool
True
      -- HsSplice might be $foo, where @($foo) would require brackets,
      -- but in that case the $foo is a type, so we can still mark Splice as atomic
      HsTypedSplice{} -> Bool
True
      HsUntypedSplice{} -> Bool
True
      HsOverLit XOverLitE GhcPs
_ HsOverLit GhcPs
x | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsOverLit GhcPs -> Bool
forall {p}. HsOverLit p -> Bool
isNegativeOverLit HsOverLit GhcPs
x -> Bool
True
      HsLit XLitE GhcPs
_ HsLit GhcPs
x     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsLit GhcPs -> Bool
forall {x}. HsLit x -> Bool
isNegativeLit HsLit GhcPs
x     -> Bool
True
      HsExpr GhcPs
_  -> Bool
False
      where
        isNegativeLit :: HsLit x -> Bool
isNegativeLit (HsInt XHsInt x
_ IntegralLit
i) = IntegralLit -> Bool
il_neg IntegralLit
i
        isNegativeLit (HsRat XHsRat x
_ FractionalLit
f Type
_) = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeLit (HsFloatPrim XHsFloatPrim x
_ FractionalLit
f) = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeLit (HsDoublePrim XHsDoublePrim x
_ FractionalLit
f) = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeLit (HsIntPrim XHsIntPrim x
_ Integer
x) = Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
        isNegativeLit (HsInt64Prim XHsInt64Prim x
_ Integer
x) = Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
        isNegativeLit (HsInteger XHsInteger x
_ Integer
x Type
_) = Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
        isNegativeLit HsLit x
_ = Bool
False
        isNegativeOverLit :: HsOverLit p -> Bool
isNegativeOverLit OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=HsIntegral IntegralLit
i} = IntegralLit -> Bool
il_neg IntegralLit
i
        isNegativeOverLit OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=HsFractional FractionalLit
f} = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeOverLit HsOverLit p
_ = Bool
False
  isAtom LocatedA (HsExpr GhcPs)
_ = Bool
False -- '{-# COMPLETE L #-}'

  needBracket :: Int -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs) -> Bool
needBracket Int
i LocatedA (HsExpr GhcPs)
parent LocatedA (HsExpr GhcPs)
child -- Note: i is the index in children, not in the AST.
     | LocatedA (HsExpr GhcPs) -> Bool
forall a. Brackets a => a -> Bool
isAtom LocatedA (HsExpr GhcPs)
child = Bool
False
     | LHsExpr GhcPs -> Bool
isSection LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
parent, L SrcSpanAnnA
_ HsApp{} <- LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ OpApp{} <- LocatedA (HsExpr GhcPs)
parent, L SrcSpanAnnA
_ HsApp{} <- LocatedA (HsExpr GhcPs)
child, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 Bool -> Bool -> Bool
|| LocatedA (HsExpr GhcPs) -> Bool
isAtomOrApp LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ ExplicitList{} <- LocatedA (HsExpr GhcPs)
parent = Bool
False
     | L SrcSpanAnnA
_ ExplicitTuple{} <- LocatedA (HsExpr GhcPs)
parent = Bool
False
     | L SrcSpanAnnA
_ HsIf{} <- LocatedA (HsExpr GhcPs)
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ HsApp{} <- LocatedA (HsExpr GhcPs)
parent, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0, L SrcSpanAnnA
_ HsApp{} <- LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ ExprWithTySig{} <- LocatedA (HsExpr GhcPs)
parent, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0, LHsExpr GhcPs -> Bool
isApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ RecordCon{} <- LocatedA (HsExpr GhcPs)
parent = Bool
False
     | L SrcSpanAnnA
_ RecordUpd{} <- LocatedA (HsExpr GhcPs)
parent, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Bool
False

     -- These all have view patterns embedded within them, or are naturally followed by ->, so we have to watch out for
     -- @(x::y) -> z@ which is valid, as either a type annotation, or a view pattern.
     | L SrcSpanAnnA
_ HsLet{} <- LocatedA (HsExpr GhcPs)
parent, LHsExpr GhcPs -> Bool
isApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ HsDo{} <- LocatedA (HsExpr GhcPs)
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ HsLam{} <- LocatedA (HsExpr GhcPs)
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
child = Bool
False
     | L SrcSpanAnnA
_ HsCase{} <- LocatedA (HsExpr GhcPs)
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
child = Bool
False

     | L SrcSpanAnnA
_ HsPar{} <- LocatedA (HsExpr GhcPs)
parent = Bool
False
     | Bool
otherwise = Bool
True

  findType :: LocatedA (HsExpr GhcPs) -> RType
findType LocatedA (HsExpr GhcPs)
_ = RType
Expr

-- | Am I an HsApp such that having me in an infix doesn't require brackets.
--   Before BlockArguments that was _all_ HsApps. Now, imagine:
--
--   (f \x -> x) *> ...
--   (f do x) *> ...
isAtomOrApp :: LocatedA (HsExpr GhcPs) -> Bool
isAtomOrApp :: LocatedA (HsExpr GhcPs) -> Bool
isAtomOrApp LocatedA (HsExpr GhcPs)
x | LocatedA (HsExpr GhcPs) -> Bool
forall a. Brackets a => a -> Bool
isAtom LocatedA (HsExpr GhcPs)
x = Bool
True
isAtomOrApp (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
_ LHsExpr GhcPs
x)) = LocatedA (HsExpr GhcPs) -> Bool
isAtomOrApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
x
isAtomOrApp LocatedA (HsExpr GhcPs)
_ = Bool
False

instance Brackets (LocatedA (Pat GhcPs)) where
  remParen :: LocatedA (Pat GhcPs) -> Maybe (LocatedA (Pat GhcPs))
remParen (L SrcSpanAnnA
_ (ParPat XParPat GhcPs
_ LHsToken "(" GhcPs
_ LPat GhcPs
x LHsToken ")" GhcPs
_)) = LocatedA (Pat GhcPs) -> Maybe (LocatedA (Pat GhcPs))
forall a. a -> Maybe a
Just LPat GhcPs
LocatedA (Pat GhcPs)
x
  remParen LocatedA (Pat GhcPs)
_ = Maybe (LocatedA (Pat GhcPs))
forall a. Maybe a
Nothing

  addParen :: LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs)
addParen = LPat GhcPs -> LPat GhcPs
LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs)
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat

  isAtom :: LocatedA (Pat GhcPs) -> Bool
isAtom (L SrcSpanAnnA
_ Pat GhcPs
x) = case Pat GhcPs
x of
    ParPat{} -> Bool
True
    TuplePat{} -> Bool
True
    ListPat{} -> Bool
True
    -- This is technically atomic, but lots of people think it shouldn't be
    ConPat XConPat GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
_ RecCon{} -> Bool
False
    -- Before we only checked args, but not type args, resulting in a
    -- false positive for things like (Proxy @a)
    ConPat XConPat GhcPs
_ XRec GhcPs (ConLikeP GhcPs)
_ (PrefixCon [] []) -> Bool
True
    VarPat{} -> Bool
True
    WildPat{} -> Bool
True
    SumPat{} -> Bool
True
    AsPat{} -> Bool
True
    SplicePat{} -> Bool
True
    LitPat XLitPat GhcPs
_ HsLit GhcPs
x | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsLit GhcPs -> Bool
forall {x}. HsLit x -> Bool
isSignedLit HsLit GhcPs
x -> Bool
True
    Pat GhcPs
_ -> Bool
False
    where
      isSignedLit :: HsLit x -> Bool
isSignedLit HsInt{} = Bool
True
      isSignedLit HsIntPrim{} = Bool
True
      isSignedLit HsInt64Prim{} = Bool
True
      isSignedLit HsInteger{} = Bool
True
      isSignedLit HsRat{} = Bool
True
      isSignedLit HsFloatPrim{} = Bool
True
      isSignedLit HsDoublePrim{} = Bool
True
      isSignedLit HsLit x
_ = Bool
False
  isAtom LocatedA (Pat GhcPs)
_ = Bool
False -- '{-# COMPLETE L #-}'

  needBracket :: Int -> LocatedA (Pat GhcPs) -> LocatedA (Pat GhcPs) -> Bool
needBracket Int
_ LocatedA (Pat GhcPs)
parent LocatedA (Pat GhcPs)
child
    | LocatedA (Pat GhcPs) -> Bool
forall a. Brackets a => a -> Bool
isAtom LocatedA (Pat GhcPs)
child = Bool
False
    | L SrcSpanAnnA
_ TuplePat{} <- LocatedA (Pat GhcPs)
parent = Bool
False
    | L SrcSpanAnnA
_ ListPat{} <- LocatedA (Pat GhcPs)
parent = Bool
False
    | Bool
otherwise = Bool
True

  findType :: LocatedA (Pat GhcPs) -> RType
findType LocatedA (Pat GhcPs)
_ = RType
Pattern

instance Brackets (LocatedA (HsType GhcPs)) where
  remParen :: LocatedA (HsType GhcPs) -> Maybe (LocatedA (HsType GhcPs))
remParen (L SrcSpanAnnA
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
x)) = LocatedA (HsType GhcPs) -> Maybe (LocatedA (HsType GhcPs))
forall a. a -> Maybe a
Just LHsType GhcPs
LocatedA (HsType GhcPs)
x
  remParen LocatedA (HsType GhcPs)
_ = Maybe (LocatedA (HsType GhcPs))
forall a. Maybe a
Nothing
  addParen :: LocatedA (HsType GhcPs) -> LocatedA (HsType GhcPs)
addParen LocatedA (HsType GhcPs)
e = HsType GhcPs -> LocatedA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsType GhcPs -> LocatedA (HsType GhcPs))
-> HsType GhcPs -> LocatedA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
EpAnn AnnParen
forall ann. EpAnn ann
EpAnnNotUsed LHsType GhcPs
LocatedA (HsType GhcPs)
e

  isAtom :: LocatedA (HsType GhcPs) -> Bool
isAtom (L SrcSpanAnnA
_ HsType GhcPs
x) = case HsType GhcPs
x of
      HsParTy{} -> Bool
True
      HsTupleTy{} -> Bool
True
      HsListTy{} -> Bool
True
      HsExplicitTupleTy{} -> Bool
True
      HsExplicitListTy{} -> Bool
True
      HsTyVar{} -> Bool
True
      HsSumTy{} -> Bool
True
      HsWildCardTy{} -> Bool
True
      -- HsSpliceTy{} is not atomic, because of @($foo)
      HsType GhcPs
_ -> Bool
False
  isAtom LocatedA (HsType GhcPs)
_ = Bool
False -- '{-# COMPLETE L #-}'

  needBracket :: Int -> LocatedA (HsType GhcPs) -> LocatedA (HsType GhcPs) -> Bool
needBracket Int
_ LocatedA (HsType GhcPs)
parent LocatedA (HsType GhcPs)
child
    | LocatedA (HsType GhcPs) -> Bool
forall a. Brackets a => a -> Bool
isAtom LocatedA (HsType GhcPs)
child = Bool
False
-- a -> (b -> c) is not a required bracket, but useful for documentation about arity etc.
--        | TyFun{} <- parent, i == 1, TyFun{} <- child = False
    | L SrcSpanAnnA
_ HsFunTy{} <- LocatedA (HsType GhcPs)
parent, L SrcSpanAnnA
_ HsAppTy{} <- LocatedA (HsType GhcPs)
child = Bool
False
    | L SrcSpanAnnA
_ HsTupleTy{} <- LocatedA (HsType GhcPs)
parent = Bool
False
    | L SrcSpanAnnA
_ HsListTy{} <- LocatedA (HsType GhcPs)
parent = Bool
False
    | L SrcSpanAnnA
_ HsExplicitTupleTy{} <- LocatedA (HsType GhcPs)
parent = Bool
False
    | L SrcSpanAnnA
_ HsListTy{} <- LocatedA (HsType GhcPs)
parent = Bool
False
    | L SrcSpanAnnA
_ HsExplicitListTy{} <- LocatedA (HsType GhcPs)
parent = Bool
False
    | L SrcSpanAnnA
_ HsOpTy{} <- LocatedA (HsType GhcPs)
parent, L SrcSpanAnnA
_ HsAppTy{} <- LocatedA (HsType GhcPs)
child = Bool
False
    | L SrcSpanAnnA
_ HsParTy{} <- LocatedA (HsType GhcPs)
parent = Bool
False
    | Bool
otherwise = Bool
True

  findType :: LocatedA (HsType GhcPs) -> RType
findType LocatedA (HsType GhcPs)
_ = RType
Type