{-# 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, toSS)

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 SrcLoc
import GHC.Hs.Extension
import GHC.Hs.Pat
import GHC.Hs.Types
import TysWiredIn
import RdrName
import GHC.Hs.Binds
import GHC.Hs.Expr
import GHC.Hs.Decls
import BasicTypes

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
_ = (LHsDecl GhcPs -> [Idea]) -> [LHsDecl GhcPs] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LHsDecl GhcPs -> [Idea]
f ([LHsDecl GhcPs] -> [Idea])
-> (LHsDecl GhcPs -> [LHsDecl GhcPs]) -> LHsDecl GhcPs -> [Idea]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsDecl GhcPs -> [LHsDecl GhcPs]
forall on. Uniplate on => on -> [on]
universe
    where
        f :: LHsDecl GhcPs -> [Idea]
f LHsDecl 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 :: LHsDecl GhcPs
x = LHsDecl GhcPs
o
            (ListCase
x, LHsExpr GhcPs -> LHsDecl GhcPs
addCase) <- LHsDecl GhcPs -> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
findCase LHsDecl GhcPs
x
            (String
use,Severity
severity,LHsExpr GhcPs
x) <- ListCase -> Maybe (String, Severity, LHsExpr GhcPs)
matchListRec ListCase
x
            let y :: LHsDecl GhcPs
y = LHsExpr GhcPs -> LHsDecl GhcPs
addCase LHsExpr GhcPs
x
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String
recursiveStr String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` LHsDecl GhcPs -> [String]
forall a. AllVars a => a -> [String]
varss LHsDecl GhcPs
y
            -- Maybe we can do better here maintaining source
            -- formatting?
            Idea -> Maybe Idea
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Idea -> Maybe Idea) -> Idea -> Maybe Idea
forall a b. (a -> b) -> a -> b
$ Severity
-> String
-> LHsDecl GhcPs
-> LHsDecl GhcPs
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(HasSrcSpan a, Outputable a, HasSrcSpan b, Outputable b) =>
Severity -> String -> a -> b -> [Refactoring SrcSpan] -> Idea
idea Severity
severity (String
"Use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
use) LHsDecl GhcPs
o LHsDecl GhcPs
y [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Decl (LHsDecl GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS LHsDecl GhcPs
o) [] (LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint LHsDecl 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
(BList -> BList -> Bool) -> (BList -> BList -> Bool) -> Eq BList
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
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
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
$cp1Ord :: Eq 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
showList :: [BList] -> String -> String
$cshowList :: [BList] -> String -> String
show :: BList -> String
$cshow :: BList -> String
showsPrec :: Int -> BList -> String -> String
$cshowsPrec :: Int -> 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 SrcSpan
_ (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
":"
    , LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
rhs) LHsExpr GhcPs
recursive, String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars 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 LHsExpr GhcPs
op LHsExpr GhcPs
lhs LHsExpr GhcPs
rhs <- LHsExpr GhcPs -> App2
forall a b. View a b => a -> b
view LHsExpr GhcPs
cons
    , String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
op [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr GhcPs
lhs) -- the meaning of xs changes, see #793
    , LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
rhs) LHsExpr 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 [LHsExpr GhcPs
op,LHsExpr GhcPs
lhs], LHsExpr GhcPs
nil, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Suggest 'foldl'?
    | [String
v] <- [String]
vs, LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view LHsExpr GhcPs
nil Var_ -> Var_ -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
v, (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
r LHsExpr GhcPs
lhs)) <- LHsExpr GhcPs
cons
    , LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen LHsExpr GhcPs
r) LHsExpr GhcPs
recursive
    , String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars 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 SrcSpan
_ (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
|| LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view LHsExpr GhcPs
res Var_ -> Var_ -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
v
    , [L SrcSpan
_ (BindStmt XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
_ (LPat GhcPs -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
b1) LHsExpr GhcPs
e SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_), L SrcSpan
_ (BodyStmt XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
_ (LHsExpr GhcPs -> LHsExpr GhcPs
fromParen -> (L SrcSpan
_ (HsApp XApp GhcPs
_ LHsExpr GhcPs
r (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, LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
r LHsExpr GhcPs
recursive, String
xs String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` LHsExpr GhcPs -> [String]
forall a. FreeVars a => a -> [String]
vars LHsExpr 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] LHsExpr GhcPs
e, String -> LHsExpr GhcPs
strToVar String
v, String -> LHsExpr GhcPs
strToVar String
xs]
    -- Nope, I got nothing ¯\_(ツ)_/¯.
    | Bool
