{-# LANGUAGE PatternGuards, ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}

{-
map f [] = []
map f (x:xs) = f x : map f xs

foldr f z [] = z
foldr f z (x:xs) = f x (foldr f z xs)

foldl f z [] = z
foldl f z (x:xs) = foldl f (f z x) xs
-}

{-
<TEST>
f (x:xs) = negate x + f xs ; f [] = 0 -- f xs = foldr ((+) . negate) 0 xs
f (x:xs) = x + 1 : f xs ; f [] = [] -- f xs = map (+ 1) xs
f z (x:xs) = f (z*x) xs ; f z [] = z -- f z xs = foldl (*) z xs
f a (x:xs) b = x + a + b : f a xs b ; f a [] b = [] -- f a xs b = map (\ x -> x + a + b) xs
f [] a = return a ; f (x:xs) a = a + x >>= \fax -> f xs fax -- f xs a = foldM (+) a xs
f (x:xs) a = a + x >>= \fax -> f xs fax ; f [] a = pure a -- f xs a = foldM (+) a xs
foos [] x = x; foos (y:ys) x = foo y $ foos ys x -- foos ys x = foldr foo x ys
f [] y = y; f (x:xs) y = f xs $ g x y -- f xs y = foldl (flip g) y xs
f [] y = y; f (x : xs) y = let z = g x y in f xs z -- f xs y = foldl (flip g) y xs
f [] y = y; f (x:xs) y = f xs (f xs z)
fun [] = []; fun (x:xs) = f x xs ++ fun xs
</TEST>
-}


module Hint.ListRec(listRecHint) where

import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSSA)

import Data.Generics.Uniplate.DataOnly
import Data.List.Extra
import Data.Maybe
import Data.Either.Extra
import Control.Monad
import Refact.Types hiding (RType(Match))

import GHC.Types.SrcLoc
import GHC.Hs.Extension
import GHC.Hs.Pat
import GHC.Builtin.Types
import GHC.Hs.Type
import GHC.Types.Name.Reader
import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.Decls
import GHC.Types.Basic

import GHC.Parser.Annotation
import Language.Haskell.Syntax.Extension

import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader

listRecHint :: DeclHint
listRecHint :: DeclHint
listRecHint Scope
_ ModuleEx
_ = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LocatedAn AnnListItem (HsDecl GhcPs) -> [Idea]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall on. Uniplate on => on -> [on]
universe
    where
        f :: LocatedAn AnnListItem (HsDecl GhcPs) -> [Idea]
f LocatedAn AnnListItem (HsDecl GhcPs)
o = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
            let x :: LocatedAn AnnListItem (HsDecl GhcPs)
x = LocatedAn AnnListItem (HsDecl GhcPs)
o
            (ListCase
x, GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LocatedAn AnnListItem (HsDecl GhcPs)
addCase) <- LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
findCase LocatedAn AnnListItem (HsDecl GhcPs)
x
            (String
use,Severity
severity,GenLocated SrcSpanAnnA (HsExpr GhcPs)
x) <- ListCase -> Maybe (String, Severity, LHsExpr GhcPs)
matchListRec ListCase
x
            let y :: LocatedAn AnnListItem (HsDecl GhcPs)
y = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LocatedAn AnnListItem (HsDecl GhcPs)
addCase GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ String
recursiveStr forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. AllVars a => a -> [String]
varss LocatedAn AnnListItem (HsDecl GhcPs)
y
            -- Maybe we can do better here maintaining source
            -- formatting?
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b.
(Outputable a, Outputable b) =>
Severity
-> String
-> Located a
-> Located b
-> [Refactoring SrcSpan]
-> Idea
idea Severity
severity (String
"Use " forall a. [a] -> [a] -> [a]
++ String
use) (forall a e. LocatedAn a e -> Located e
reLoc LocatedAn AnnListItem (HsDecl GhcPs)
o) (forall a e. LocatedAn a e -> Located e
reLoc LocatedAn AnnListItem (HsDecl GhcPs)
y) [forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Decl (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LocatedAn AnnListItem (HsDecl GhcPs)
o) [] (forall a. Outputable a => a -> String
unsafePrettyPrint LocatedAn AnnListItem (HsDecl GhcPs)
y)]

recursiveStr :: String
recursiveStr :: String
recursiveStr = String
"_recursive_"
recursive :: LHsExpr GhcPs
recursive = String -> LHsExpr GhcPs
strToVar String
recursiveStr

