{-# 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 SrcLoc
import BasicTypes
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr

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

instance Brackets (LHsExpr 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 :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
remParen (L _ (HsPar _ (L _ SectionL{}))) = Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing
  remParen (L _ (HsPar _ (L _ SectionR{}))) = Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing
  remParen (L _ (HsPar _ x :: LHsExpr GhcPs
x)) = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a. a -> Maybe a
Just LHsExpr GhcPs
x
  remParen _ = Maybe (LHsExpr GhcPs)
forall a. Maybe a
Nothing

  addParen :: LHsExpr GhcPs -> LHsExpr GhcPs
addParen e :: LHsExpr GhcPs
e = SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs)
-> SrcSpanLess (LHsExpr GhcPs) -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noExtField LHsExpr GhcPs
e

  isAtom :: LHsExpr GhcPs -> Bool
isAtom (L _ x :: HsExpr GhcPs
x) = case HsExpr GhcPs
x of
      HsVar{} -> Bool
True
      HsUnboundVar{} -> Bool
True
      HsRecFld{} -> 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
      HsBracket{} -> Bool
True
      HsSpliceE {} -> Bool
True
      HsOverLit _ x :: 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 _ x :: 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
      _  -> Bool
False
      where
        isNegativeLit :: HsLit x -> Bool
isNegativeLit (HsInt _ i :: IntegralLit
i) = IntegralLit -> Bool
il_neg IntegralLit
i
        isNegativeLit (HsRat _ f :: FractionalLit
f _) = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeLit (HsFloatPrim _ f :: FractionalLit
f) = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeLit (HsDoublePrim _ f :: FractionalLit
f) = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeLit (HsIntPrim _ x :: Integer
x) = Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0
        isNegativeLit (HsInt64Prim _ x :: Integer
x) = Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0
        isNegativeLit (HsInteger _ x :: Integer
x _) = Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0
        isNegativeLit _ = Bool
False
        isNegativeOverLit :: HsOverLit p -> Bool
isNegativeOverLit OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=HsIntegral i :: IntegralLit
i} = IntegralLit -> Bool
il_neg IntegralLit
i
        isNegativeOverLit OverLit {ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=HsFractional f :: FractionalLit
f} = FractionalLit -> Bool
fl_neg FractionalLit
f
        isNegativeOverLit _ = Bool
False
  isAtom _ = Bool
False -- '{-# COMPLETE L #-}'

  needBracket :: Int -> LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
needBracket i :: Int
i parent :: LHsExpr GhcPs
parent child :: LHsExpr GhcPs
child -- Note: i is the index in children, not in the AST.
     | LHsExpr GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
child = Bool
False
     | LHsExpr GhcPs -> Bool
isSection LHsExpr GhcPs
parent, L _ HsApp{} <- LHsExpr GhcPs
child = Bool
False
     | L _ OpApp{} <- LHsExpr GhcPs
parent, L _ HsApp{} <- LHsExpr GhcPs
child, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 Bool -> Bool -> Bool
|| LHsExpr GhcPs -> Bool
isAtomOrApp LHsExpr GhcPs
child = Bool
False
     | L _ ExplicitList{} <- LHsExpr GhcPs
parent = Bool
False
     | L _ ExplicitTuple{} <- LHsExpr GhcPs
parent = Bool
False
     | L _ HsIf{} <- LHsExpr GhcPs
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
child = Bool
False
     | L _ HsApp{} <- LHsExpr GhcPs
parent, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0, L _ HsApp{} <- LHsExpr GhcPs
child = Bool
False
     | L _ ExprWithTySig{} <- LHsExpr GhcPs
parent, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0, LHsExpr GhcPs -> Bool
isApp LHsExpr GhcPs
child = Bool
False
     | L _ RecordCon{} <- LHsExpr GhcPs
parent = Bool
False
     | L _ RecordUpd{} <- LHsExpr GhcPs
parent, Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 _ HsLet{} <- LHsExpr GhcPs
parent, LHsExpr GhcPs -> Bool
isApp LHsExpr GhcPs
child = Bool
False
     | L _ HsDo{} <- LHsExpr GhcPs
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
child = Bool
False
     | L _ HsLam{} <- LHsExpr GhcPs
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
child = Bool
False
     | L _ HsCase{} <- LHsExpr GhcPs
parent, LHsExpr GhcPs -> Bool
isAnyApp LHsExpr GhcPs
child = Bool
False

     | L _ HsPar{} <- LHsExpr GhcPs