otherwise = 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 (LHsExpr GhcPs -> App2
forall a b. View a b => a -> b
view ->
       App2 LHsExpr GhcPs
bind LHsExpr GhcPs
lhs
         (L SrcSpan
_ (HsLam XLam GhcPs
_ MG {
              mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin=Origin
FromSource
            , mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=L SrcSpan
_ [
                 L SrcSpan
_ Match {  m_ctxt :: forall p body.
Match p body -> HsMatchContext (NameOrRdrName (IdP p))
m_ctxt=HsMatchContext (NameOrRdrName (IdP GhcPs))
LambdaExpr
                            , m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[v :: LPat GhcPs
v@(L _ VarPat{})]
                            , m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss=GRHSs XCGRHSs GhcPs (LHsExpr GhcPs)
_
                                        [L SrcSpan
_ (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [] LHsExpr GhcPs
rhs)]
                                        (L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_))}]}))
      ) =
  [ SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> LStmt GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> LStmt GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> LStmt GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LPat GhcPs
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt NoExtField
XBindStmt GhcPs GhcPs (LHsExpr GhcPs)
noExtField LPat GhcPs
v LHsExpr GhcPs
lhs SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
  , SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> LStmt GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> LStmt GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> LStmt GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
noExtField LHsExpr GhcPs
rhs SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr ]
asDo (L SrcSpan
_ (HsDo XDo GhcPs
_ HsStmtContext Name
DoExpr (L SrcSpan
_ [LStmt GhcPs (LHsExpr GhcPs)]
stmts))) = [LStmt GhcPs (LHsExpr GhcPs)]
stmts
asDo LHsExpr GhcPs
x = [SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> LStmt GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
 -> LStmt GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LStmt GhcPs (LHsExpr GhcPs))
-> LStmt GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
-> LHsExpr GhcPs
-> SyntaxExpr GhcPs
-> SyntaxExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
forall idL idR body.
XBodyStmt idL idR body
-> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body
BodyStmt NoExtField
XBodyStmt GhcPs GhcPs (LHsExpr GhcPs)
noExtField LHsExpr GhcPs
x SyntaxExpr GhcPs
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr SyntaxExpr GhcPs
forall (p :: Pass). 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 SrcSpan
_ (ValD XValD GhcPs
_ FunBind {fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=
              MG{mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin=Origin
FromSource, mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=
                     (L SrcSpan
_
                            [ x1 :: LMatch GhcPs (LHsExpr GhcPs)
x1@(L SrcSpan
_ Match{[LPat GhcPs]
HsMatchContext (NameOrRdrName (IdP GhcPs))
GRHSs GhcPs (LHsExpr GhcPs)
XCMatch GhcPs (LHsExpr GhcPs)
m_ext :: forall p body. Match p body -> XCMatch p body
m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_pats :: [LPat GhcPs]
m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ext :: XCMatch GhcPs (LHsExpr 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 (NameOrRdrName (IdP p))
..}) -- Match fields.
                            , LMatch GhcPs (LHsExpr GhcPs)
x2]), XMG GhcPs (LHsExpr GhcPs)
mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext :: XMG GhcPs (LHsExpr GhcPs)
..} -- Match group fields.
          , [Tickish Id]
HsWrapper
XFunBind GhcPs GhcPs
Located (IdP GhcPs)
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_co_fn :: forall idL idR. HsBindLR idL idR -> HsWrapper
fun_tick :: forall idL idR. HsBindLR idL idR -> [Tickish Id]
fun_tick :: [Tickish Id]
fun_co_fn :: HsWrapper
fun_id :: Located (IdP GhcPs)
fun_ext :: XFunBind GhcPs GhcPs
..} -- Fun. bind fields.
      )) <- LHsDecl GhcPs -> Maybe (LHsDecl GhcPs)
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 LMatch GhcPs (LHsExpr GhcPs)
x1
  Branch String