data ListCase =
  ListCase
    [String] -- recursion parameters
    (LHsExpr GhcPs)  -- nil case
    (String, String, LHsExpr GhcPs) -- cons case
-- For cons-case delete any recursive calls with 'xs' in them. Any
-- recursive calls are marked "_recursive_".

data BList = BNil | BCons String String
             deriving (BList -> BList -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BList -> BList -> Bool
$c/= :: BList -> BList -> Bool
== :: BList -> BList -> Bool
$c== :: BList -> BList -> Bool
Eq, Eq BList
BList -> BList -> Bool
BList -> BList -> Ordering
BList -> BList -> BList
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BList -> BList -> BList
$cmin :: BList -> BList -> BList
max :: BList -> BList -> BList
$cmax :: BList -> BList -> BList
>= :: BList -> BList -> Bool
$c>= :: BList -> BList -> Bool
> :: BList -> BList -> Bool
$c> :: BList -> BList -> Bool
<= :: BList -> BList -> Bool
$c<= :: BList -> BList -> Bool
< :: BList -> BList -> Bool
$c< :: BList -> BList -> Bool
compare :: BList -> BList -> Ordering
$ccompare :: BList -> BList -> Ordering
Ord, Int -> BList -> ShowS
[BList] -> ShowS
BList -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BList] -> ShowS
$cshowList :: [BList] -> ShowS
show :: BList -> String
$cshow :: BList -> String
showsPrec :: Int -> BList -> ShowS
$cshowsPrec :: Int -> BList -> ShowS
Show)

data Branch =
  Branch
    String  -- function name
    [String]  -- parameters
    Int -- list position
    BList (LHsExpr GhcPs) -- list type/body

---------------------------------------------------------------------
-- MATCH THE RECURSION


matchListRec :: ListCase -> Maybe (String, Severity, LHsExpr GhcPs)
matchListRec :: ListCase -> Maybe (String, Severity, LHsExpr GhcPs)
matchListRec o :: ListCase
o@(ListCase [String]
vs LHsExpr GhcPs
nil (String
x, String
xs, LHsExpr GhcPs
cons))
    -- Suggest 'map'?
    | [] <- [String]
vs, LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
nil forall a. Eq a => a -> a -> Bool
== String
"[]", (L SrcSpanAnnA
_ (OpApp XOpApp GhcPs
_ LHsExpr GhcPs
lhs LHsExpr GhcPs
c LHsExpr GhcPs
rhs)) <- LHsExpr GhcPs
cons, LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
c forall a. Eq a => a -> a -> Bool
== String
":"
    , forall a. Data a => a -> a -> Bool