parent = Bool
False
     | Bool
otherwise = Bool
True

-- | 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 :: LHsExpr GhcPs -> Bool
isAtomOrApp :: LHsExpr GhcPs -> Bool
isAtomOrApp x :: LHsExpr GhcPs
x | LHsExpr GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsExpr GhcPs
x = Bool
True
isAtomOrApp (L _ (HsApp _ _ x :: LHsExpr GhcPs
x)) = LHsExpr GhcPs -> Bool
isAtomOrApp LHsExpr GhcPs
x
isAtomOrApp _ = Bool
False

instance Brackets (Located (Pat GhcPs)) where
  remParen :: Located (Pat GhcPs) -> Maybe (Located (Pat GhcPs))
remParen (L _ (ParPat _ x :: LPat GhcPs
x)) = Located (Pat GhcPs) -> Maybe (Located (Pat GhcPs))
forall a. a -> Maybe a
Just LPat GhcPs
Located (Pat GhcPs)
x
  remParen _ = Maybe (Located (Pat GhcPs))
forall a. Maybe a
Nothing
  addParen :: Located (Pat GhcPs) -> Located (Pat GhcPs)
addParen e :: Located (Pat GhcPs)
e = SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs))
-> SrcSpanLess (Located (Pat GhcPs)) -> Located (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ XParPat GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XParPat p -> LPat p -> Pat p
ParPat NoExtField
XParPat GhcPs
noExtField LPat GhcPs
Located (Pat GhcPs)
e

  isAtom :: Located (Pat GhcPs) -> Bool
isAtom (L _ x :: Pat GhcPs
x) = case Pat GhcPs
x of
    ParPat{} -> Bool
True
    TuplePat{} -> Bool
True
    ListPat{} -> Bool
True
    ConPatIn _ RecCon{} -> Bool
True
    ConPatIn _ (PrefixCon []) -> Bool
True
    VarPat{} -> Bool
True
    WildPat{} -> Bool
True
    SumPat{} -> Bool
True
    AsPat{} -> Bool
True
    SplicePat{} -> Bool
True
    LitPat _ x :: 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
    _ -> 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 _ = Bool
False
  isAtom _ = Bool
False -- '{-# COMPLETE L #-}'

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

instance Brackets (LHsType GhcPs) where
  remParen :: LHsType GhcPs -> Maybe (LHsType GhcPs)
remParen (L _ (HsParTy _ x :: LHsType GhcPs
x)) = LHsType GhcPs -> Maybe (LHsType GhcPs)
forall a. a -> Maybe a
Just LHsType GhcPs
x
  remParen _ = Maybe (LHsType GhcPs)
forall a. Maybe a
Nothing
  addParen :: LHsType GhcPs -> LHsType GhcPs
addParen e :: LHsType GhcPs
e = SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs)
-> SrcSpanLess (LHsType GhcPs) -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExtField
XParTy GhcPs
noExtField LHsType GhcPs
e

  isAtom :: LHsType GhcPs -> Bool
isAtom (L _ x :: 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
      HsSpliceTy{} -> Bool
True
      HsWildCardTy{} -> Bool
True
      _ -> Bool
False
  isAtom _ = Bool
False -- '{-# COMPLETE L #-}'

  needBracket :: Int -> LHsType GhcPs -> LHsType GhcPs -> Bool
needBracket _ parent :: LHsType GhcPs
parent child :: LHsType GhcPs
child
    | LHsType GhcPs -> Bool
forall a. Brackets a => a -> Bool
isAtom LHsType 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 _ HsFunTy{} <- LHsType GhcPs
parent, L _ HsAppTy{} <- LHsType GhcPs
child = Bool
False
    | L _ HsTupleTy{} <- LHsType GhcPs
parent = Bool
False
    | L _ HsListTy{} <- LHsType GhcPs
parent = Bool
False
    | L _ HsExplicitTupleTy{} <- LHsType GhcPs
parent = Bool
False
    | L _ HsListTy{} <- LHsType GhcPs
parent = Bool
False
    | L _ HsExplicitListTy{} <- LHsType GhcPs
parent = Bool
False
    | L _ HsOpTy{} <- LHsType GhcPs
parent, L _ HsAppTy{} <- LHsType GhcPs
child = Bool
False
    | L _ HsParTy{} <- LHsType GhcPs
parent = Bool
False
    | Bool
otherwise = Bool
True