module Conversions.ToScala.FnDef where
import qualified SyntaxTrees.Haskell.Common as H
import qualified SyntaxTrees.Haskell.FnDef as H
import qualified SyntaxTrees.Haskell.Type as H
import qualified SyntaxTrees.Scala.Common as S
import qualified SyntaxTrees.Scala.FnDef as S
import qualified SyntaxTrees.Scala.Pattern as S
import Conversions.ToScala.Common (autoIds, literal, qCtor, qCtorOp, qVar,
qVarOp, var)
import Conversions.ToScala.Pattern (allVars, extractVars, pattern')
import Conversions.ToScala.Type (argLists, classScopeSplit, findTypeParams,
typeParam, typeSplit, usingArgList)
import Data.Foldable (Foldable (fold, toList))
import Data.List (nubBy)
import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe)
import Data.Tuple.Extra (uncurry3, (***))
import SyntaxTrees.Scala.FnDef (WhenExpr (..))
import Utils.List (groupTuplesByKey, mergeUnion)
emptyFnSig :: S.FnSig
emptyFnSig :: FnSig
emptyFnSig = [TypeParam] -> [ArgList] -> [UsingArgList] -> Maybe Type -> FnSig
S.FnSig [] [] [] forall a. Maybe a
Nothing
namedFnSig :: H.Type -> [H.Var] -> S.FnSig
namedFnSig :: Type -> [Var] -> FnSig
namedFnSig Type
tpe [Var]
args = [TypeParam] -> [ArgList] -> [UsingArgList] -> Maybe Type -> FnSig
S.FnSig (TypeParam -> TypeParam
typeParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Type -> Set TypeParam
findTypeParams Type
tpe))
([Var] -> [Type] -> [ArgList]
argLists (Var -> Var
var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
args) [Type]
argTypes)
[[ClassConstraint] -> UsingArgList
usingArgList [ClassConstraint]
constraints]
(forall a. a -> Maybe a
Just Type
retType)
where
([ClassConstraint]
constraints, Type
rest) = Type -> ([ClassConstraint], Type)
classScopeSplit Type
tpe
([Type]
argTypes, Type
retType) = Int -> Type -> ([Type], Type)
typeSplit (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
args) Type
rest
unNamedFnSig :: H.Type -> Int -> S.FnSig
unNamedFnSig :: Type -> Int -> FnSig
unNamedFnSig Type
tpe Int
n = [TypeParam] -> [ArgList] -> [UsingArgList] -> Maybe Type -> FnSig
S.FnSig (TypeParam -> TypeParam
typeParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Type -> Set TypeParam
findTypeParams Type
tpe))
([Var] -> [Type] -> [ArgList]
argLists (String -> Var
S.Var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
autoIds) [Type]
argTypes)
[[ClassConstraint] -> UsingArgList
usingArgList [ClassConstraint]
constraints]
(forall a. a -> Maybe a
Just Type
retType)
where
([ClassConstraint]
constraints, Type
rest) = Type -> ([ClassConstraint], Type)
classScopeSplit Type
tpe
([Type]
argTypes, Type
retType) = Int -> Type -> ([Type], Type)
typeSplit Int
n Type
rest
fnDefOrSigs :: [H.FnDefOrSig] -> [(Maybe H.FnSig, Maybe [H.FnDef])]
fnDefOrSigs :: [FnDefOrSig] -> [(Maybe FnSig, Maybe [FnDef])]
fnDefOrSigs [FnDefOrSig]
defsOrSigs = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy forall {b} {a} {b} {b}.
(Eq b, HasField "name" a b) =>
(Maybe a, b) -> (Maybe a, b) -> Bool
dedupFn forall a b. (a -> b) -> a -> b
$ forall a b c. Eq a => [(a, b)] -> [(a, c)] -> [(Maybe b, Maybe c)]
mergeUnion [(Var, FnSig)]
sigs [(Var, [FnDef])]
groupedDefs
where
dedupFn :: (Maybe a, b) -> (Maybe a, b) -> Bool
dedupFn (Maybe a, b)
x (Maybe a, b)
y = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isJust [forall a b. (a, b) -> a
fst (Maybe a, b)
x, forall a b. (a, b) -> a
fst (Maybe a, b)
y] Bool -> Bool -> Bool
&&
((.name) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> a
fst (Maybe a, b)
x) forall a. Eq a => a -> a -> Bool
== ((.name) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> a
fst (Maybe a, b)
y)
defs :: [(Var, FnDef)]
defs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (H.Def FnDef
x) -> forall a. a -> Maybe a
Just (forall a. [a] -> a
head FnDef
x.names, FnDef
x)
(H.Sig FnSig
_) -> forall a. Maybe a
Nothing)
[FnDefOrSig]
defsOrSigs
sigs :: [(Var, FnSig)]
sigs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case (H.Def FnDef
_) -> forall a. Maybe a
Nothing
(H.Sig FnSig
x) -> forall a. a -> Maybe a
Just (FnSig
x.name, FnSig
x))
[FnDefOrSig]
defsOrSigs
groupedDefs :: [(Var, [FnDef])]
groupedDefs = forall a b. Eq a => [(a, b)] -> [(a, [b])]
groupTuplesByKey [(Var, FnDef)]
defs
fnDefs :: (Maybe H.FnSig, Maybe [H.FnDef]) -> S.InternalFnDef
fnDefs :: (Maybe FnSig, Maybe [FnDef]) -> InternalFnDef
fnDefs (Maybe FnSig
x, Just [FnDef
y])
| forall (t :: * -> *) a. Foldable t => t a -> Int
length FnDef
y.names forall a. Ord a => a -> a -> Bool
> Int
1 = FnDef -> InternalFnDef
valDef FnDef
y
| [Pattern] -> Bool
allVars FnDef
y.args = Maybe FnSig -> FnDef -> InternalFnDef
simpleFnDef Maybe FnSig
x FnDef
y
fnDefs (Maybe FnSig
x, Maybe [FnDef]
y) = Maybe FnSig -> Maybe [FnDef] -> InternalFnDef
fnDef Maybe FnSig
x Maybe [FnDef]
y
fnDef :: Maybe H.FnSig -> Maybe [H.FnDef] -> S.InternalFnDef
fnDef :: Maybe FnSig -> Maybe [FnDef] -> InternalFnDef
fnDef Maybe FnSig
sig Maybe [FnDef]
defs = MethodDef -> InternalFnDef
S.FnMethod forall a b. (a -> b) -> a -> b
$ [Modifier] -> Var -> Maybe FnSig -> Maybe FnBody -> MethodDef
S.MethodDef [] Var
name Maybe FnSig
fnSig
(FnBody -> FnBody
matchFn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FnDef] -> FnBody
fnDefToFnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [FnDef]
defs)
where
n :: Int
n = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.args)) forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold) Maybe [FnDef]
defs
fnSig :: Maybe FnSig
fnSig = (Type -> Int -> FnSig
`unNamedFnSig` Int
n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.type') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FnSig
sig
name :: Var
name = Var -> Var
var forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.names) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [FnDef]
defs) (.name) Maybe FnSig
sig
(Int
n', FnBody -> FnBody
matchFn) = if Int
n forall a. Eq a => a -> a -> Bool
== Int
1 then (Int
0, FnBody -> FnBody
topLevelMatch) else (Int
n, forall a. a -> a
id)
simpleFnDef :: Maybe H.FnSig -> H.FnDef -> S.InternalFnDef
simpleFnDef :: Maybe FnSig -> FnDef -> InternalFnDef
simpleFnDef Maybe FnSig
sig FnDef
def = MethodDef -> InternalFnDef
S.FnMethod forall a b. (a -> b) -> a -> b
$ [Modifier] -> Var -> Maybe FnSig -> Maybe FnBody -> MethodDef
S.MethodDef [] Var
name Maybe FnSig
fnSig
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FnDef -> FnBody
simpleFnDefToFnBody FnDef
def)
where
name :: Var
name = Var -> Var
var forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head FnDef
def.names
args :: [Var]
args = [Pattern] -> [Var]
extractVars forall a b. (a -> b) -> a -> b
$ (.args) FnDef
def
fnSig :: Maybe FnSig
fnSig = (Type -> [Var] -> FnSig
`namedFnSig` [Var]
args) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.type') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FnSig
sig
valDef :: H.FnDef -> S.InternalFnDef
valDef :: FnDef -> InternalFnDef
valDef FnDef
def = ValDef -> InternalFnDef
S.FnVal forall a b. (a -> b) -> a -> b
$ [Modifier] -> [Var] -> Maybe Type -> Maybe FnBody -> ValDef
S.ValDef [Modifier
S.Lazy] [Var]
names forall a. Maybe a
Nothing
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FnDef -> FnBody
simpleFnDefToFnBody FnDef
def)
where
names :: [Var]
names = Var -> Var
var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FnDef
def.names
simpleFnDefToFnBody :: H.FnDef -> S.FnBody
simpleFnDefToFnBody :: FnDef -> FnBody
simpleFnDefToFnBody FnDef
def = MaybeGuardedFnBody -> FnBody
maybeGuardedBody forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.body) forall a b. (a -> b) -> a -> b
$ FnDef
def
fnDefToFnBody :: [H.FnDef] -> S.FnBody
fnDefToFnBody :: [FnDef] -> FnBody
fnDefToFnBody [FnDef]
defs = FnBody
match
where
match :: FnBody
match = FnBody -> FnBody
simplifyMatch forall a b. (a -> b) -> a -> b
$
FnBody -> [CaseBinding] -> FnBody
S.MatchExpr ([String] -> FnBody
tuple forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
n [String]
autoIds) [CaseBinding]
cases
casePatterns :: [Pattern]
casePatterns = ([Pattern] -> Pattern
S.TuplePattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern -> Pattern
pattern' <$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.args)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnDef]
defs
caseBodies :: [FnBody]
caseBodies = (MaybeGuardedFnBody -> FnBody
maybeGuardedBody forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.body)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnDef]
defs
cases :: [CaseBinding]
cases = forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Pattern]
casePatterns (forall a. a -> [a]
repeat forall a. Maybe a
Nothing)
[FnBody]
caseBodies
tuple :: [String] -> FnBody
tuple [String]
x = [FnBody] -> FnBody
S.Tuple forall a b. (a -> b) -> a -> b
$ (FnVar -> FnBody
S.FnVar' forall b c a. (b -> c) -> (a -> b) -> a -> c
. QVar -> FnVar
S.Var' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Package -> Var -> QVar
S.QVar forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Var
S.Var) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
x
n :: Int
n = (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.args)) (forall a. [a] -> a
head [FnDef]
defs)
fnBody :: H.FnBody -> S.FnBody
fnBody :: FnBody -> FnBody
fnBody (H.FnApply FnBody
x [FnBody]
y) = FnBody -> [FnBody] -> FnBody
S.FnApply (FnBody -> FnBody
fnBody FnBody
x) (FnBody -> FnBody
fnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnBody]
y)
fnBody (H.InfixFnApply [FnOp]
x [FnBody]
y) = [FnOp] -> [FnBody] -> FnBody
S.InfixFnApply (FnOp -> FnOp
fnOp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnOp]
x) (FnBody -> FnBody
fnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnBody]
y)
fnBody (H.LeftOpSection FnOp
x FnBody
y) = [Pattern] -> FnBody -> FnBody
S.LambdaExpr [] ([FnOp] -> [FnBody] -> FnBody
S.InfixFnApply [FnOp -> FnOp
fnOp FnOp
x]
[FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QVar -> FnVar
S.Var' forall a b. (a -> b) -> a -> b
$ Maybe Package -> Var -> QVar
S.QVar forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> Var
S.Var String
"_", FnBody -> FnBody
fnBody FnBody
y])
fnBody (H.RightOpSection FnBody
x FnOp
y) = [Pattern] -> FnBody -> FnBody
S.LambdaExpr [] ([FnOp] -> [FnBody] -> FnBody
S.InfixFnApply [FnOp -> FnOp
fnOp FnOp
y]
[FnBody -> FnBody
fnBody FnBody
x, FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QVar -> FnVar
S.Var' forall a b. (a -> b) -> a -> b
$ Maybe Package -> Var -> QVar
S.QVar forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> Var
S.Var String
"_"])
fnBody (H.LambdaExpr [Pattern]
x FnBody
y) = [Pattern] -> FnBody -> FnBody
S.LambdaExpr (Pattern -> Pattern
pattern' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
x)
(FnBody -> FnBody
fnBody FnBody
y)
fnBody (H.IfExpr FnBody
x FnBody
y FnBody
z) = FnBody -> FnBody -> FnBody -> FnBody
S.IfExpr (FnBody -> FnBody
fnBody FnBody
x) (FnBody -> FnBody
fnBody FnBody
y) (FnBody -> FnBody
fnBody FnBody
z)
fnBody (H.DoExpr [DoStep]
x) = [ForStep] -> FnBody -> FnBody
S.ForExpr (DoStep -> ForStep
doStep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
init [DoStep]
x) (DoStep -> FnBody
extractDoStep forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [DoStep]
x)
fnBody (H.MultiWayIfExpr [GuardedFnBody]
x) = MaybeGuardedFnBody -> FnBody
maybeGuardedBody forall a b. (a -> b) -> a -> b
$ [GuardedFnBody] -> MaybeGuardedFnBody
H.Guarded [GuardedFnBody]
x
fnBody (H.CaseOfExpr FnBody
x [CaseBinding]
y) = FnBody -> FnBody
simplifyMatch forall a b. (a -> b) -> a -> b
$
FnBody -> [CaseBinding] -> FnBody
S.MatchExpr (FnBody -> FnBody
fnBody FnBody
x) (CaseBinding -> CaseBinding
caseBinding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CaseBinding]
y)
fnBody (H.LambdaCaseExpr [CaseBinding]
x) = [Pattern] -> FnBody -> FnBody
S.LambdaExpr [] (FnBody -> FnBody
fnBody forall a b. (a -> b) -> a -> b
$ FnBody -> [CaseBinding] -> FnBody
H.CaseOfExpr
(FnVar -> FnBody
H.FnVar' forall a b. (a -> b) -> a -> b
$ QVar -> FnVar
H.Var' forall a b. (a -> b) -> a -> b
$ Maybe Module -> Var -> QVar
H.QVar forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> Var
H.Var String
"_") [CaseBinding]
x)
fnBody (H.TypeAnnotation FnBody
x Type
_) = FnBody -> FnBody
fnBody FnBody
x
fnBody (H.ListRange FnBody
x (Just FnBody
y)) = [FnOp] -> [FnBody] -> FnBody
S.InfixFnApply
[QVarOp -> FnOp
S.VarOp' forall a b. (a -> b) -> a -> b
$ Maybe Package -> VarOp -> QVarOp
S.QVarOp forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> VarOp
S.VarOp String
"to"] [FnBody -> FnBody
fnBody FnBody
x, FnBody -> FnBody
fnBody FnBody
y]
fnBody (H.ListRange FnBody
x Maybe FnBody
Nothing) = [FnOp] -> [FnBody] -> FnBody
S.InfixFnApply
[QVarOp -> FnOp
S.VarOp' forall a b. (a -> b) -> a -> b
$ Maybe Package -> VarOp -> QVarOp
S.QVarOp forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> VarOp
S.VarOp String
"to"]
[FnBody -> FnBody
fnBody FnBody
x, FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QVar -> FnVar
S.Var' forall a b. (a -> b) -> a -> b
$ Maybe Package -> Var -> QVar
S.QVar forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> Var
S.Var String
"maxBound"]
fnBody (H.Tuple [FnBody]
x) = [FnBody] -> FnBody
S.Tuple forall a b. (a -> b) -> a -> b
$ FnBody -> FnBody
fnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnBody]
x
fnBody (H.FnOp' FnOp
x) = FnOp -> FnBody
S.FnOp' forall a b. (a -> b) -> a -> b
$ FnOp -> FnOp
fnOp FnOp
x
fnBody (H.FnVar' FnVar
x) = FnVar -> FnBody
fnVar FnVar
x
fnBody (H.Literal' Literal
x) = Literal -> FnBody
S.Literal' forall a b. (a -> b) -> a -> b
$ Literal -> Literal
literal Literal
x
fnBody (H.List []) = FnBody -> [FnBody] -> FnBody
S.FnApply
(FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QCtor -> FnVar
S.Ctor' forall a b. (a -> b) -> a -> b
$ Maybe Package -> Ctor -> QCtor
S.QCtor (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [String] -> Package
S.Package [String
"List"])
(String -> Ctor
S.Ctor String
"empty")) []
fnBody (H.List [FnBody]
x) = FnBody -> [FnBody] -> FnBody
S.FnApply
(FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QCtor -> FnVar
S.Ctor' forall a b. (a -> b) -> a -> b
$ Maybe Package -> Ctor -> QCtor
S.QCtor forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> Ctor
S.Ctor String
"List")
(FnBody -> FnBody
fnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnBody]
x)
fnBody (H.LetExpr [FnDefOrSig]
x FnBody
y) = [InternalFnDef] -> FnBody -> FnBody
S.LetExpr ((Maybe FnSig, Maybe [FnDef]) -> InternalFnDef
fnDefs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnDefOrSig] -> [(Maybe FnSig, Maybe [FnDef])]
fnDefOrSigs [FnDefOrSig]
x)
(FnBody -> FnBody
fnBody FnBody
y)
fnBody (H.WhereExpr FnBody
x [FnDefOrSig]
y) = [InternalFnDef] -> FnBody -> FnBody
S.LetExpr ((Maybe FnSig, Maybe [FnDef]) -> InternalFnDef
fnDefs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnDefOrSig] -> [(Maybe FnSig, Maybe [FnDef])]
fnDefOrSigs [FnDefOrSig]
y)
(FnBody -> FnBody
fnBody FnBody
x)
fnBody (H.RecordCreate FnBody
x [(Var, FnBody)]
y) = FnBody -> [(Var, FnBody)] -> FnBody
S.NamedFnApply (FnBody -> FnBody
fnBody FnBody
x)
((Var -> Var
var forall a a' b b'. (a -> a') -> (b -> b') -> (a, b) -> (a', b')
*** FnBody -> FnBody
fnBody) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, FnBody)]
y)
fnBody (H.RecordUpdate FnBody
x [(Var, FnBody)]
y) =
FnBody -> [(Var, FnBody)] -> FnBody
S.NamedFnApply (FnBody -> [Var] -> FnBody
S.BodySelection (FnBody -> FnBody
fnBody FnBody
x) [String -> Var
S.Var String
"copy"])
((Var -> Var
var forall a a' b b'. (a -> a') -> (b -> b') -> (a, b) -> (a', b')
*** FnBody -> FnBody
fnBody) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, FnBody)]
y)
doStep :: H.DoStep -> S.ForStep
doStep :: DoStep -> ForStep
doStep (H.DoBinding [Var]
x FnBody
y) = [Var] -> FnBody -> ForStep
S.ForBinding (Var -> Var
var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
x) (FnBody -> FnBody
fnBody FnBody
y)
doStep (H.LetBinding [FnDefOrSig]
x) = [InternalFnDef] -> ForStep
S.LetBinding ((Maybe FnSig, Maybe [FnDef]) -> InternalFnDef
fnDefs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnDefOrSig] -> [(Maybe FnSig, Maybe [FnDef])]
fnDefOrSigs [FnDefOrSig]
x)
doStep (H.Body FnBody
x) = [Var] -> FnBody -> ForStep
S.ForBinding [String -> Var
S.Var String
"_"] (FnBody -> FnBody
fnBody FnBody
x)
caseBinding :: H.CaseBinding -> S.CaseBinding
caseBinding :: CaseBinding -> CaseBinding
caseBinding (H.CaseBinding Pattern
x MaybeGuardedFnBody
y) = Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding (Pattern -> Pattern
pattern' Pattern
x) forall a. Maybe a
Nothing
(MaybeGuardedFnBody -> FnBody
maybeGuardedBody MaybeGuardedFnBody
y)
simplifyMatch :: S.FnBody -> S.FnBody
simplifyMatch :: FnBody -> FnBody
simplifyMatch (S.MatchExpr FnBody
x [CaseBinding]
y) = FnBody -> [CaseBinding] -> FnBody
S.MatchExpr FnBody
x (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CaseBinding -> [CaseBinding]
simplifyCases [CaseBinding]
y)
simplifyMatch FnBody
x = FnBody
x
topLevelMatch :: S.FnBody -> S.FnBody
topLevelMatch :: FnBody -> FnBody
topLevelMatch (S.MatchExpr FnBody
_ [CaseBinding]
y) = [CaseBinding] -> FnBody
S.TopLevelMatchExpr [CaseBinding]
y
topLevelMatch FnBody
x = FnBody
x
simplifyCases :: S.CaseBinding -> [S.CaseBinding]
simplifyCases :: CaseBinding -> [CaseBinding]
simplifyCases (S.CaseBinding Pattern
x' Maybe FnBody
Nothing (S.MatchExpr FnBody
_ [CaseBinding]
y))
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseBinding -> Maybe (Maybe FnBody, FnBody)
simpleCase) [CaseBinding]
y = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding Pattern
x') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe FnBody, FnBody)]
z
where
z :: [(Maybe FnBody, FnBody)]
z = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CaseBinding -> Maybe (Maybe FnBody, FnBody)
simpleCase [CaseBinding]
y
simplifyCases CaseBinding
x = [CaseBinding
x]
simpleCase :: S.CaseBinding -> Maybe (Maybe S.FnBody, S.FnBody)
simpleCase :: CaseBinding -> Maybe (Maybe FnBody, FnBody)
simpleCase (S.CaseBinding Pattern
S.Wildcard Maybe FnBody
x FnBody
y) = forall a. a -> Maybe a
Just (Maybe FnBody
x, FnBody
y)
simpleCase CaseBinding
_ = forall a. Maybe a
Nothing
maybeGuardedBody :: H.MaybeGuardedFnBody -> S.FnBody
maybeGuardedBody :: MaybeGuardedFnBody -> FnBody
maybeGuardedBody (H.Guarded [GuardedFnBody]
x)
| Guard
H.Otherwise <- forall a. [a] -> a
last [Guard]
guards
, forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Guard -> Bool
onlySimpleGuards forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
init [Guard]
guards
= [WhenExpr] -> FnBody -> FnBody
S.CondExpr [WhenExpr]
whenBranches FnBody
elseBranch
where
guards :: [Guard]
guards = (.guard) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedFnBody]
x
bodies :: [FnBody]
bodies = FnBody -> FnBody
fnBody forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.body) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedFnBody]
x
conds :: [FnBody]
conds = [FnBody] -> FnBody
aggregateConds forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FnBody -> FnBody
fnBody <$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Guard -> [FnBody]
extractSimpleGuards forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. [a] -> [a]
init [Guard]
guards)
whenBranches :: [WhenExpr]
whenBranches = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FnBody -> FnBody -> WhenExpr
WhenExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [FnBody]
conds (forall a. [a] -> [a]
init [FnBody]
bodies)
elseBranch :: FnBody
elseBranch = forall a. [a] -> a
last [FnBody]
bodies
maybeGuardedBody (H.Guarded [GuardedFnBody]
x) = FnBody -> FnBody
simplifyMatch forall a b. (a -> b) -> a -> b
$
FnBody -> [CaseBinding] -> FnBody
S.MatchExpr (Literal -> FnBody
S.Literal' forall a b. (a -> b) -> a -> b
$ Bool -> Literal
S.BoolLit Bool
True) (GuardedFnBody -> CaseBinding
guardedBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedFnBody]
x)
maybeGuardedBody (H.Standard FnBody
x) = FnBody -> FnBody
fnBody FnBody
x
guardedBody :: H.GuardedFnBody -> S.CaseBinding
guardedBody :: GuardedFnBody -> CaseBinding
guardedBody (H.GuardedFnBody x :: Guard
x@(H.Guard [PatternGuard]
y) FnBody
body)
| Guard -> Bool
onlySimpleGuards Guard
x =
Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding Pattern
S.Wildcard (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [FnBody] -> FnBody
aggregateConds forall a b. (a -> b) -> a -> b
$
FnBody -> FnBody
fnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Guard -> [FnBody]
extractSimpleGuards Guard
x)
(FnBody -> FnBody
fnBody FnBody
body)
| Bool
otherwise =
Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding Pattern
S.Wildcard forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PatternGuard -> FnBody -> FnBody
patternGuard (FnBody -> FnBody
fnBody FnBody
body) [PatternGuard]
y
guardedBody (H.GuardedFnBody Guard
H.Otherwise FnBody
body) =
Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding Pattern
S.Wildcard forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ FnBody -> FnBody
fnBody FnBody
body
patternGuard :: H.PatternGuard -> S.FnBody -> S.FnBody
patternGuard :: PatternGuard -> FnBody -> FnBody
patternGuard (H.PatternGuard Pattern
x FnBody
y) FnBody
body = FnBody -> FnBody
simplifyMatch forall a b. (a -> b) -> a -> b
$
FnBody -> [CaseBinding] -> FnBody
S.MatchExpr
(FnBody -> FnBody
fnBody FnBody
y)
[Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding (Pattern -> Pattern
pattern' Pattern
x) forall a. Maybe a
Nothing FnBody
body]
patternGuard (H.SimpleGuard FnBody
x) FnBody
body = FnBody -> FnBody
simplifyMatch forall a b. (a -> b) -> a -> b
$
FnBody -> [CaseBinding] -> FnBody
S.MatchExpr
(Literal -> FnBody
S.Literal' forall a b. (a -> b) -> a -> b
$ Bool -> Literal
S.BoolLit Bool
True)
[Pattern -> Maybe FnBody -> FnBody -> CaseBinding
S.CaseBinding Pattern
S.Wildcard (forall a. a -> Maybe a
Just (FnBody -> FnBody
fnBody FnBody
x)) FnBody
body]
fnVar :: H.FnVar -> S.FnBody
fnVar :: FnVar -> FnBody
fnVar (H.Selector Var
x) = [Pattern] -> FnBody -> FnBody
S.LambdaExpr [] forall a b. (a -> b) -> a -> b
$ FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$
QVar -> [Var] -> FnVar
S.Selection (Maybe Package -> Var -> QVar
S.QVar forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> Var
S.Var String
"_") [Var -> Var
var Var
x]
fnVar (H.Selection QVar
x [Var]
y) = FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QVar -> [Var] -> FnVar
S.Selection (QVar -> QVar
qVar QVar
x) (Var -> Var
var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
y)
fnVar (H.Var' QVar
x) = FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QVar -> FnVar
S.Var' forall a b. (a -> b) -> a -> b
$ QVar -> QVar
qVar QVar
x
fnVar (H.Ctor' QCtor
x) = FnVar -> FnBody
S.FnVar' forall a b. (a -> b) -> a -> b
$ QCtor -> FnVar
S.Ctor' forall a b. (a -> b) -> a -> b
$ QCtor -> QCtor
qCtor QCtor
x
fnOp :: H.FnOp -> S.FnOp
fnOp :: FnOp -> FnOp
fnOp (H.VarOp' QVarOp
x) = QVarOp -> FnOp
S.VarOp' forall a b. (a -> b) -> a -> b
$ QVarOp -> QVarOp
qVarOp QVarOp
x
fnOp (H.CtorOp' QCtorOp
x) = QCtorOp -> FnOp
S.CtorOp' forall a b. (a -> b) -> a -> b
$ QCtorOp -> QCtorOp
qCtorOp QCtorOp
x
extractDoStep :: H.DoStep -> S.FnBody
(H.DoBinding [Var]
_ FnBody
y) = FnBody -> FnBody
fnBody FnBody
y
extractDoStep (H.Body FnBody
x) = FnBody -> FnBody
fnBody FnBody
x
extractDoStep (H.LetBinding [FnDefOrSig]
_) = [FnBody] -> FnBody
S.Tuple []
extractSimpleGuards :: H.Guard -> [H.FnBody]
(H.Guard [PatternGuard]
x) =
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\case (H.SimpleGuard FnBody
y) -> [FnBody
y]; PatternGuard
_ -> []) [PatternGuard]
x
extractSimpleGuards Guard
_ = []
onlySimpleGuards :: H.Guard -> Bool
onlySimpleGuards :: Guard -> Bool
onlySimpleGuards (H.Guard [PatternGuard]
x) =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\case (H.SimpleGuard FnBody
_) -> Bool
True; PatternGuard
_ -> Bool
False ) [PatternGuard]
x
onlySimpleGuards Guard
H.Otherwise = Bool
False
aggregateConds :: [S.FnBody] -> S.FnBody
aggregateConds :: [FnBody] -> FnBody
aggregateConds [FnBody
x] = FnBody
x
aggregateConds [FnBody]
x = [FnOp] -> [FnBody] -> FnBody
S.InfixFnApply
[QVarOp -> FnOp
S.VarOp' forall a b. (a -> b) -> a -> b
$ Maybe Package -> VarOp -> QVarOp
S.QVarOp forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String -> VarOp
S.VarOp String
"&&"] [FnBody]
x