-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Retrie.Expr
  ( bitraverseHsConDetails
  , getUnparened
  , grhsToExpr
  , mkApps
  , mkConPatIn
  , mkEpAnn
  , mkHsAppsTy
  , mkLams
  , mkLet
  , mkLoc
  , mkLocA
  , mkLocatedHsVar
  , mkVarPat
  , mkTyVar
  , parenify
  , parenifyT
  , parenifyP
  , patToExpr
  -- , patToExprA
  -- , setAnnsFor
  , unparen
  , unparenP
  , unparenT
  , wildSupply
  ) where

import Control.Monad
import Control.Monad.State.Lazy
import Data.Functor.Identity
-- import qualified Data.Map as M
import Data.Maybe
-- import Data.Void

import Retrie.AlphaEnv
import Retrie.ExactPrint
import Retrie.Fixity
import Retrie.GHC
import Retrie.SYB
import Retrie.Types
import Retrie.Util

-------------------------------------------------------------------------------

mkLocatedHsVar :: Monad m => LocatedN RdrName -> TransformT m (LHsExpr GhcPs)
mkLocatedHsVar :: forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr (GhcPass 'Parsed))
mkLocatedHsVar ln :: LocatedN RdrName
ln@(L SrcSpanAnnN
l RdrName
n) = do
  -- This special casing for [] is gross, but this is apparently how the
  -- annotations work.
  -- let anns =
  --       case occNameString (occName (unLoc v)) of
  --         "[]" -> [(G AnnOpenS, DP (0,0)), (G AnnCloseS, DP (0,0))]
  --         _    -> [(G AnnVal, DP (0,0))]
  -- r <- setAnnsFor v anns
  -- return (L (moveAnchor l)  (HsVar noExtField n))
  forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
0)  (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L (forall an. Monoid an => DeltaPos -> SrcAnn an -> SrcAnn an
setMoveAnchor (Int -> DeltaPos
SameLine Int
0) SrcSpanAnnN
l) RdrName
n))

-- TODO: move to ghc-exactprint
setMoveAnchor :: (Monoid an) => DeltaPos -> SrcAnn an -> SrcAnn an
setMoveAnchor :: forall an. Monoid an => DeltaPos -> SrcAnn an -> SrcAnn an
setMoveAnchor DeltaPos
dp (SrcSpanAnn EpAnn an
EpAnnNotUsed SrcSpan
l)
  = forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (SrcSpan -> DeltaPos -> Anchor
dpAnchor SrcSpan
l DeltaPos
dp) forall a. Monoid a => a
mempty EpAnnComments
emptyComments) SrcSpan
l
setMoveAnchor DeltaPos
dp (SrcSpanAnn (EpAnn (Anchor RealSrcSpan
a AnchorOperation
_) an
an EpAnnComments
cs) SrcSpan
l)
  = forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
a (DeltaPos -> AnchorOperation
MovedAnchor DeltaPos
dp)) an
an EpAnnComments
cs) SrcSpan
l

-- TODO: move to ghc-exactprint
dpAnchor :: SrcSpan -> DeltaPos -> Anchor
dpAnchor :: SrcSpan -> DeltaPos -> Anchor
dpAnchor SrcSpan
l DeltaPos
dp = RealSrcSpan -> AnchorOperation -> Anchor
Anchor (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) (DeltaPos -> AnchorOperation
MovedAnchor DeltaPos
dp)

-------------------------------------------------------------------------------

-- setAnnsFor :: (Data e, Monad m)
--            => Located e -> [(KeywordId, DeltaPos)] -> TransformT m (Located e)
-- setAnnsFor e anns = modifyAnnsT (M.alter f (mkAnnKey e)) >> return e
--   where f Nothing  = Just annNone { annsDP = anns }
--         f (Just a) = Just a { annsDP = M.toList
--                                      $ M.union (M.fromList anns)
--                                                (M.fromList (annsDP a)) }

mkLoc :: (Data e, Monad m) => e -> TransformT m (Located e)
mkLoc :: forall e (m :: * -> *).
(Data e, Monad m) =>
e -> TransformT m (Located e)
mkLoc e
e = do
  forall l e. l -> e -> GenLocated l e
L forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure e
e

-- ++AZ++:TODO: move to ghc-exactprint
mkLocA :: (Data e, Monad m, Monoid an)
  => DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA :: forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA DeltaPos
dp e
e = forall e (m :: * -> *) an.
(Data e, Monad m) =>
DeltaPos -> an -> e -> TransformT m (LocatedAn an e)
mkLocAA DeltaPos
dp forall a. Monoid a => a
mempty e
e

-- ++AZ++:TODO: move to ghc-exactprint
mkLocAA :: (Data e, Monad m) => DeltaPos -> an -> e -> TransformT m (LocatedAn an e)
mkLocAA :: forall e (m :: * -> *) an.
(Data e, Monad m) =>
DeltaPos -> an -> e -> TransformT m (LocatedAn an e)
mkLocAA DeltaPos
dp an
an e
e = do
  SrcSpan
l <- forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
  let anc :: Anchor
anc = RealSrcSpan -> AnchorOperation -> Anchor
Anchor (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) (DeltaPos -> AnchorOperation
MovedAnchor DeltaPos
dp)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc an
an EpAnnComments
emptyComments) SrcSpan
l) e
e)


-- ++AZ++:TODO: move to ghc-exactprint
mkEpAnn :: Monad m => DeltaPos -> an -> TransformT m (EpAnn an)
mkEpAnn :: forall (m :: * -> *) an.
Monad m =>
DeltaPos -> an -> TransformT m (EpAnn an)
mkEpAnn DeltaPos
dp an
an = do
  Anchor
anc <- forall (m :: * -> *). Monad m => DeltaPos -> TransformT m Anchor
mkAnchor DeltaPos
dp
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc an
an EpAnnComments
emptyComments

