{-# 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
_ = (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [Idea])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [Idea]
f ([GenLocated SrcSpanAnnA (HsDecl GhcPs)] -> [Idea])
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
    -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [Idea]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall on. Uniplate on => on -> [on]
universe
    where
        f :: GenLocated SrcSpanAnnA (HsDecl GhcPs) -> [Idea]
f GenLocated SrcSpanAnnA (HsDecl GhcPs)
o = Maybe Idea -> [Idea]
forall a. Maybe a -> [a]
maybeToList (Maybe Idea -> [Idea]) -> Maybe Idea -> [Idea]
forall a b. (a -> b) -> a -> b
$ do
            let x :: GenLocated SrcSpanAnnA (HsDecl GhcPs)
x = GenLocated SrcSpanAnnA (HsDecl GhcPs)
o
            (x, addCase) <- XRec GhcPs (HsDecl GhcPs)
-> Maybe (ListCase, LHsExpr GhcPs -> XRec GhcPs (HsDecl GhcPs))
findCase GenLocated SrcSpanAnnA (HsDecl GhcPs)
XRec GhcPs (HsDecl GhcPs)
x
            (use,severity,x) <- matchListRec x
            let y = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
addCase GenLocated SrcSpanAnnA (HsExpr GhcPs)
x
            guard $ recursiveStr `notElem` varss y
            -- Maybe we can do better here maintaining source
            -- formatting?
            pure $ idea severity ("Use " ++ use) (reLoc o) (reLoc y) [Replace Decl (toSSA o) [] (unsafePrettyPrint 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
(BList -> BList -> Bool) -> (BList -> BList -> Bool) -> Eq BList
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BList -> BList -> Bool
== :: BList -> BList -> Bool
$c/= :: BList -> BList -> Bool
/= :: BList -> BList -> Bool
Eq, Eq BList
Eq BList =>
(BList -> BList -> Ordering)
-> (BList -> BList -> Bool)
-> (BList -> BList -> Bool)
-> (BList -> BList -> Bool)
-> (BList -> BList -> Bool)
-> (BList -> BList -> BList)
-> (BList -> BList -> BList)
-> Ord 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
$ccompare :: BList -> BList -> Ordering
compare :: BList -> BList -> Ordering
$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
>= :: BList -> BList -> Bool
$cmax :: BList -> BList -> BList
max :: BList -> BList -> BList
$cmin :: BList -> BList -> BList
min :: BList -> BList -> BList
Ord, Int -> BList -> String -> String
[BList] -> String -> String
BList -> String
(Int -> BList -> String -> String)
-> (BList -> String) -> ([BList] -> String -> String) -> Show BList
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BList -> String -> String
showsPrec :: Int -> BList -> String -> String
$cshow :: BList -> String
show :: BList -> String
$cshowList :: [BList] -> String -> String
showList :: [BList] -> String -> String
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 String -> String -> Bool
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
":"
    , GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall a. Data a => a -> a -> Bool
astEq (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
rhs) GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive, String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [String]
forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
lhs
    = (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a. a -> Maybe a
Just ((String, Severity, LHsExpr GhcPs)
 -> Maybe (String, Severity, LHsExpr GhcPs))
-> (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (,,) String
"map" Severity
Hint.Type.Warning (LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs))
-> LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs)
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 <- GenLocated SrcSpanAnnA (HsExpr GhcPs) -> App2
forall a b. View a b => a -> b
view GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
cons
    , String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [String]
forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
op [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [String]
forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs) -- the meaning of xs changes, see #793
    , GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
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
    = (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a. a -> Maybe a
Just ((String, Severity, LHsExpr GhcPs)
 -> Maybe (String, Severity, LHsExpr GhcPs))
-> (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (,,) String
"foldr" Severity
Suggestion (LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs))
-> LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs)
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] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket [GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
op,GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
lhs], LHsExpr GhcPs
nil, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Suggest 'foldl'?
    | [String
v] <- [String]
vs, GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
forall a b. View a b => a -> b
view GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
nil Var_ -> Var_ -> Bool
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
    , GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall a. Data a => a -> a -> Bool
astEq (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
fromParen GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
r) GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive
    , String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [String]
forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
lhs
    = (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a. a -> Maybe a
Just ((String, Severity, LHsExpr GhcPs)
 -> Maybe (String, Severity, LHsExpr GhcPs))
-> (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (,,) String
"foldl" Severity
Suggestion (LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs))
-> LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs)
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"()" Bool -> Bool -> Bool
|| GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
forall a b. View a b => a -> b
view GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
res Var_ -> Var_ -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
v
    , [L SrcSpanAnnA
_ (BindStmt XBindStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ (GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
LPat GhcPs -> PVar_
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 (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
LHsExpr GhcPs -> Var_
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b2, GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall a. Data a => a -> a -> Bool
astEq GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
r GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive, String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` GenLocated SrcSpanAnnA (HsExpr GhcPs) -> [String]
forall a. FreeVars a => a -> [String]
vars GenLocated SrcSpanAnnA (HsExpr GhcPs)
e
    , String
name <- String
"foldM" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'_' | LHsExpr GhcPs -> String
varToStr LHsExpr GhcPs
res String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"()"]
    = (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a. a -> Maybe a
Just ((String, Severity, LHsExpr GhcPs)
 -> Maybe (String, Severity, LHsExpr GhcPs))
-> (String, Severity, LHsExpr GhcPs)
-> Maybe (String, Severity, LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (,,) String
name Severity
Suggestion (LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs))
-> LHsExpr GhcPs -> (String, Severity, LHsExpr GhcPs)
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)
LHsExpr GhcPs
e, String -> LHsExpr GhcPs
strToVar String
v, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Nope, I got nothing ¯\_(ツ)_/¯.
    | Bool
otherwise = Maybe (String, Severity, GenLocated SrcSpanAnnA (HsExpr GhcPs))
Maybe (String, Severity, LHsExpr GhcPs)
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 (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> App2
LHsExpr GhcPs -> App2
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
_ HsLamVariant
LamSingle MG {
              mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext=XMG GhcPs (LHsExpr GhcPs)
Origin
FromSource
            , mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts=L SrcSpanAnnLW
_ [
                 L SrcSpanAnnA
_ Match {  m_ctxt :: forall p body. Match p body -> HsMatchContext (LIdP (NoGhcTc p))
m_ctxt=(LamAlt HsLamVariant
LamSingle)
                            , m_pats :: forall p body. Match p body -> XRec p [LPat p]
m_pats=L EpaLocation
_ [v :: GenLocated SrcSpanAnnA (Pat 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 EpAnnCO
_ (GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs)]
                                        (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_)}]}))
      ) =
  [ StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> LPat GhcPs
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt XBindStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. NoAnn a => a
noAnn GenLocated SrcSpanAnnA (Pat GhcPs)
LPat GhcPs
v GenLocated SrcSpanAnnA (HsExpr GhcPs)
lhs
  , StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
noExtField GenLocated SrcSpanAnnA (HsExpr GhcPs)
rhs SyntaxExpr GhcPs
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr ]
asDo (L SrcSpanAnnA
_ (HsDo XDo GhcPs
_ (DoExpr Maybe ModuleName
_) (L SrcSpanAnnLW
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts))) = [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
[LStmt GhcPs (LHsExpr GhcPs)]
stmts
asDo LHsExpr GhcPs
x = [StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA
      (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
noExtField GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x SyntaxExpr GhcPs
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). IsPass p => SyntaxExpr (GhcPass p)
noSyntaxExpr]


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


findCase :: LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
findCase :: XRec GhcPs (HsDecl GhcPs)
-> Maybe (ListCase, LHsExpr GhcPs -> XRec GhcPs (HsDecl GhcPs))
findCase XRec GhcPs (HsDecl GhcPs)
x = do
  -- Match a function binding with two alternatives.
  (L _ (ValD _ FunBind {fun_matches=
              MG{mg_ext=FromSource, mg_alts=
                     (L _
                            [ x1@(L _ Match{..}) -- Match fields.
                            , x2]), ..} -- Match group fields.
          , ..} -- Fun. bind fields.
      )) <- GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsDecl GhcPs))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsDecl GhcPs)
XRec GhcPs (HsDecl GhcPs)
x

  Branch name1 ps1 p1 c1 b1 <- findBranch x1
  Branch name2 ps2 p2 c2 b2 <- findBranch x2
  guard (name1 == name2 && ps1 == ps2 && p1 == p2)
  [(BNil, b1), (BCons x xs, b2)] <- pure $ sortOn fst [(c1, b1), (c2, b2)]
  b2 <- transformAppsM (delCons name1 p1 xs) b2
  (ps, b2) <- pure $ eliminateArgs ps1 b2

  let ps12 = let ([String]
a, [String]
b) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
p1 [String]
ps1 in (String -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [String] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map String -> GenLocated SrcSpanAnnA (Pat GhcPs)
String -> LPat GhcPs
strToPat ([String]
a [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
xs String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
b) -- Function arguments.
      emptyLocalBinds = XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.
      gRHS GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS XCGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. NoAnn a => a
noAnn [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
      gRHSSs GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [LGRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> HsLocalBindsLR GhcPs GhcPs
-> GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs EpAnnComments
XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
emptyComments [GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated
     EpAnnCO (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
gRHS GenLocated SrcSpanAnnA (HsExpr GhcPs)
e] HsLocalBindsLR GhcPs GhcPs
emptyLocalBinds -- Guarded rhs set.
      match GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = Match{m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext=NoExtField
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
noExtField,m_pats :: XRec GhcPs [LPat GhcPs]
m_pats=[GenLocated SrcSpanAnnA (Pat GhcPs)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [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 (LIdP (NoGhcTc GhcPs))
m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
m_ctxt :: HsMatchContext (LIdP (NoGhcTc GhcPs))
..} -- Match.
      matchGroup GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = MG{mg_alts :: XRec GhcPs [LMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
mg_alts=[GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     SrcSpanAnnLW
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
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=GenReason -> DoPmc -> Origin
Generated GenReason
OtherExpansion DoPmc
SkipPmc, ..} -- Match group.
      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, XFunBind GhcPs GhcPs
LIdP GhcPs
fun_ext :: XFunBind GhcPs GhcPs
fun_id :: LIdP GhcPs
fun_ext :: XFunBind GhcPs GhcPs
fun_id :: LIdP GhcPs
..} :: HsBindLR GhcPs GhcPs -- Fun bind.

  pure (ListCase ps b1 (x, xs, b2), noLocA . ValD noExtField . 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 -> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
x) : [LHsExpr GhcPs]
xs) | String
func String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x = do
    (pre, (view -> Var_ v) : post) <- ([GenLocated SrcSpanAnnA (HsExpr GhcPs)],
 [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
-> Maybe
     ([GenLocated SrcSpanAnnA (HsExpr GhcPs)],
      [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([GenLocated SrcSpanAnnA (HsExpr GhcPs)],
  [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
 -> Maybe
      ([GenLocated SrcSpanAnnA (HsExpr GhcPs)],
       [GenLocated SrcSpanAnnA (HsExpr GhcPs)]))
-> ([GenLocated SrcSpanAnnA (HsExpr GhcPs)],
    [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
-> Maybe
     ([GenLocated SrcSpanAnnA (HsExpr GhcPs)],
      [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
forall a b. (a -> b) -> a -> b
$ Int
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsExpr GhcPs)],
    [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
[LHsExpr GhcPs]
xs
    guard $ v == var
    pure $ apps $ recursive : pre ++ post
delCons String
_ Int
_ String
_ LHsExpr GhcPs
x = GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x

eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs)
eliminateArgs :: [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs)
eliminateArgs [String]
ps LHsExpr GhcPs
cons = ([String] -> [String]
forall {a}. [a] -> [a]
remove [String]
ps, (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall on. Uniplate on => (on -> on) -> on -> on
transform GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
f GenLocated SrcSpanAnnA (HsExpr GhcPs)
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 <- (LHsExpr GhcPs -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)])
-> [LHsExpr GhcPs] -> [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]]
forall a b. (a -> b) -> [a] -> [b]
map LHsExpr GhcPs -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps ([LHsExpr GhcPs] -> [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]])
-> [LHsExpr GhcPs] -> [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps LHsExpr GhcPs
cons, GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall a. Data a => a -> a -> Bool
astEq GenLocated SrcSpanAnnA (HsExpr GhcPs)
z GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive]
    elim :: [Bool]
elim = [([GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Bool)
-> [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i Bool -> Bool -> Bool
&& GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
forall a b. View a b => a -> b
view ([GenLocated SrcSpanAnnA (HsExpr GhcPs)]
xs [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> Int -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Var_ -> Var_ -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
p) [[GenLocated SrcSpanAnnA (HsExpr GhcPs)]]
args | (Int
i, String
p) <- Int -> [String] -> [(Int, String)]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 [String]
ps] [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False
    remove :: [a] -> [a]
remove = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> ([a] -> [[a]]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> a -> [a]) -> [Bool] -> [a] -> [[a]]
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) | GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Bool
forall a. Data a => a -> a -> Bool
astEq GenLocated SrcSpanAnnA (HsExpr GhcPs)
LHsExpr GhcPs
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive = [LHsExpr GhcPs] -> LHsExpr GhcPs
apps ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
x LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall {a}. [a] -> [a]
remove [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
[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 = FunRhs {mc_fun=(L _ name)}
            , m_pats = ps
            , m_grhss =
              GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]
                        , grhssLocalBinds=EmptyLocalBinds _
                        }
            } <- Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
x
  (a, b, c) <- findPat (unLoc ps)
  pure $ Branch (occNameStr name) a b c $ simplifyExp body

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

  pure (left, i, right)

readPat :: LPat GhcPs -> Maybe (Either String BList)
readPat :: LPat GhcPs -> Maybe (Either String BList)
readPat (GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
LPat GhcPs -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
x) = Either String BList -> Maybe (Either String BList)
forall a. a -> Maybe a
Just (Either String BList -> Maybe (Either String BList))
-> Either String BList -> Maybe (Either String BList)
forall a b. (a -> b) -> a -> b
$ String -> Either String BList
forall a b. a -> Either a b
Left String
x
readPat (L SrcSpanAnnA
_ (ParPat XParPat GhcPs
_ (L SrcSpanAnnA
_ (ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ RdrName
n) (InfixCon (GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
LPat GhcPs -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
x) (GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
LPat GhcPs -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
xs))))))
 | RdrName
n RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName
consDataCon_RDR = Either String BList -> Maybe (Either String BList)
forall a. a -> Maybe a
Just (Either String BList -> Maybe (Either String BList))
-> Either String BList -> Maybe (Either String BList)
forall a b. (a -> b) -> a -> b
$ BList -> Either String BList
forall a b. b -> Either a b
Right (BList -> Either String BList) -> BList -> Either String BList
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 RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> RdrName
nameRdrName Name
nilDataConName = Either String BList -> Maybe (Either String BList)
forall a. a -> Maybe a
Just (Either String BList -> Maybe (Either String BList))
-> Either String BList -> Maybe (Either String BList)
forall a b. (a -> b) -> a -> b
$ BList -> Either String BList
forall a b. b -> Either a b
Right BList
BNil
readPat LPat GhcPs
_ = Maybe (Either String BList)
forall a. Maybe a
Nothing