{-# 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
_ = (LocatedAn AnnListItem (HsDecl GhcPs) -> [Idea])
-> [LocatedAn AnnListItem (HsDecl GhcPs)] -> [Idea]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LocatedAn AnnListItem (HsDecl GhcPs) -> [Idea]
f ([LocatedAn AnnListItem (HsDecl GhcPs)] -> [Idea])
-> (LocatedAn AnnListItem (HsDecl GhcPs)
    -> [LocatedAn AnnListItem (HsDecl GhcPs)])
-> LocatedAn AnnListItem (HsDecl GhcPs)
-> [Idea]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedAn AnnListItem (HsDecl GhcPs)
-> [LocatedAn AnnListItem (HsDecl GhcPs)]
forall on. Uniplate on => on -> [on]
universe
    where
        f :: LocatedAn AnnListItem (HsDecl GhcPs) -> [Idea]
f LocatedAn AnnListItem (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 :: LocatedAn AnnListItem (HsDecl GhcPs)
x = LocatedAn AnnListItem (HsDecl GhcPs)
o
            (ListCase
x, GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LocatedAn AnnListItem (HsDecl GhcPs)
addCase) <- XRec GhcPs (HsDecl GhcPs)
-> Maybe (ListCase, LHsExpr GhcPs -> XRec GhcPs (HsDecl GhcPs))
findCase XRec GhcPs (HsDecl GhcPs)
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
            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` LocatedAn AnnListItem (HsDecl GhcPs) -> [String]
forall a. AllVars a => a -> [String]
varss LocatedAn AnnListItem (HsDecl GhcPs)
y
            -- Maybe we can do better here maintaining source
            -- formatting?
            Idea -> Maybe Idea
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Idea -> Maybe Idea) -> Idea -> Maybe Idea
forall a b. (a -> b) -> a -> b
$ Severity
-> String
-> Located (HsDecl GhcPs)
-> Located (HsDecl GhcPs)
-> [Refactoring SrcSpan]
-> Idea
forall a b.
(Outputable a, Outputable b) =>
Severity
-> String
-> Located a
-> Located b
-> [Refactoring SrcSpan]
-> Idea
idea Severity
severity (String
"Use " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
use) (LocatedAn AnnListItem (HsDecl GhcPs) -> Located (HsDecl GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LocatedAn AnnListItem (HsDecl GhcPs)
o) (LocatedAn AnnListItem (HsDecl GhcPs) -> Located (HsDecl GhcPs)
forall a e. LocatedAn a e -> Located e
reLoc LocatedAn AnnListItem (HsDecl GhcPs)
y) [RType
-> SrcSpan -> [(String, SrcSpan)] -> String -> Refactoring SrcSpan
forall a. RType -> a -> [(String, a)] -> String -> Refactoring a
Replace RType
Decl (LocatedAn AnnListItem (HsDecl GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LocatedAn AnnListItem (HsDecl GhcPs)
o) [] (LocatedAn AnnListItem (HsDecl GhcPs) -> String
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
(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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 [LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
op,LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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))
_ (LPat GhcPs -> PVar_
GenLocated SrcSpanAnnA (Pat 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 (LHsExpr GhcPs -> Var_
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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] LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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)
Maybe (String, Severity, GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr 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
_ 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 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
_)}]}))
      ) =
  [ StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an 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))
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed 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 a an. a -> LocatedAn an 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 XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
NoExtField
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 SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts))) = [LStmt GhcPs (LHsExpr GhcPs)]
[GenLocated
   SrcSpanAnnA
   (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
stmts
asDo LHsExpr GhcPs
x = [StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an 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 XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
NoExtField
noExtField LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 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=XMG GhcPs (LHsExpr GhcPs)
Origin
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]
XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
HsMatchContext GhcPs
m_ctxt :: forall p body. Match p body -> HsMatchContext p
m_pats :: forall p body. Match p body -> [LPat p]
m_grhss :: forall p body. Match p body -> GRHSs p body
m_ext :: XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ctxt :: HsMatchContext GhcPs
m_pats :: [LPat GhcPs]
m_grhss :: GRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m_ext :: forall p body. Match p body -> XCMatch p body
..}) -- Match fields.
                            , GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
x2]), ..} -- Match group fields.
          , XFunBind GhcPs GhcPs
LIdP GhcPs
fun_ext :: XFunBind GhcPs GhcPs
fun_id :: LIdP GhcPs
fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
..} -- Fun. bind fields.
      )) <- LocatedAn AnnListItem (HsDecl GhcPs)
-> Maybe (LocatedAn AnnListItem (HsDecl GhcPs))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XRec GhcPs (HsDecl GhcPs)
LocatedAn AnnListItem (HsDecl 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)
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 LMatch GhcPs (LHsExpr GhcPs)
GenLocated
  SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr 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, GenLocated SrcSpanAnnA (HsExpr GhcPs)
b1), (BCons String
x String
xs, GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2)] <- [(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe [(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> Maybe [(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> [(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> Maybe [(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall a b. (a -> b) -> a -> b
$ ((BList, GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> BList)
-> [(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> [(BList, GenLocated SrcSpanAnnA (HsExpr GhcPs))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (BList, GenLocated SrcSpanAnnA (HsExpr GhcPs)) -> BList
forall a b. (a, b) -> a
fst [(BList
c1, LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b1), (BList
c2, LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2)]
  GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2
  ([String]
ps, GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2) <- ([String], LHsExpr GhcPs) -> Maybe ([String], LHsExpr GhcPs)
forall a. a -> Maybe a
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
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2

  let ps12 :: [GenLocated SrcSpanAnnA (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 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [String] -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map String -> LPat GhcPs
String -> GenLocated SrcSpanAnnA (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 :: HsLocalBindsLR GhcPs GhcPs
emptyLocalBinds = XEmptyLocalBinds GhcPs GhcPs -> HsLocalBindsLR GhcPs GhcPs
forall idL idR. XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR
EmptyLocalBinds XEmptyLocalBinds GhcPs GhcPs
NoExtField
noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.
      gRHS :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LGRHS GhcPs (LHsExpr GhcPs)
gRHS GenLocated SrcSpanAnnA (HsExpr GhcPs)
e = GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     (SrcAnn NoEpAnns)
     (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> GenLocated
      (SrcAnn NoEpAnns)
      (GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
-> GRHS GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     (SrcAnn NoEpAnns)
     (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))
EpAnn GrhsAnn
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 = 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 XCGRHSs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
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=XCMatch GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed,m_pats :: [LPat GhcPs]
m_pats=[LPat GhcPs]
[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=[GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
-> GenLocated
     SrcSpanAnnL
     [GenLocated
        SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
forall a an. a -> LocatedAn an a
noLocA [Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated
     SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an 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=DoPmc -> Origin
Generated DoPmc
DoPmc, ..} -- 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, 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.

  (ListCase,
 GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> LocatedAn AnnListItem (HsDecl GhcPs))
-> Maybe
     (ListCase,
      GenLocated SrcSpanAnnA (HsExpr GhcPs)
      -> LocatedAn AnnListItem (HsDecl GhcPs))
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
-> LHsExpr GhcPs -> (String, String, LHsExpr GhcPs) -> ListCase
ListCase [String]
ps LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b1 (String
x, String
xs, LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
b2), HsDecl GhcPs -> LocatedAn AnnListItem (HsDecl GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsDecl GhcPs -> LocatedAn AnnListItem (HsDecl GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> LocatedAn AnnListItem (HsDecl 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 XValD GhcPs
NoExtField
noExtField (HsBindLR GhcPs GhcPs -> HsDecl GhcPs)
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> HsBindLR GhcPs GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> HsDecl GhcPs
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 -> (LHsExpr GhcPs -> Var_
GenLocated SrcSpanAnnA (HsExpr 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
    ([GenLocated SrcSpanAnnA (HsExpr GhcPs)]
pre, (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> Var_
forall a b. View a b => a -> b
view -> Var_ String
v) : [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
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 [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr 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
    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)
 -> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr 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
$ GenLocated SrcSpanAnnA (HsExpr GhcPs)
recursive GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
pre [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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 -> [LHsExpr GhcPs]
LHsExpr GhcPs -> [GenLocated SrcSpanAnnA (HsExpr 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 LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr 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
GenLocated SrcSpanAnnA (HsExpr GhcPs)
x GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
: [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall {a}. [a] -> [a]
remove [LHsExpr GhcPs]
[GenLocated SrcSpanAnnA (HsExpr 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
_
                        }
            } <- 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
  ([String]
a, Int
b, BList
c) <- [LPat GhcPs] -> Maybe ([String], Int, BList)
findPat [LPat GhcPs]
ps
  Branch -> Maybe Branch
forall a. a -> Maybe a
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 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
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 <- (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 LPat GhcPs -> Maybe (Either String BList)
GenLocated SrcSpanAnnA (Pat GhcPs) -> Maybe (Either String BList)
readPat [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
ps
  [Int
i] <- [Int] -> Maybe [Int]
forall a. a -> Maybe a
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 a. a -> Maybe a
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_
GenLocated SrcSpanAnnA (Pat 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
_ LHsToken "(" GhcPs
_ (L SrcSpanAnnA
_ (ConPat XConPat GhcPs
_ (L SrcSpanAnnN
_ RdrName
n) (InfixCon (LPat GhcPs -> PVar_
GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
x) (LPat GhcPs -> PVar_
GenLocated SrcSpanAnnA (Pat GhcPs) -> PVar_
forall a b. View a b => a -> b
view -> PVar_ String
xs)))) LHsToken ")" 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 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