name2 [String]
ps2 Int
p2 BList
c2 LHsExpr GhcPs
b2 <- LMatch GhcPs (LHsExpr GhcPs) -> Maybe Branch
findBranch LMatch GhcPs (LHsExpr GhcPs)
x2
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
name1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name2 Bool -> Bool -> Bool
&& [String]
ps1 [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [String]
ps2 Bool -> Bool -> Bool
&& Int
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
p2)
  [(BList
BNil, LHsExpr GhcPs
b1), (BCons String
x String
xs, LHsExpr GhcPs
b2)] <- [(BList, LHsExpr GhcPs)] -> Maybe [(BList, LHsExpr GhcPs)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(BList, LHsExpr GhcPs)] -> Maybe [(BList, LHsExpr GhcPs)])
-> [(BList, LHsExpr GhcPs)] -> Maybe [(BList, LHsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$ ((BList, LHsExpr GhcPs) -> BList)
-> [(BList, LHsExpr GhcPs)] -> [(BList, LHsExpr GhcPs)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (BList, LHsExpr GhcPs) -> BList
forall a b. (a, b) -> a
fst [(BList
c1, LHsExpr GhcPs
b1), (BList
c2, LHsExpr GhcPs
b2)]
  LHsExpr GhcPs
b2 <- (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
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) LHsExpr GhcPs
b2
  ([String]
ps, LHsExpr GhcPs
b2) <- ([String], LHsExpr GhcPs) -> Maybe ([String], LHsExpr GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([String], LHsExpr GhcPs) -> Maybe ([String], LHsExpr GhcPs))
-> ([String], LHsExpr GhcPs) -> Maybe ([String], LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [String] -> LHsExpr GhcPs -> ([String], LHsExpr GhcPs)
eliminateArgs [String]
ps1 LHsExpr GhcPs
b2

  let ps12 :: [Located (Pat GhcPs)]
ps12 = let ([String]
a, [String]
b) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
p1 [String]
ps1 in (String -> Located (Pat GhcPs))
-> [String] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map String -> LPat GhcPs
String -> Located (Pat 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 :: GenLocated SrcSpan (HsLocalBinds GhcPs)
emptyLocalBinds = SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
 -> GenLocated SrcSpan (HsLocalBinds GhcPs))
-> SrcSpanLess (GenLocated SrcSpan (HsLocalBinds GhcPs))
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
forall a b. (a -> b) -> a -> b
$ XEmptyLocalBinds GhcPs GhcPs -> HsLocalBinds GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds NoExtField
XEmptyLocalBinds GhcPs GhcPs
noExtField -- Empty where clause.
      gRHS :: LHsExpr GhcPs -> LGRHS GhcPs (LHsExpr GhcPs)
gRHS LHsExpr GhcPs
e = SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
 -> LGRHS GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LGRHS GhcPs (LHsExpr GhcPs))
-> LGRHS GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XCGRHS GhcPs (LHsExpr GhcPs)
-> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
-> GRHS GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body
GRHS NoExtField
XCGRHS GhcPs (LHsExpr GhcPs)
noExtField [] LHsExpr GhcPs
e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
      gRHSSs :: LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
gRHSSs LHsExpr GhcPs
e = XCGRHSs GhcPs (LHsExpr GhcPs)
-> [LGRHS GhcPs (LHsExpr GhcPs)]
-> GenLocated SrcSpan (HsLocalBinds GhcPs)
-> GRHSs GhcPs (LHsExpr GhcPs)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs NoExtField
XCGRHSs GhcPs (LHsExpr GhcPs)
noExtField [LHsExpr GhcPs -> LGRHS GhcPs (LHsExpr GhcPs)
gRHS LHsExpr GhcPs
e] GenLocated SrcSpan (HsLocalBinds GhcPs)
emptyLocalBinds -- Guarded rhs set.
      match :: LHsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)
match LHsExpr GhcPs
e = Match :: forall p body.
XCMatch p body
-> HsMatchContext (NameOrRdrName (IdP p))
-> [LPat p]
-> GRHSs p body
-> Match p body
Match{m_ext :: XCMatch GhcPs (LHsExpr GhcPs)
m_ext=NoExtField
XCMatch GhcPs (LHsExpr GhcPs)
noExtField,m_pats :: [LPat GhcPs]
m_pats=[LPat GhcPs]
[Located (Pat GhcPs)]
ps12, m_grhss :: GRHSs GhcPs (LHsExpr GhcPs)
m_grhss=LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs)
gRHSSs LHsExpr GhcPs
e, HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
m_ctxt :: HsMatchContext (NameOrRdrName (IdP GhcPs))
..} -- Match.
      matchGroup :: LHsExpr GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup LHsExpr GhcPs
e = MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG{mg_alts :: GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
mg_alts=SrcSpanLess (GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)])
-> GenLocated SrcSpan [LMatch GhcPs (LHsExpr GhcPs)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
 -> LMatch GhcPs (LHsExpr GhcPs))