astEq (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen LHsExpr GhcPs
rhs) GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive, String
xs forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
lhs
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (,,) String
"map" Severity
Hint.Type.Warning forall a b. (a -> b) -> a -> b
$
      [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket [ String -> LHsExpr GhcPs
strToVar String
"map", [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda [String
x] LHsExpr GhcPs
lhs, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Suggest 'foldr'?
    | [] <- [String]
vs, App2 GenLocated SrcSpanAnnA (HsExpr GhcPs)
op GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs <- forall a b. View a b => a -> b
view LHsExpr GhcPs
cons
    , String
xs forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
op forall a. [a] -> [a] -> [a]
++ forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs) -- the meaning of xs changes, see #793
    , forall a. Data a => a -> a -> Bool
astEq (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs) GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (,,) String
"foldr" Severity
Suggestion forall a b. (a -> b) -> a -> b
$
      [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket [ String -> LHsExpr GhcPs
strToVar String
"foldr", [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda [String
x] forall a b. (a -> b) -> a -> b
$ [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket [GenLocated SrcSpanAnnA (HsExpr GhcPs)
op,GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs], LHsExpr GhcPs
nil, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Suggest 'foldl'?
    | [String
v] <- [String]
vs, forall a b. View a b => a -> b
view LHsExpr GhcPs
nil forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
v, (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
r LHsExpr GhcPs
lhs)) <- LHsExpr GhcPs
cons
    , forall a. Data a => a -> a -> Bool
astEq (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen LHsExpr GhcPs
r) GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive
    , String
xs forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
lhs
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (,,) String
"foldl" Severity
Suggestion forall a b. (a -> b) -> a -> b
$
      [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket [ String -> LHsExpr GhcPs
strToVar String
"foldl", [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda [String
v,String
x] LHsExpr GhcPs
lhs, String -> LHsExpr GhcPs
strToVar String
v, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Suggest 'foldM'?
    | [String
v] <- [String]
vs, (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
ret LHsExpr GhcPs
res)) <- LHsExpr GhcPs
nil, LHsExpr GhcPs -> Bool
isReturn LHsExpr GhcPs
ret, LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
res forall a. Eq a => a -> a -> Bool
== String
"()" Bool -> Bool -> Bool
|| forall a b. View a b => a -> b
view LHsExpr GhcPs
res forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
v
    , [L SrcSpanAnnA
_ (BindStmt XBindStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ (forall a b. View a b => a -> b
view -> PVar_ String
b1) GenLocated SrcSpanAnnA (HsExpr GhcPs)
e), L SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen -> (L SrcSpanAnnA
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
r (forall a b. View a b => a -> b
view -> Var_ String
b2)))) SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)] <- LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]
asDo LHsExpr GhcPs
cons
    , String
b1 forall a. Eq a => a -> a -> Bool
== String
b2, forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
r GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive, String
xs forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
    , String
name <- String
"foldM" forall a. [a] -> [a] -> [a]
++ [Char
'_' | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
res forall a. Eq a => a -> a -> Bool
== String
"()"]
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (,,) String
name Severity
Suggestion forall a b. (a -> b) -> a -> b
$
      [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket [String -> LHsExpr GhcPs
strToVar String
name, [String] -> LHsExpr GhcPs -> LHsExpr GhcPs
niceLambda [String
v,String
x] GenLocated SrcSpanAnnA (HsExpr GhcPs)
e, String -> LHsExpr GhcPs
strToVar String
v, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Nope, I got nothing ¯\_(ツ)_/¯.
    | Bool
otherwise = forall a. Maybe a
Nothing

-- Very limited attempt to convert >>= to do, only useful for
-- 'foldM' / 'foldM_'.
asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]
asDo :: LHsExpr GhcPs -> [LStmt GhcPs (LHsExpr GhcPs)]
asDo (forall a b. View a b => a -> b
view ->
       App2 GenLocated SrcSpanAnnA (HsExpr GhcPs)
bind GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs
         (L SrcSpanAnnA
_ (HsLam XLam GhcPs
_ MG {
              mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext=Origin
XMG GhcPs (LHsExpr GhcPs)
FromSource
            , mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts=L SrcSpanAnnL
_ [
                 L SrcSpanAnnA
_ Match {  m_ctxt :: forall p body. Match p body -> HsMatchContext p
m_ctxt=HsMatchContext GhcPs
LambdaExpr
                            , m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[v :: LPat GhcPs
v@(L SrcSpanAnnA
_ VarPat{})]
                            , m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_
                                        [L SrcAnn NoEpAnns
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs)]
                                        (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_)}]}))
      ) =
  [ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt forall ann. EpAnn ann
EpAnnNotUsed LPat GhcPs
v GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs
  , forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
noExtField GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr ]
asDo (L SrcSpanAnnA
_ (HsDo XDo GhcPs
_ (DoExpr Maybe ModuleName
_) (L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts))) = [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts
asDo LHsExpr GhcPs
x = [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
noExtField LHsExpr GhcPs
x forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr]


---------------------------------------------------------------------
-- FIND THE CASE ANALYSIS


findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
findCase LHsDecl GhcPs
x = do
  -- Match a function binding with two alternatives.
  (L SrcSpanAnnA
_ (ValD XValD GhcPs
_ FunBind {fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=
              MG{mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext=Origin
XMG GhcPs (LHsExpr GhcPs)
FromSource, mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts=
                     (L SrcSpanAnnL
_
                            [ x1 :: GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x1@(L SrcSpanAnnA
_ Match{[LPat GhcPs]
HsMatchContext GhcPs
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext :: forall p body. Match p body -> XCMatch p body
m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_pats :: [LPat GhcPs]
m_ctxt :: HsMatchContext GhcPs
m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss :: forall p body. Match p body -> GRHSs p body
m_pats :: forall p body. Match p body -> [LPat p]
m_ctxt :: forall p body. Match p body -> HsMatchContext p
..}) -- Match fields.
                            , GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x2]), ..} -- Match group fields.
          , LIdP GhcPs
XFunBind GhcPs GhcPs
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id :: LIdP GhcPs
fun_ext :: XFunBind GhcPs GhcPs
..} -- Fun. bind fields.
      )) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsDecl GhcPs
x

  Branch String
name1 [String]
ps1 Int
p1 BList
c1 LHsExpr GhcPs
b1 <- LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch
findBranch GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x1
  Branch String
name2 [String]
ps2 Int
p2 BList
c2 LHsExpr GhcPs
b2 <- LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch
findBranch GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x2
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
name1 forall a. Eq a => a -> a -> Bool
== String
name2 Bool -> Bool -> Bool
&& [String]
ps1 forall a. Eq a => a -> a -> Bool
== [String]
ps2 Bool -> Bool -> Bool
&& Int
p1 forall a. Eq a => a -> a -> Bool
== Int
p2)
  [(BList
BNil, GenLocated SrcSpanAnnA (HsExpr GhcPs)
b1), (BCons String
x String
xs, GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2)] <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [(BList
c1, LHsExpr GhcPs
b1), (BList
c2, LHsExpr GhcPs
b2)]
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2 <- forall (m :: * -> *).
Monad m =>
(LHsExpr GhcPs -> m (LHsExpr GhcPs))
-> LHsExpr GhcPs -> m (LHsExpr GhcPs)
transformAppsM (String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
delCons String
name1 Int
p1 String
xs) GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2
  ([String]
ps, GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs)
eliminateArgs [String]
ps1 GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2

  let ps12 :: [GenLocated SrcSpanAnnA (Pat GhcPs)]
ps12 = let ([String]
a, [String]
b) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
p1 [String]
ps1 in forall a b. (a -> b) -> [a] -> [b]
map String -> LPat GhcPs
strToPat ([String]
a forall a. [a] -> [a] -> [a]
++ String
xs forall a. a -> [a] -> [a]
: [String]
b) -- Function arguments.
      emptyLocalBinds :: HsLocalBindsLR GhcPs GhcPs
emptyLocalBinds = forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.
      gRHS :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LGRHS GhcPs (LHsExpr GhcPs)
gRHS GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS forall ann. EpAnn ann
EpAnnNotUsed [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
      gRHSSs :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
gRHSSs GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
emptyComments [GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated
     (SrcAnn NoEpAnns)
     (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
gRHS GenLocated SrcSpanAnnA (HsExpr GhcPs)
e] HsLocalBindsLR GhcPs GhcPs
emptyLocalBinds -- Guarded rhs set.
      match :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = Match{m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext=forall ann. EpAnn ann
EpAnnNotUsed,m_pats :: [LPat GhcPs]
m_pats=[GenLocated SrcSpanAnnA (Pat GhcPs)]
ps12, m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_grhss=GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
gRHSSs GenLocated SrcSpanAnnA (HsExpr GhcPs)
e, HsMatchContext GhcPs
m_ctxt :: HsMatchContext GhcPs
m_ctxt :: HsMatchContext GhcPs
..} -- Match.
      matchGroup :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchGroup GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = MG{mg_alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
mg_alts=forall a an. a -> LocatedAn an a
noLocA [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
match GenLocated SrcSpanAnnA (HsExpr GhcPs)
e], mg_ext :: XMG GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
mg_ext=Origin
Generated, ..} -- Match group.
      funBind :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsBindLR GhcPs GhcPs
funBind GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = FunBind {fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches=GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> MatchGroup GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
matchGroup GenLocated SrcSpanAnnA (HsExpr GhcPs)
e, LIdP GhcPs
XFunBind GhcPs GhcPs
fun_ext :: XFunBind GhcPs GhcPs
fun_id :: LIdP GhcPs
fun_id :: LIdP GhcPs
fun_ext :: XFunBind GhcPs GhcPs
..} :: HsBindLR GhcPs GhcPs -- Fun bind.

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
-> LHsExpr GhcPs -> (String, String, LHsExpr GhcPs) -> ListCase
ListCase [String]
ps GenLocated SrcSpanAnnA (HsExpr GhcPs)
b1 (String
x, String
xs, GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2), forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
noExtField forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsBindLR GhcPs GhcPs
funBind)

delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
delCons :: String -> Int -> String -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
delCons String
func Int
pos String
var (LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps -> (forall a b. View a b => a -> b
view -> Var_ String
x) : [LHsExpr GhcPs]
xs) | String
func forall a. Eq a => a -> a -> Bool
== String
x = do
    ([GenLocated SrcSpanAnnA (HsExpr GhcPs)]
pre, (forall a b. View a b => a -> b
view -> Var_ String
v) : [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
post) <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos [LHsExpr GhcPs]
xs
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ String
v forall a. Eq a => a -> a -> Bool
== String
var
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [LHsExpr GhcPs] -> LHsExpr GhcPs
apps forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
pre forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
post
delCons String
_ Int
_ String
_ LHsExpr GhcPs
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr GhcPs
x

eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs)
eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs)
eliminateArgs [String]
ps LHsExpr GhcPs
cons = (forall {a}. [a] -> [a]
remove [String]
ps, forall on. Uniplate on => (on -> on) -> on -> on
transform GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
f LHsExpr GhcPs
cons)
  where
    args :: [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]]
args = [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
zs | GenLocated SrcSpanAnnA (HsExpr GhcPs)
z : [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
zs <- forall a b. (a -> b) -> [a] -> [b]
map LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps LHsExpr GhcPs
cons, forall a. Data a => a -> a -> Bool
astEq GenLocated SrcSpanAnnA (HsExpr GhcPs)
z GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive]
    elim :: [Bool]
elim = [forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs forall a. Ord a => a -> a -> Bool
> Int
i Bool -> Bool -> Bool
&& forall a b. View a b => a -> b
view ([GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs forall a. [a] -> Int -> a
!! Int
i) forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
p) [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]]
args | (Int
i, String
p) <- forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 [String]
ps] forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Bool
False
    remove :: [a] -> [a]
remove = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Bool
b a
x -> [a
x | Bool -> Bool
not Bool
b]) [Bool]
elim

    f :: LHsExpr GhcPs -> LHsExpr GhcPs
f (LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps -> LHsExpr GhcPs
x : [LHsExpr GhcPs]
xs) | forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive = [LHsExpr GhcPs] -> LHsExpr GhcPs
apps forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
x forall a. a -> [a] -> [a]
: forall {a}. [a] -> [a]
remove [LHsExpr GhcPs]
xs
    f LHsExpr GhcPs
x = LHsExpr GhcPs
x


---------------------------------------------------------------------
-- FIND A BRANCH


findBranch :: LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch
findBranch :: LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch
findBranch (L SrcSpanAnnA
_ Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x) = do
  Match { m_ctxt :: forall p body. Match p body -> HsMatchContext p
m_ctxt = FunRhs {mc_fun :: forall p. HsMatchContext p -> LIdP (NoGhcTc p)
mc_fun=(L SrcSpanAnnN
_ RdrName
name)}
            , m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [LPat GhcPs]
ps
            , m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss =
              GRHSs {grhssGRHSs :: forall p body. GRHSs p body -> [LGRHS p body]
grhssGRHSs=[L SrcAnn NoEpAnns
l (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
body)]
                        , grhssLocalBinds :: forall p body. GRHSs p body -> HsLocalBinds p
grhssLocalBinds=EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_
                        }
            } <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x
  ([String]
a, Int
b, BList
c) <- [LPat GhcPs] -> Maybe ([String], Int, BList)
findPat [LPat GhcPs]
ps
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> [String] -> Int -> BList -> LHsExpr GhcPs -> Branch
Branch (RdrName -> String
occNameStr RdrName
name) [String]
a Int
b BList
c forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
simplifyExp GenLocated SrcSpanAnnA (HsExpr GhcPs)
body

findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList)
findPat :: [LPat GhcPs] -> Maybe ([String], Int, BList)
findPat [LPat GhcPs]
ps = do
  [Either String BList]
