{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Tactic.Simplify
( simplify
) where
import Data.Generics (everywhere, mkT, GenericT)
import Data.List.Extra (unsnoc)
import Data.Monoid (Endo (..))
import Development.IDE.GHC.Compat
import GHC.SourceGen (var)
import GHC.SourceGen.Expr (lambda)
import Ide.Plugin.Tactic.CodeGen.Utils
import Ide.Plugin.Tactic.GHC (fromPatCompatPs, containsHsVar)
pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
pattern $bLambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
$mLambda :: forall r.
HsExpr GhcPs
-> ([Pat GhcPs] -> HsExpr GhcPs -> r) -> (Void# -> r) -> r
Lambda pats body <-
HsLam _
(MG {mg_alts = L _ [L _
(Match { m_pats = fmap fromPatCompatPs -> pats
, m_grhss = GRHSs {grhssGRHSs = [L _ (
GRHS _ [] (L _ body))]}
})]})
where
Lambda [] HsExpr GhcPs
body = HsExpr GhcPs
body
Lambda [Pat GhcPs]
pats HsExpr GhcPs
body = [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
lambda [Pat GhcPs]
pats HsExpr GhcPs
body
simplify :: LHsExpr GhcPs -> LHsExpr GhcPs
simplify :: LHsExpr GhcPs -> LHsExpr GhcPs
simplify
= [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a. [a] -> a
head
([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> (LHsExpr GhcPs -> [LHsExpr GhcPs])
-> LHsExpr GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. Int -> [a] -> [a]
drop Int
3
([LHsExpr GhcPs] -> [LHsExpr GhcPs])
-> (LHsExpr GhcPs -> [LHsExpr GhcPs])
-> LHsExpr GhcPs
-> [LHsExpr GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LHsExpr GhcPs -> [LHsExpr GhcPs]
forall a. (a -> a) -> a -> [a]
iterate ((forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((forall a. Data a => a -> a) -> forall a. Data a => a -> a)
-> (forall a. Data a => a -> a) -> forall a. Data a => a -> a
forall a b. (a -> b) -> a -> b
$ [a -> a] -> a -> a
forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
foldEndo
[ a -> a
forall a. Data a => a -> a
simplifyEtaReduce
, a -> a
forall a. Data a => a -> a
simplifyRemoveParens
, a -> a
forall a. Data a => a -> a
simplifyCompose
])
foldEndo :: Foldable t => t (a -> a) -> a -> a
foldEndo :: t (a -> a) -> a -> a
foldEndo = Endo a -> a -> a
forall a. Endo a -> a -> a
appEndo (Endo a -> a -> a)
-> (t (a -> a) -> Endo a) -> t (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> a) -> Endo a) -> t (a -> a) -> Endo a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo
simplifyEtaReduce :: GenericT
simplifyEtaReduce :: a -> a
simplifyEtaReduce = (HsExpr GhcPs -> HsExpr GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((HsExpr GhcPs -> HsExpr GhcPs) -> a -> a)
-> (HsExpr GhcPs -> HsExpr GhcPs) -> a -> a
forall a b. (a -> b) -> a -> b
$ \case
Lambda
[VarPat XVarPat GhcPs
_ (L SrcSpan
_ IdP GhcPs
pat)]
(HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
a)) | IdP GhcPs
RdrName
pat RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcPs
RdrName
a ->
RdrNameStr -> HsExpr GhcPs
forall a. Var a => RdrNameStr -> a
var RdrNameStr
"id"
Lambda
([Pat GhcPs] -> Maybe ([Pat GhcPs], Pat GhcPs)
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([Pat GhcPs]
pats, (VarPat XVarPat GhcPs
_ (L SrcSpan
_ IdP GhcPs
pat))))
(HsApp XApp GhcPs
_ (L SrcSpan
_ HsExpr GhcPs
f) (L SrcSpan
_ (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
a))))
| IdP GhcPs
RdrName
pat RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcPs
RdrName
a
, Bool -> Bool
not (RdrName -> HsExpr GhcPs -> Bool
forall a. Data a => RdrName -> a -> Bool
containsHsVar IdP GhcPs
RdrName
pat HsExpr GhcPs
f) ->
[Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
Lambda [Pat GhcPs]
pats HsExpr GhcPs
f
HsExpr GhcPs
x -> HsExpr GhcPs
x
simplifyCompose :: GenericT
simplifyCompose :: a -> a
simplifyCompose = (HsExpr GhcPs -> HsExpr GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((HsExpr GhcPs -> HsExpr GhcPs) -> a -> a)
-> (HsExpr GhcPs -> HsExpr GhcPs) -> a -> a
forall a b. (a -> b) -> a -> b
$ \case
Lambda
([Pat GhcPs] -> Maybe ([Pat GhcPs], Pat GhcPs)
forall a. [a] -> Maybe ([a], a)
unsnoc -> Just ([Pat GhcPs]
pats, (VarPat XVarPat GhcPs
_ (L SrcSpan
_ IdP GhcPs
pat))))
(HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs)
unroll -> (fs :: [HsExpr GhcPs]
fs@(HsExpr GhcPs
_:[HsExpr GhcPs]
_), (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
a))))
| IdP GhcPs
RdrName
pat RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcPs
RdrName
a
, Bool -> Bool
not (RdrName -> [HsExpr GhcPs] -> Bool
forall a. Data a => RdrName -> a -> Bool
containsHsVar IdP GhcPs
RdrName
pat [HsExpr GhcPs]
fs) ->
[Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs
Lambda [Pat GhcPs]
pats ((HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs)
-> [HsExpr GhcPs] -> HsExpr GhcPs
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs
infixCall String
".") [HsExpr GhcPs]
fs)
HsExpr GhcPs
x -> HsExpr GhcPs
x
simplifyRemoveParens :: GenericT
simplifyRemoveParens :: a -> a
simplifyRemoveParens = (HsExpr GhcPs -> HsExpr GhcPs) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT ((HsExpr GhcPs -> HsExpr GhcPs) -> a -> a)
-> (HsExpr GhcPs -> HsExpr GhcPs) -> a -> a
forall a b. (a -> b) -> a -> b
$ \case
HsPar XPar GhcPs
_ (L SrcSpan
_ HsExpr GhcPs
x) | HsExpr GhcPs -> Bool
forall id. HsExpr id -> Bool
isAtomicHsExpr HsExpr GhcPs
x -> HsExpr GhcPs
x
(HsExpr GhcPs
x :: HsExpr GhcPs) -> HsExpr GhcPs
x
unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs)
unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs)
unroll (HsPar XPar GhcPs
_ (L SrcSpan
_ HsExpr GhcPs
x)) = HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs)
unroll HsExpr GhcPs
x
unroll (HsApp XApp GhcPs
_ (L SrcSpan
_ HsExpr GhcPs
f) (L SrcSpan
_ HsExpr GhcPs
a)) =
let ([HsExpr GhcPs]
fs, HsExpr GhcPs
r) = HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs)
unroll HsExpr GhcPs
a
in (HsExpr GhcPs
f HsExpr GhcPs -> [HsExpr GhcPs] -> [HsExpr GhcPs]
forall a. a -> [a] -> [a]
: [HsExpr GhcPs]
fs, HsExpr GhcPs
r)
unroll HsExpr GhcPs
x = ([], HsExpr GhcPs
x)