mkAnchor :: Monad m => DeltaPos -> TransformT m (Anchor)
mkAnchor :: forall (m :: * -> *). Monad m => DeltaPos -> TransformT m Anchor
mkAnchor DeltaPos
dp = do
  SrcSpan
l <- forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
  forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> AnchorOperation -> Anchor
Anchor (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) (DeltaPos -> AnchorOperation
MovedAnchor DeltaPos
dp))

-------------------------------------------------------------------------------

mkLams
  :: [LPat GhcPs]
  -> LHsExpr GhcPs
  -> TransformT IO (LHsExpr GhcPs)
mkLams :: [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> TransformT IO (LHsExpr (GhcPass 'Parsed))
mkLams [] LHsExpr (GhcPass 'Parsed)
e = forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Parsed)
e
mkLams [LPat (GhcPass 'Parsed)]
vs LHsExpr (GhcPass 'Parsed)
e = do
  Anchor
ancg <- forall (m :: * -> *). Monad m => DeltaPos -> TransformT m Anchor
mkAnchor (Int -> DeltaPos
SameLine Int
0)
  Anchor
ancm <- forall (m :: * -> *). Monad m => DeltaPos -> TransformT m Anchor
mkAnchor (Int -> DeltaPos
SameLine Int
0)
  let
    ga :: GrhsAnn
ga = Maybe EpaLocation -> AddEpAnn -> GrhsAnn
GrhsAnn forall a. Maybe a
Nothing (AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnRarrow (DeltaPos -> [LEpaComment] -> EpaLocation
EpaDelta (Int -> DeltaPos
SameLine Int
1) []))
    ang :: EpAnn GrhsAnn
ang = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
ancg GrhsAnn
ga EpAnnComments
emptyComments
    anm :: EpAnn [AddEpAnn]
anm = forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
ancm [(AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnLam (DeltaPos -> [LEpaComment] -> EpaLocation
EpaDelta (Int -> DeltaPos
SameLine Int
0) []))] EpAnnComments
emptyComments
    L SrcSpanAnnA
l (Match XCMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
x HsMatchContext (NoGhcTc (GhcPass 'Parsed))
ctxt [LPat (GhcPass 'Parsed)]
pats (GRHSs XCGRHSs (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
cs [LGRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))]
grhs HsLocalBinds (GhcPass 'Parsed)
binds)) = forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch forall p. HsMatchContext p
LambdaExpr [LPat (GhcPass 'Parsed)]
vs LHsExpr (GhcPass 'Parsed)
e forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
    grhs' :: [GenLocated
   SrcSpan
   (GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
grhs' = case [GenLocated
   SrcSpan
   (GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
grhs of
      [L SrcSpan
lg (GRHS XCGRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
an [GuardLStmt (GhcPass 'Parsed)]
guards LocatedA (HsExpr (GhcPass 'Parsed))
rhs)] -> [forall l e. l -> e -> GenLocated l e
L SrcSpan
lg (forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS EpAnn GrhsAnn
ang [GuardLStmt (GhcPass 'Parsed)]
guards LocatedA (HsExpr (GhcPass 'Parsed))
rhs)]
      [GenLocated
   SrcSpan
   (GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkLams: lambda expression can only have a single grhs!"
  LocatedAn
  AnnList
  [GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
0) [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (forall p body.
XCMatch p body
-> HsMatchContext (NoGhcTc p)
-> [LPat p]
-> GRHSs p body
-> Match p body
Match EpAnn [AddEpAnn]
anm HsMatchContext (GhcPass 'Parsed)
ctxt [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pats (forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
cs [GenLocated
   SrcSpan
   (GRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
grhs' HsLocalBinds (GhcPass 'Parsed)
binds))]
  let
    mg :: MatchGroup (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
mg =
      forall (p :: Pass) (body :: * -> *).
AnnoBody p body =>
Origin
-> LocatedL
     [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup Origin
Generated LocatedAn
  AnnList
  [GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches
  forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) forall a b. (a -> b) -> a -> b
$ forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam NoExtField
noExtField MatchGroup (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
mg

mkLet :: Monad m => HsLocalBinds GhcPs -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
mkLet :: forall (m :: * -> *).
Monad m =>
HsLocalBinds (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> TransformT m (LHsExpr (GhcPass 'Parsed))
mkLet EmptyLocalBinds{} LHsExpr (GhcPass 'Parsed)
e = forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Parsed)
e
mkLet HsLocalBinds (GhcPass 'Parsed)
lbs LHsExpr (GhcPass 'Parsed)
e = do
#if __GLASGOW_HASKELL__ < 904
  EpAnn AnnsLet
an <- forall (m :: * -> *) an.
Monad m =>
DeltaPos -> an -> TransformT m (EpAnn an)
mkEpAnn (Int -> Int -> DeltaPos
DifferentLine Int
1 Int
5)
                (AnnsLet {
                   alLet :: EpaLocation
alLet = DeltaPos -> [LEpaComment] -> EpaLocation
EpaDelta (Int -> DeltaPos
SameLine Int
0) [],
                   alIn :: EpaLocation
alIn = DeltaPos -> [LEpaComment] -> EpaLocation
EpaDelta (Int -> Int -> DeltaPos
DifferentLine Int
1 Int
1) []
                 })
  LocatedA (HsExpr (GhcPass 'Parsed))
le <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) forall a b. (a -> b) -> a -> b
$ forall p. XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
HsLet EpAnn AnnsLet
an HsLocalBinds (GhcPass 'Parsed)
lbs LHsExpr (GhcPass 'Parsed)
e
  forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA (HsExpr (GhcPass 'Parsed))
le
#else
  an <- mkEpAnn (DifferentLine 1 5) NoEpAnns
  let tokLet = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok
      tokIn = L (TokenLoc (EpaDelta (DifferentLine 1 1) [])) HsTok
  le <- mkLocA (SameLine 1) $ HsLet an tokLet lbs tokIn e
  return le
#endif

mkApps :: MonadIO m => LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT m (LHsExpr GhcPs)
mkApps :: forall (m :: * -> *).
MonadIO m =>
LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)]
-> TransformT m (LHsExpr (GhcPass 'Parsed))
mkApps LHsExpr (GhcPass 'Parsed)
e []     = forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Parsed)
e
mkApps LHsExpr (GhcPass 'Parsed)
f (LHsExpr (GhcPass 'Parsed)
a:[LHsExpr (GhcPass 'Parsed)]
as) = do
  -- lift $ liftIO $ debugPrint Loud "mkApps:f="  [showAst f]
  LocatedA (HsExpr (GhcPass 'Parsed))
f' <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
0) (forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p
HsApp forall a. EpAnn a
noAnn LHsExpr (GhcPass 'Parsed)
f LHsExpr (GhcPass 'Parsed)
a)
  forall (m :: * -> *).
MonadIO m =>
LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)]
-> TransformT m (LHsExpr (GhcPass 'Parsed))
mkApps LocatedA (HsExpr (GhcPass 'Parsed))
f' [LHsExpr (GhcPass 'Parsed)]
as

-- GHC never generates HsAppTy in the parser, using HsAppsTy to keep a list
-- of types.
mkHsAppsTy :: Monad m => [LHsType GhcPs] -> TransformT m (LHsType GhcPs)
mkHsAppsTy :: forall (m :: * -> *).
Monad m =>
[LHsType (GhcPass 'Parsed)]
-> TransformT m (LHsType (GhcPass 'Parsed))
mkHsAppsTy [] = forall a. HasCallStack => String -> a
error String
"mkHsAppsTy: empty list"
mkHsAppsTy (LHsType (GhcPass 'Parsed)
t:[LHsType (GhcPass 'Parsed)]
ts) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
t1 LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
t2 -> forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
noExtField LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
t1 LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
t2)) LHsType (GhcPass 'Parsed)
t [LHsType (GhcPass 'Parsed)]
ts

mkTyVar :: Monad m => LocatedN RdrName -> TransformT m (LHsType GhcPs)
mkTyVar :: forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsType (GhcPass 'Parsed))
mkTyVar LocatedN RdrName
nm = do
  LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
tv <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LocatedN RdrName
nm)
  -- _ <- setAnnsFor nm [(G AnnVal, DP (0,0))]
  (LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
tv', LocatedN RdrName
nm') <- forall a b (m :: * -> *) a1 a2.
(Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1,
 Typeable a2) =>
LocatedAn a1 a
-> LocatedAn a2 b -> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
swapEntryDPT LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
tv LocatedN RdrName
nm
  forall (m :: * -> *) a. Monad m => a -> m a
return LocatedAn AnnListItem (HsType (GhcPass 'Parsed))
tv'

mkVarPat :: Monad m => LocatedN RdrName -> TransformT m (LPat GhcPs)
mkVarPat :: forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LPat (GhcPass 'Parsed))
mkVarPat LocatedN RdrName
nm = forall (p :: Pass). LPat (GhcPass p) -> LPat (GhcPass p)
cLPat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
noExtField LocatedN RdrName
nm)

-- type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))

mkConPatIn
  :: Monad m
  => LocatedN RdrName
  -> HsConPatDetails GhcPs
  -- -> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]
  -> TransformT m (LPat GhcPs)
mkConPatIn :: forall (m :: * -> *).
Monad m =>
LocatedN RdrName
-> HsConPatDetails (GhcPass 'Parsed)
-> TransformT m (LPat (GhcPass 'Parsed))
mkConPatIn LocatedN RdrName
patName HsConPatDetails (GhcPass 'Parsed)
params = do
  GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
0) forall a b. (a -> b) -> a -> b
$ forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat forall a. EpAnn a
noAnn LocatedN RdrName
patName HsConPatDetails (GhcPass 'Parsed)
params
  -- setEntryDPT p (DP (0,0))
  forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
p

-------------------------------------------------------------------------------

-- Note [Wildcards]
-- We need to invent unique binders for wildcard patterns and feed
-- them in as quantified variables for the matcher (they will match
-- some expression and be discarded). We do this hackily here, by
-- generating a supply of w1, w2, etc variables, and filter out any
-- other binders we know about. However, we should also filter out
-- the free variables of the expression, to avoid capture. Haven't found
-- a free variable computation on HsExpr though. :-(

type PatQ m = StateT ([RdrName], [RdrName]) (TransformT m)

newWildVar :: Monad m => PatQ m RdrName
newWildVar :: forall (m :: * -> *). Monad m => PatQ m RdrName
newWildVar = do
  ([RdrName]
s, [RdrName]
u) <- forall s (m :: * -> *). MonadState s m => m s
get
  case [RdrName]
s of
    (RdrName
r:[RdrName]
s') -> do
      forall s (m :: * -> *). MonadState s m => s -> m ()
put ([RdrName]
s', RdrName
rforall a. a -> [a] -> [a]
:[RdrName]
u)
      forall (m :: * -> *) a. Monad m => a -> m a
return RdrName
r
    [] -> forall a. HasCallStack => String -> a
error String
"impossible: empty wild supply"

wildSupply :: [RdrName] -> [RdrName]
wildSupply :: [RdrName] -> [RdrName]
wildSupply [RdrName]
used = (RdrName -> Bool) -> [RdrName]
wildSupplyP (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [RdrName]
used)

wildSupplyAlphaEnv :: AlphaEnv -> [RdrName]
wildSupplyAlphaEnv :: AlphaEnv -> [RdrName]
wildSupplyAlphaEnv AlphaEnv
env = (RdrName -> Bool) -> [RdrName]
wildSupplyP (\ RdrName
nm -> forall a. Maybe a -> Bool
isNothing (RdrName -> AlphaEnv -> Maybe Int
lookupAlphaEnv RdrName
nm AlphaEnv
env))

wildSupplyP :: (RdrName -> Bool) -> [RdrName]
wildSupplyP :: (RdrName -> Bool) -> [RdrName]
wildSupplyP RdrName -> Bool
p =
  [ RdrName
r | Int
i <- [Int
0..]
      , let r :: RdrName
r = FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (Char
'w' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show (Int
i :: Int)))
      , RdrName -> Bool
p RdrName
r ]

-- patToExprA :: AlphaEnv -> AnnotatedPat -> AnnotatedHsExpr
-- patToExprA env pat = runIdentity $ transformA pat $ \ p ->
--   fst <$> runStateT (patToExpr $ cLPat p) (wildSupplyAlphaEnv env, [])

patToExpr :: MonadIO m => LPat GhcPs -> PatQ m (LHsExpr GhcPs)
patToExpr :: forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr LPat (GhcPass 'Parsed)
orig = case forall (p :: Pass). LPat (GhcPass p) -> Maybe (LPat (GhcPass p))
dLPat LPat (GhcPass 'Parsed)
orig of
  Maybe (LPat (GhcPass 'Parsed))
Nothing -> forall a. HasCallStack => String -> a
error String
"patToExpr: called on unlocated Pat!"
  Just lp :: LPat (GhcPass 'Parsed)
lp@(L SrcSpanAnnA
_ Pat (GhcPass 'Parsed)
p) -> do
    LocatedA (HsExpr (GhcPass 'Parsed))
e <- forall {m :: * -> *}.
MonadIO m =>
Pat (GhcPass 'Parsed)
-> StateT
     ([RdrName], [RdrName])
     (TransformT m)
     (LocatedA (HsExpr (GhcPass 'Parsed)))
go Pat (GhcPass 'Parsed)
p
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t2 t1 a b.
(Monad m, Monoid t2, Typeable t1, Typeable t2) =>
LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
transferEntryDP LPat (GhcPass 'Parsed)
lp LocatedA (HsExpr (GhcPass 'Parsed))
e
  where
    -- go :: Pat GhcPs -> PatQ m (LHsExpr GhcPs)
    go :: Pat (GhcPass 'Parsed)
-> StateT
     ([RdrName], [RdrName])
     (TransformT m)
     (LocatedA (HsExpr (GhcPass 'Parsed)))
go WildPat{} = do
      RdrName
w <- forall (m :: * -> *). Monad m => PatQ m RdrName
newWildVar
      LocatedN RdrName
v <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) RdrName
w
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr (GhcPass 'Parsed))
mkLocatedHsVar LocatedN RdrName
v
#if __GLASGOW_HASKELL__ < 900
    go XPat{} = error "patToExpr XPat"
    go CoPat{} = error "patToExpr CoPat"
    go (ConPatIn con ds) = conPatHelper con ds
    go ConPatOut{} = error "patToExpr ConPatOut" -- only exists post-tc
#else
    go (ConPat XConPat (GhcPass 'Parsed)
_ XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
con HsConPatDetails (GhcPass 'Parsed)
ds) = forall (m :: * -> *).
MonadIO m =>
LocatedN RdrName
-> HsConPatDetails (GhcPass 'Parsed)
-> PatQ m (LHsExpr (GhcPass 'Parsed))
conPatHelper XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
con HsConPatDetails (GhcPass 'Parsed)
ds
#endif
    go (LazyPat XLazyPat (GhcPass 'Parsed)
_ LPat (GhcPass 'Parsed)
pat) = forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr LPat (GhcPass 'Parsed)
pat
    go (BangPat XBangPat (GhcPass 'Parsed)
_ LPat (GhcPass 'Parsed)
pat) = forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr LPat (GhcPass 'Parsed)
pat
    go (ListPat XListPat (GhcPass 'Parsed)
_ [LPat (GhcPass 'Parsed)]
ps) = do
      [LocatedA (HsExpr (GhcPass 'Parsed))]
ps' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr [LPat (GhcPass 'Parsed)]
ps
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
        EpAnn AnnList
an <- forall (m :: * -> *) an.
Monad m =>
DeltaPos -> an -> TransformT m (EpAnn an)
mkEpAnn (Int -> DeltaPos
SameLine Int
1)
                      (Maybe Anchor
-> Maybe AddEpAnn
-> Maybe AddEpAnn
-> [AddEpAnn]
-> [TrailingAnn]
-> AnnList
AnnList forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnOpenS EpaLocation
d0)) (forall a. a -> Maybe a
Just (AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnCloseS EpaLocation
d0)) [] [])
        LocatedA (HsExpr (GhcPass 'Parsed))
el <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) forall a b. (a -> b) -> a -> b
$ forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList EpAnn AnnList
an [LocatedA (HsExpr (GhcPass 'Parsed))]
ps'
        -- setAnnsFor el [(G AnnOpenS, DP (0,0)), (G AnnCloseS, DP (0,0))]
        forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA (HsExpr (GhcPass 'Parsed))
el
    go (LitPat XLitPat (GhcPass 'Parsed)
_ HsLit (GhcPass 'Parsed)
lit) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
      -- lit' <- cloneT lit
      forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) forall a b. (a -> b) -> a -> b
$ forall p. XLitE p -> HsLit p -> HsExpr p
HsLit forall a. EpAnn a
noAnn HsLit (GhcPass 'Parsed)
lit
    go (NPat XNPat (GhcPass 'Parsed)
_ XRec (GhcPass 'Parsed) (HsOverLit (GhcPass 'Parsed))
llit Maybe (SyntaxExpr (GhcPass 'Parsed))
mbNeg SyntaxExpr (GhcPass 'Parsed)
_) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
      -- L _ lit <- cloneT llit
      LocatedA (HsExpr (GhcPass 'Parsed))
e <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) forall a b. (a -> b) -> a -> b
$ forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit forall a. EpAnn a
noAnn (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass 'Parsed) (HsOverLit (GhcPass 'Parsed))
llit)
      LocatedA (HsExpr (GhcPass 'Parsed))
negE <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA (HsExpr (GhcPass 'Parsed))
e) (forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp forall a. EpAnn a
noAnn LocatedA (HsExpr (GhcPass 'Parsed))
e) Maybe (SyntaxExpr (GhcPass 'Parsed))
mbNeg
      -- addAllAnnsT llit negE
      forall (m :: * -> *) a. Monad m => a -> m a
return LocatedA (HsExpr (GhcPass 'Parsed))
negE
#if __GLASGOW_HASKELL__ < 904
    go (ParPat XParPat (GhcPass 'Parsed)
an LPat (GhcPass 'Parsed)
p') = do
      LocatedA (HsExpr (GhcPass 'Parsed))
p <- forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr LPat (GhcPass 'Parsed)
p'
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar XParPat (GhcPass 'Parsed)
an LocatedA (HsExpr (GhcPass 'Parsed))
p)
#else
    go (ParPat an _ p' _) = do
      p <- patToExpr p'
      let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok
          tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok
      lift $ mkLocA (SameLine 1) (HsPar an tokLP p tokRP)
#endif
    go SigPat{} = forall a. HasCallStack => String -> a
error String
"patToExpr SigPat"
    go (TuplePat XTuplePat (GhcPass 'Parsed)
an [LPat (GhcPass 'Parsed)]
ps Boxity
boxity) = do
      [HsTupArg (GhcPass 'Parsed)]
es <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LPat (GhcPass 'Parsed)]
ps forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
pat -> do
        LocatedA (HsExpr (GhcPass 'Parsed))
e <- forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
pat
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present forall a. EpAnn a
noAnn LocatedA (HsExpr (GhcPass 'Parsed))
e
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) forall a b. (a -> b) -> a -> b
$ forall p. XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p
ExplicitTuple XTuplePat (GhcPass 'Parsed)
an [HsTupArg (GhcPass 'Parsed)]
es Boxity
boxity
    go (VarPat XVarPat (GhcPass 'Parsed)
_ LIdP (GhcPass 'Parsed)
i) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr (GhcPass 'Parsed))
mkLocatedHsVar LIdP (GhcPass 'Parsed)
i
    go AsPat{} = forall a. HasCallStack => String -> a
error String
"patToExpr AsPat"
    go NPlusKPat{} = forall a. HasCallStack => String -> a
error String
"patToExpr NPlusKPat"
    go SplicePat{} = forall a. HasCallStack => String -> a
error String
"patToExpr SplicePat"
    go SumPat{} = forall a. HasCallStack => String -> a
error String
"patToExpr SumPat"
    go ViewPat{} = forall a. HasCallStack => String -> a
error String
"patToExpr ViewPat"

conPatHelper :: MonadIO m
             => LocatedN RdrName
             -> HsConPatDetails GhcPs
             -> PatQ m (LHsExpr GhcPs)
conPatHelper :: forall (m :: * -> *).
MonadIO m =>
LocatedN RdrName
-> HsConPatDetails (GhcPass 'Parsed)
-> PatQ m (LHsExpr (GhcPass 'Parsed))
conPatHelper LocatedN RdrName
con (InfixCon LPat (GhcPass 'Parsed)
x LPat (GhcPass 'Parsed)
y) =
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1)
               forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. EpAnn a
noAnn
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr LPat (GhcPass 'Parsed)
x
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr (GhcPass 'Parsed))
mkLocatedHsVar LocatedN RdrName
con)
                         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr LPat (GhcPass 'Parsed)
y
conPatHelper LocatedN RdrName
con (PrefixCon [HsPatSigType (NoGhcTc (GhcPass 'Parsed))]
tyargs [LPat (GhcPass 'Parsed)]
xs) = do
  LocatedA (HsExpr (GhcPass 'Parsed))
f <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
LocatedN RdrName -> TransformT m (LHsExpr (GhcPass 'Parsed))
mkLocatedHsVar LocatedN RdrName
con
  [LocatedA (HsExpr (GhcPass 'Parsed))]
as <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadIO m =>
LPat (GhcPass 'Parsed) -> PatQ m (LHsExpr (GhcPass 'Parsed))
patToExpr [LPat (GhcPass 'Parsed)]
xs
  -- lift $ lift $ liftIO $ debugPrint Loud "conPatHelper:f="  [showAst f]
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)]
-> TransformT m (LHsExpr (GhcPass 'Parsed))
mkApps LocatedA (HsExpr (GhcPass 'Parsed))
f [LocatedA (HsExpr (GhcPass 'Parsed))]
as
conPatHelper LocatedN RdrName
_ HsConPatDetails (GhcPass 'Parsed)
_ = forall a. HasCallStack => String -> a
error String
"conPatHelper RecCon"

-------------------------------------------------------------------------------

grhsToExpr :: LGRHS GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
grhsToExpr :: LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
grhsToExpr (L SrcSpan
_ (GRHS XCGRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
_ [] LocatedA (HsExpr (GhcPass 'Parsed))
e)) = LocatedA (HsExpr (GhcPass 'Parsed))
e
grhsToExpr (L SrcSpan
_ (GRHS XCGRHS (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
_ (GuardLStmt (GhcPass 'Parsed)
_:[GuardLStmt (GhcPass 'Parsed)]
_) LocatedA (HsExpr (GhcPass 'Parsed))
e)) = LocatedA (HsExpr (GhcPass 'Parsed))
e -- not sure about this
grhsToExpr LGRHS (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
_ = forall a. HasCallStack => String -> a
error String
"grhsToExpr"

-------------------------------------------------------------------------------

precedence :: FixityEnv -> HsExpr GhcPs -> Maybe Fixity
precedence :: FixityEnv -> HsExpr (GhcPass 'Parsed) -> Maybe Fixity
precedence FixityEnv
_        (HsApp {})       = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SourceText -> Int -> FixityDirection -> Fixity
Fixity (String -> SourceText
SourceText String
"HsApp") Int
10 FixityDirection
InfixL
precedence FixityEnv
fixities (OpApp XOpApp (GhcPass 'Parsed)
_ LHsExpr (GhcPass 'Parsed)
_ LHsExpr (GhcPass 'Parsed)
op LHsExpr (GhcPass 'Parsed)
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed) -> FixityEnv -> Fixity
lookupOp LHsExpr (GhcPass 'Parsed)
op FixityEnv
fixities
precedence FixityEnv
_        HsExpr (GhcPass 'Parsed)
_                = forall a. Maybe a
Nothing

parenify
  :: Monad m => Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
parenify :: forall (m :: * -> *).
Monad m =>
Context
-> LHsExpr (GhcPass 'Parsed)
-> TransformT m (LHsExpr (GhcPass 'Parsed))
parenify Context{[RdrName]
Maybe Substitution
FixityEnv
AlphaEnv
Rewriter
ParentPrec
ctxtSubst :: Context -> Maybe Substitution
ctxtRewriter :: Context -> Rewriter
ctxtParentPrec :: Context -> ParentPrec
ctxtInScope :: Context -> AlphaEnv
ctxtFixityEnv :: Context -> FixityEnv
ctxtDependents :: Context -> Rewriter
ctxtBinders :: Context -> [RdrName]
ctxtSubst :: Maybe Substitution
ctxtRewriter :: Rewriter
ctxtParentPrec :: ParentPrec
ctxtInScope :: AlphaEnv
ctxtFixityEnv :: FixityEnv
ctxtDependents :: Rewriter
ctxtBinders :: [RdrName]
..} le :: LHsExpr (GhcPass 'Parsed)
le@(L SrcSpanAnnA
_ HsExpr (GhcPass 'Parsed)
e)
#if __GLASGOW_HASKELL__ < 904
  | ParentPrec -> Maybe Fixity -> Bool
needed ParentPrec
ctxtParentPrec (FixityEnv -> HsExpr (GhcPass 'Parsed) -> Maybe Fixity
precedence FixityEnv
ctxtFixityEnv HsExpr (GhcPass 'Parsed)
e) Bool -> Bool -> Bool
&& HsExpr (GhcPass 'Parsed) -> Bool
needsParens HsExpr (GhcPass 'Parsed)
e =
    forall x (m :: * -> *) an.
(Data x, Monad m, Monoid an) =>
DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)
mkParen' (forall t a. LocatedAn t a -> DeltaPos
getEntryDP LHsExpr (GhcPass 'Parsed)
le) (\EpAnn AnnParen
an -> forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar EpAnn AnnParen
an (forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LHsExpr (GhcPass 'Parsed)
le (Int -> DeltaPos
SameLine Int
0)))
#else
  | needed ctxtParentPrec (precedence ctxtFixityEnv e) && needsParens e = do
    let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok
        tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok
     in mkParen' (getEntryDP le) (\an -> HsPar an tokLP (setEntryDP le (SameLine 0)) tokRP)
#endif
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr (GhcPass 'Parsed)
le
  where
           {- parent -}               {- child -}
    needed :: ParentPrec -> Maybe Fixity -> Bool
needed (HasPrec (Fixity SourceText
_ Int
p1 FixityDirection
d1)) (Just (Fixity SourceText
_ Int
p2 FixityDirection
d2)) =
      Int
p1 forall a. Ord a => a -> a -> Bool
> Int
p2 Bool -> Bool -> Bool
|| (Int
p1 forall a. Eq a => a -> a -> Bool
== Int
p2 Bool -> Bool -> Bool
&& (FixityDirection
d1 forall a. Eq a => a -> a -> Bool
/= FixityDirection
d2 Bool -> Bool -> Bool
|| FixityDirection
d2 forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixN))
    needed ParentPrec
NeverParen Maybe Fixity
_ = Bool
False
    needed ParentPrec
_ Maybe Fixity
Nothing = Bool
True
    needed ParentPrec
_ Maybe Fixity
_ = Bool
False

getUnparened :: Data k => k -> k
getUnparened :: forall k. Data k => k -> k
getUnparened = forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
unparen forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` LHsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
unparenT forall a b.
(Typeable a, Typeable b) =>
(a -> a) -> (b -> b) -> a -> a
`extT` LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
unparenP

-- TODO: what about comments?
unparen :: LHsExpr GhcPs -> LHsExpr GhcPs
#if __GLASGOW_HASKELL__ < 904
unparen :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
unparen (L SrcSpanAnnA
_ (HsPar XPar (GhcPass 'Parsed)
_ LHsExpr (GhcPass 'Parsed)
e)) = LHsExpr (GhcPass 'Parsed)
e
#else
unparen (L _ (HsPar _ _ e _)) = e
#endif
unparen LHsExpr (GhcPass 'Parsed)
e = LHsExpr (GhcPass 'Parsed)
e

-- | hsExprNeedsParens is not always up-to-date, so this allows us to override
needsParens :: HsExpr GhcPs -> Bool
needsParens :: HsExpr (GhcPass 'Parsed) -> Bool
needsParens = forall (p :: Pass).
IsPass p =>
PprPrec -> HsExpr (GhcPass p) -> Bool
hsExprNeedsParens (Int -> PprPrec
PprPrec Int
10)

mkParen :: (Data x, Monad m, Monoid an, Typeable an)
  => (LocatedAn an x -> x) -> LocatedAn an x -> TransformT m (LocatedAn an x)
mkParen :: forall x (m :: * -> *) an.
(Data x, Monad m, Monoid an, Typeable an) =>
(LocatedAn an x -> x)
-> LocatedAn an x -> TransformT m (LocatedAn an x)
mkParen LocatedAn an x -> x
k LocatedAn an x
e = do
  LocatedAn an x
pe <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA (Int -> DeltaPos
SameLine Int
1) (LocatedAn an x -> x
k LocatedAn an x
e)
  -- _ <- setAnnsFor pe [(G AnnOpenP, DP (0,0)), (G AnnCloseP, DP (0,0))]
  (LocatedAn an x
e0,LocatedAn an x
pe0) <- forall a b (m :: * -> *) a1 a2.
(Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1,
 Typeable a2) =>
LocatedAn a1 a
-> LocatedAn a2 b -> TransformT m (LocatedAn a1 a, LocatedAn a2 b)
swapEntryDPT LocatedAn an x
e LocatedAn an x
pe
  forall (m :: * -> *) a. Monad m => a -> m a
return LocatedAn an x
pe0

#if __GLASGOW_HASKELL__ < 904
mkParen' :: (Data x, Monad m, Monoid an)
         => DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)
mkParen' :: forall x (m :: * -> *) an.
(Data x, Monad m, Monoid an) =>
DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)
mkParen' DeltaPos
dp EpAnn AnnParen -> x
k = do
  let an :: AnnParen
an = ParenType -> EpaLocation -> EpaLocation -> AnnParen
AnnParen ParenType
AnnParens EpaLocation
d0 EpaLocation
d0
  SrcSpan
l <- forall (m :: * -> *). Monad m => TransformT m SrcSpan
uniqueSrcSpanT
  let anc :: Anchor
anc = RealSrcSpan -> AnchorOperation -> Anchor
Anchor (SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l) (DeltaPos -> AnchorOperation
MovedAnchor (Int -> DeltaPos
SameLine Int
0))
  LocatedAn an x
pe <- forall e (m :: * -> *) an.
(Data e, Monad m, Monoid an) =>
DeltaPos -> e -> TransformT m (LocatedAn an e)
mkLocA DeltaPos
dp (EpAnn AnnParen -> x
k (forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc AnnParen
an EpAnnComments
emptyComments))
  forall (m :: * -> *) a. Monad m => a -> m a
return LocatedAn an x
pe
#else
mkParen' :: (Data x, Monad m, Monoid an)
         => DeltaPos -> (EpAnn NoEpAnns -> x) -> TransformT m (LocatedAn an x)
mkParen' dp k = do
  let an = NoEpAnns
  l <- uniqueSrcSpanT
  let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0))
  pe <- mkLocA dp (k (EpAnn anc an emptyComments))
  return pe

mkParenTy :: (Data x, Monad m, Monoid an)
         => DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)
mkParenTy dp k = do
  let an = AnnParen AnnParens d0 d0
  l <- uniqueSrcSpanT
  let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0))
  pe <- mkLocA dp (k (EpAnn anc an emptyComments))
  return pe
#endif

-- This explicitly operates on 'Located (Pat GhcPs)' instead of 'LPat GhcPs'
-- because it is applied at that type by SYB.
parenifyP
  :: Monad m
  => Context
  -> LPat GhcPs
  -> TransformT m (LPat GhcPs)
parenifyP :: forall (m :: * -> *).
Monad m =>
Context
-> LPat (GhcPass 'Parsed) -> TransformT m (LPat (GhcPass 'Parsed))
parenifyP Context{[RdrName]
Maybe Substitution
FixityEnv
AlphaEnv
Rewriter
ParentPrec
ctxtSubst :: Maybe Substitution
ctxtRewriter :: Rewriter
ctxtParentPrec :: ParentPrec
ctxtInScope :: AlphaEnv
ctxtFixityEnv :: FixityEnv
ctxtDependents :: Rewriter
ctxtBinders :: [RdrName]
ctxtSubst :: Context -> Maybe Substitution
ctxtRewriter :: Context -> Rewriter
ctxtParentPrec :: Context -> ParentPrec
ctxtInScope :: Context -> AlphaEnv
ctxtFixityEnv :: Context -> FixityEnv
ctxtDependents :: Context -> Rewriter
ctxtBinders :: Context -> [RdrName]
..} p :: LPat (GhcPass 'Parsed)
p@(L SrcSpanAnnA
_ Pat (GhcPass 'Parsed)
pat)
  | ParentPrec
IsLhs <- ParentPrec
ctxtParentPrec
  , forall {p}. Pat p -> Bool
needed Pat (GhcPass 'Parsed)
pat =
#if __GLASGOW_HASKELL__ < 904
    forall x (m :: * -> *) an.
(Data x, Monad m, Monoid an) =>
DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)
mkParen' (forall t a. LocatedAn t a -> DeltaPos
getEntryDP LPat (GhcPass 'Parsed)
p) (\EpAnn AnnParen
an -> forall p. XParPat p -> LPat p -> Pat p
ParPat EpAnn AnnParen
an (forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LPat (GhcPass 'Parsed)
p (Int -> DeltaPos
SameLine Int
0)))
#else
    let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok
        tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok
     in mkParen' (getEntryDP p) (\an -> ParPat an tokLP (setEntryDP p (SameLine 0)) tokRP)
#endif
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return LPat (GhcPass 'Parsed)
p
  where
    needed :: Pat p -> Bool
needed BangPat{}                          = Bool
False
    needed LazyPat{}                          = Bool
False
    needed ListPat{}                          = Bool
False
    needed LitPat{}                           = Bool
False
    needed ParPat{}                           = Bool
False
    needed SumPat{}                           = Bool
False
    needed TuplePat{}                         = Bool
False
    needed VarPat{}                           = Bool
False
    needed WildPat{}                          = Bool
False
#if __GLASGOW_HASKELL__ < 900
    needed (ConPatIn _ (PrefixCon []))        = False
    needed ConPatOut{pat_args = PrefixCon []} = False
#else
    needed (ConPat XConPat p
_ XRec p (ConLikeP p)
_ (PrefixCon [HsPatSigType (NoGhcTc p)]
_ []))      = Bool
False
#endif
    needed Pat p
_                                  = Bool
True

parenifyT
  :: Monad m => Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
parenifyT :: forall (m :: * -> *).
Monad m =>
Context
-> LHsType (GhcPass 'Parsed)
-> TransformT m (LHsType (GhcPass 'Parsed))
parenifyT Context{[RdrName]
Maybe Substitution
FixityEnv
AlphaEnv
Rewriter
ParentPrec
ctxtSubst :: Maybe Substitution
ctxtRewriter :: Rewriter
ctxtParentPrec :: ParentPrec
ctxtInScope :: AlphaEnv
ctxtFixityEnv :: FixityEnv
ctxtDependents :: Rewriter
ctxtBinders :: [RdrName]
ctxtSubst :: Context -> Maybe Substitution
ctxtRewriter :: Context -> Rewriter
ctxtParentPrec :: Context -> ParentPrec
ctxtInScope :: Context -> AlphaEnv
ctxtFixityEnv :: Context -> FixityEnv
ctxtDependents :: Context -> Rewriter
ctxtBinders :: Context -> [RdrName]
..} lty :: LHsType (GhcPass 'Parsed)
lty@(L SrcSpanAnnA
_ HsType (GhcPass 'Parsed)
ty)
  | forall {p :: Pass}. HsType (GhcPass p) -> Bool
needed HsType (GhcPass 'Parsed)
ty =
#if __GLASGOW_HASKELL__ < 904
      forall x (m :: * -> *) an.
(Data x, Monad m, Monoid an) =>
DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)
mkParen' (forall t a. LocatedAn t a -> DeltaPos
getEntryDP LHsType (GhcPass 'Parsed)
lty) (\EpAnn AnnParen
an -> forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy EpAnn AnnParen
an (forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LHsType (GhcPass 'Parsed)
lty (Int -> DeltaPos
SameLine Int
0)))
#else
      mkParenTy (getEntryDP lty) (\an -> HsParTy an (setEntryDP lty (SameLine 0)))
#endif
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return LHsType (GhcPass 'Parsed)
lty
  where
    needed :: HsType (GhcPass p) -> Bool
needed HsAppTy{}
      | ParentPrec
IsHsAppsTy <- ParentPrec
ctxtParentPrec = Bool
True
      | Bool
otherwise = Bool
False
    needed HsType (GhcPass p)
t = forall (p :: Pass). PprPrec -> HsType (GhcPass p) -> Bool
hsTypeNeedsParens (Int -> PprPrec
PprPrec Int
10) HsType (GhcPass p)
t

unparenT :: LHsType GhcPs -> LHsType GhcPs
unparenT :: LHsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
unparenT (L SrcSpanAnnA
_ (HsParTy XParTy (GhcPass 'Parsed)
_ LHsType (GhcPass 'Parsed)
ty)) = LHsType (GhcPass 'Parsed)
ty
unparenT LHsType (GhcPass 'Parsed)
ty = LHsType (GhcPass 'Parsed)
ty

unparenP :: LPat GhcPs -> LPat GhcPs
#if __GLASGOW_HASKELL__ < 904
unparenP :: LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
unparenP (L SrcSpanAnnA
_ (ParPat XParPat (GhcPass 'Parsed)
_ LPat (GhcPass 'Parsed)
p)) = LPat (GhcPass 'Parsed)
p
#else
unparenP (L _ (ParPat _ _ p _)) = p
#endif
unparenP LPat (GhcPass 'Parsed)
p = LPat (GhcPass 'Parsed)
p

--------------------------------------------------------------------

bitraverseHsConDetails
  :: Applicative m
  => ([tyarg] -> m [tyarg'])
  -> (arg -> m arg')
  -> (rec -> m rec')
  -> HsConDetails tyarg arg rec
  -> m (HsConDetails tyarg' arg' rec')
bitraverseHsConDetails :: forall (m :: * -> *) tyarg tyarg' arg arg' rec rec'.
Applicative m =>
([tyarg] -> m [tyarg'])
-> (arg -> m arg')
-> (rec -> m rec')
-> HsConDetails tyarg arg rec
-> m (HsConDetails tyarg' arg' rec')
bitraverseHsConDetails [tyarg] -> m [tyarg']
argt arg -> m arg'
argf rec -> m rec'
_ (PrefixCon [tyarg]
tyargs [arg]
args) =
  forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([tyarg] -> m [tyarg']
argt [tyarg]
tyargs) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (arg -> m arg'
argf forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
`traverse` [arg]
args)
bitraverseHsConDetails [tyarg] -> m [tyarg']
_ arg -> m arg'
_ rec -> m rec'
recf (RecCon rec
r) =
  forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> rec -> m rec'
recf rec
r
bitraverseHsConDetails [tyarg] -> m [tyarg']
_ arg -> m arg'
argf rec -> m rec'
_ (InfixCon arg
a1 arg
a2) =
  forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
InfixCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> arg -> m arg'
argf arg
a1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> arg -> m arg'
argf arg
a2