ps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcPs -> Maybe (Either String BList)
readPat [LPat GhcPs]
ps
  [Int
i] <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [Int]
findIndices forall a b. Either a b -> Bool
isRight [Either String BList]
ps
  let ([String]
left, [BList
right]) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String BList]
ps

  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
left, Int
i, BList
right)

readPat :: LPat GhcPs -> Maybe (Either String BList)
readPat :: LPat GhcPs -> Maybe (Either String BList)
readPat (forall a b. View a b => a -> b
view -> PVar_ String
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
x
readPat (L SrcSpanAnnA
_ (ParPat XParPat GhcPs
_ LHsToken "(" GhcPs
_ (L SrcSpanAnnA
_ (ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ RdrName
n) (InfixCon (forall a b. View a b => a -> b
view -> PVar_ String
x) (forall a b. View a b => a -> b
view -> PVar_ String
xs)))) LHsToken ")" GhcPs
_))
 | RdrName
n forall a. Eq a => a -> a -> Bool
== RdrName
consDataCon_RDR = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> String -> BList
BCons String
x String
xs
readPat (L SrcSpanAnnA
_ (ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ RdrName
n) (PrefixCon [] [])))
  | RdrName
n forall a. Eq a => a -> a -> Bool
== Name -> RdrName
nameRdrName Name
nilDataConName = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right BList
BNil
readPat LPat GhcPs
_ = forall a. Maybe a
Nothing