-> SrcSpanLess (LMatch GhcPs (LHsExpr GhcPs))
-> LMatch GhcPs (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)
match LHsExpr GhcPs
e], mg_origin :: Origin
mg_origin=Origin
Generated, XMG GhcPs (LHsExpr GhcPs)
mg_ext :: XMG GhcPs (LHsExpr GhcPs)
mg_ext :: XMG GhcPs (LHsExpr GhcPs)
..} -- Match group.
      funBind :: LHsExpr GhcPs -> HsBindLR GhcPs GhcPs
funBind LHsExpr GhcPs
e = FunBind :: forall idL idR.
XFunBind idL idR
-> Located (IdP idL)
-> MatchGroup idR (LHsExpr idR)
-> HsWrapper
-> [Tickish Id]
-> HsBindLR idL idR
FunBind {fun_matches :: MatchGroup GhcPs (LHsExpr GhcPs)
fun_matches=LHsExpr GhcPs -> MatchGroup GhcPs (LHsExpr GhcPs)
matchGroup LHsExpr GhcPs
e, [Tickish Id]
HsWrapper
XFunBind GhcPs GhcPs
Located (IdP GhcPs)
fun_ext :: XFunBind GhcPs GhcPs
fun_id :: Located (IdP GhcPs)
fun_co_fn :: HsWrapper
fun_tick :: [Tickish Id]
fun_tick :: [Tickish Id]
fun_co_fn :: HsWrapper
fun_id :: Located (IdP GhcPs)
fun_ext :: XFunBind GhcPs GhcPs
..} :: HsBindLR GhcPs GhcPs -- Fun bind.

  (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
-> Maybe (ListCase, LHsExpr GhcPs -> LHsDecl GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
-> LHsExpr GhcPs -> (String, String, LHsExpr GhcPs) -> ListCase
ListCase [String]
ps LHsExpr GhcPs
b1 (String
x, String
xs, LHsExpr GhcPs
b2), HsDecl GhcPs -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsDecl GhcPs -> LHsDecl GhcPs)
-> (LHsExpr GhcPs -> HsDecl GhcPs)
-> LHsExpr GhcPs
-> LHsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XValD GhcPs -> HsBindLR GhcPs GhcPs -> HsDecl GhcPs
forall p. XValD p -> HsBind p -> HsDecl p
ValD NoExtField
XValD GhcPs
noExtField (HsBindLR GhcPs GhcPs -> HsDecl GhcPs)
-> (LHsExpr GhcPs -> HsBindLR GhcPs GhcPs)
-> LHsExpr GhcPs
-> HsDecl GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr 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 -> (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
    ([LHsExpr GhcPs]
pre, (LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view -> Var_ String
v) : [LHsExpr GhcPs]
post) <- ([LHsExpr GhcPs], [LHsExpr GhcPs])
-> Maybe ([LHsExpr GhcPs], [LHsExpr GhcPs])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([LHsExpr GhcPs], [LHsExpr GhcPs])
 -> Maybe ([LHsExpr GhcPs], [LHsExpr GhcPs]))
-> ([LHsExpr GhcPs], [LHsExpr GhcPs])
-> Maybe ([LHsExpr GhcPs], [LHsExpr GhcPs])
forall a b. (a -> b) -> a -> b
$ Int -> [LHsExpr GhcPs] -> ([LHsExpr GhcPs], [LHsExpr GhcPs])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos [LHsExpr GhcPs]
xs
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
var
    LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr GhcPs -> Maybe (LHsExpr GhcPs))
-> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsExpr GhcPs] -> LHsExpr GhcPs
apps ([LHsExpr GhcPs] -> LHsExpr GhcPs)
-> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
recursive LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [LHsExpr GhcPs]
pre [LHsExpr GhcPs] -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsExpr GhcPs]
post
delCons String
_ Int
_ String
_ LHsExpr GhcPs
x = LHsExpr GhcPs -> Maybe (LHsExpr GhcPs)
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 = ([String] -> [String]
forall a. [a] -> [a]
remove [String]
ps, (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall on. Uniplate on => (on -> on) -> on -> on
transform LHsExpr GhcPs -> LHsExpr GhcPs
f LHsExpr GhcPs
cons)
  where
    args :: [[LHsExpr GhcPs]]
args = [[LHsExpr GhcPs]
zs | LHsExpr GhcPs
z : [LHsExpr GhcPs]
zs <- (LHsExpr GhcPs -> [LHsExpr GhcPs])
-> [LHsExpr GhcPs] -> [[LHsExpr GhcPs]]
forall a b. (a -> b) -> [a] -> [b]
map LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps ([LHsExpr GhcPs] -> [[LHsExpr GhcPs]])
-> [LHsExpr GhcPs] -> [[LHsExpr GhcPs]]
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps LHsExpr GhcPs
cons, LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
z LHsExpr GhcPs
recursive]
    elim :: [Bool]
elim = [([LHsExpr GhcPs] -> Bool) -> [[LHsExpr GhcPs]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[LHsExpr GhcPs]
xs -> [LHsExpr GhcPs] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcPs]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
i Bool -> Bool -> Bool
&& LHsExpr GhcPs -> Var_
forall a b. View a b => a -> b
view ([LHsExpr GhcPs]
xs [LHsExpr GhcPs] -> Int -> LHsExpr GhcPs
forall a. [a] -> Int -> a
!! Int
i) Var_ -> Var_ -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Var_
Var_ String
p) [[LHsExpr 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) | LHsExpr GhcPs -> LHsExpr GhcPs -> Bool
forall a. Data a => a -> a -> Bool
astEq LHsExpr GhcPs
x LHsExpr 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]
: [LHsExpr GhcPs] -> [LHsExpr GhcPs]
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 SrcSpan
_ Match GhcPs (LHsExpr GhcPs)
x) = do
  Match { m_ctxt :: forall p body.
Match p body -> HsMatchContext (NameOrRdrName (IdP p))
m_ctxt = FunRhs {mc_fun :: forall id. HsMatchContext id -> Located id
mc_fun=(L SrcSpan
_ NameOrRdrName (IdP GhcPs)
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 SrcSpan
l (GRHS XCGRHS GhcPs (LHsExpr GhcPs)
_ [] LHsExpr GhcPs
body)]
                        , grhssLocalBinds :: forall p body. GRHSs p body -> LHsLocalBinds p
grhssLocalBinds=L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
_)
                        }
            } <- Match GhcPs (LHsExpr GhcPs) -> Maybe (Match GhcPs (LHsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Match GhcPs (LHsExpr GhcPs)
x
  ([String]
a, Int
b, BList
c) <- [LPat GhcPs] -> Maybe ([String], Int, BList)
findPat [LPat GhcPs]
ps
  Branch -> Maybe Branch
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch -> Maybe Branch) -> Branch -> Maybe Branch
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Int -> BList -> LHsExpr GhcPs -> Branch
Branch (RdrName -> String
occNameStr NameOrRdrName (IdP GhcPs)
RdrName
name) [String]
a Int
b BList
c (LHsExpr GhcPs -> Branch) -> LHsExpr GhcPs -> Branch
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> LHsExpr GhcPs
simplifyExp LHsExpr 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 <- (Located (Pat GhcPs) -> Maybe (Either String BList))
-> [Located (Pat GhcPs)] -> Maybe [Either String BList]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LPat GhcPs -> Maybe (Either String BList)
Located (Pat GhcPs) -> Maybe (Either String BList)
readPat [LPat GhcPs]
[Located (Pat GhcPs)]
ps
  [Int
i] <- [Int] -> Maybe [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int] -> Maybe [Int]) -> [Int] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ (Either String BList -> Bool) -> [Either String BList] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices Either String BList -> Bool
forall a b. Either a b -> Bool
isRight [Either String BList]
ps
  let ([String]
left, [BList
right]) = [Either String BList] -> ([String], [BList])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either String BList]
ps

  ([String], Int, BList) -> Maybe ([String], Int, BList)
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 (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 _ (ParPat _ (L _ (ConPatIn (L _ n) (InfixCon (view -> PVar_ x) (view -> PVar_ xs))))))
 | IdP GhcPs
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 _ (ConPatIn (L _ n) (PrefixCon [])))
  | IdP GhcPs
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