{- |
    Module      :  $Header$
    Description :  Optimizing the Desugared Code
    Copyright   :  (c) 2003        Wolfgang Lux
                                   Martin Engelke
                       2011 - 2015 Björn Peemöller
                       2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

   After desugaring the source code, but before lifting local
   declarations, the compiler performs a few simple optimizations to
   improve the efficiency of the generated code. In addition, the
   optimizer replaces pattern bindings with simple variable bindings and
   selector functions.

   Currently, the following optimizations are implemented:

     * Under certain conditions, inline local function definitions.
     * Remove unused declarations.
     * Compute minimal binding groups for let expressions.
     * Remove pattern bindings to constructor terms
     * Inline simple constants.
-}
{-# LANGUAGE CPP #-}
module Transformations.Simplify (simplify) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative        ((<$>), (<*>))
#endif
import           Control.Monad.Extra        (concatMapM)
import           Control.Monad.State as S   (State, runState, gets, modify)
import qualified Data.Map            as Map (Map, empty, insert, lookup)

import Curry.Base.Ident
import Curry.Base.SpanInfo
import Curry.Syntax

import Base.Expr
import Base.Messages (internalError)
import Base.SCC
import Base.Types
import Base.Typing
import Base.Utils

import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)

-- -----------------------------------------------------------------------------
-- Simplification
-- -----------------------------------------------------------------------------

simplify :: ValueEnv -> Module Type -> (Module Type, ValueEnv)
simplify :: ValueEnv -> Module Type -> (Module Type, ValueEnv)
simplify vEnv :: ValueEnv
vEnv mdl :: Module Type
mdl@(Module _ _ m :: ModuleIdent
m _ _ _) = (Module Type
mdl', SimplifyState -> ValueEnv
valueEnv SimplifyState
s')
  where (mdl' :: Module Type
mdl', s' :: SimplifyState
s') = State SimplifyState (Module Type)
-> SimplifyState -> (Module Type, SimplifyState)
forall s a. State s a -> s -> (a, s)
S.runState (Module Type -> State SimplifyState (Module Type)
simModule Module Type
mdl) (ModuleIdent -> ValueEnv -> Int -> SimplifyState
SimplifyState ModuleIdent
m ValueEnv
vEnv 1)

-- -----------------------------------------------------------------------------
-- Internal state monad
-- -----------------------------------------------------------------------------

data SimplifyState = SimplifyState
  { SimplifyState -> ModuleIdent
moduleIdent :: ModuleIdent -- read-only!
  , SimplifyState -> ValueEnv
valueEnv    :: ValueEnv    -- updated for new pattern selection functions
  , SimplifyState -> Int
nextId      :: Int         -- counter
  }

type SIM = S.State SimplifyState

getModuleIdent :: SIM ModuleIdent
getModuleIdent :: SIM ModuleIdent
getModuleIdent = (SimplifyState -> ModuleIdent) -> SIM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SimplifyState -> ModuleIdent
moduleIdent

getNextId :: SIM Int
getNextId :: SIM Int
getNextId = do
  Int
nid <- (SimplifyState -> Int) -> SIM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SimplifyState -> Int
nextId
  (SimplifyState -> SimplifyState)
-> StateT SimplifyState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((SimplifyState -> SimplifyState)
 -> StateT SimplifyState Identity ())
-> (SimplifyState -> SimplifyState)
-> StateT SimplifyState Identity ()
forall a b. (a -> b) -> a -> b
$ \s :: SimplifyState
s -> SimplifyState
s { nextId :: Int
nextId = Int -> Int
forall a. Enum a => a -> a
succ Int
nid }
  Int -> SIM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
nid

getFunArity :: QualIdent -> SIM Int
getFunArity :: QualIdent -> SIM Int
getFunArity f :: QualIdent
f = do
  ValueEnv
vEnv <- SIM ValueEnv
getValueEnv
  Int -> SIM Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> SIM Int) -> Int -> SIM Int
forall a b. (a -> b) -> a -> b
$ case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
f ValueEnv
vEnv of
    [Value _ _ a :: Int
a _] -> Int
a
    [Label   _ _ _] -> 1
    _               -> String -> Int
forall a. String -> a
internalError (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ "Simplify.funType " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
f

getValueEnv :: SIM ValueEnv
getValueEnv :: SIM ValueEnv
getValueEnv = (SimplifyState -> ValueEnv) -> SIM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets SimplifyState -> ValueEnv
valueEnv

freshIdent :: (Int -> Ident) -> SIM Ident
freshIdent :: (Int -> Ident) -> SIM Ident
freshIdent f :: Int -> Ident
f = Int -> Ident
f (Int -> Ident) -> SIM Int -> SIM Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SIM Int
getNextId

-- -----------------------------------------------------------------------------
-- Simplification
-- -----------------------------------------------------------------------------

simModule :: Module Type -> SIM (Module Type)
simModule :: Module Type -> State SimplifyState (Module Type)
simModule (Module spi :: SpanInfo
spi ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl Type]
ds) = SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl Type]
-> Module Type
forall a.
SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
es [ImportDecl]
is
                                         ([Decl Type] -> Module Type)
-> StateT SimplifyState Identity [Decl Type]
-> State SimplifyState (Module Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl Type -> StateT SimplifyState Identity (Decl Type))
-> [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InlineEnv -> Decl Type -> StateT SimplifyState Identity (Decl Type)
simDecl InlineEnv
forall k a. Map k a
Map.empty) [Decl Type]
ds

-- Inline an expression for a variable
type InlineEnv = Map.Map Ident (Expression Type)

simDecl :: InlineEnv -> Decl Type -> SIM (Decl Type)
simDecl :: InlineEnv -> Decl Type -> StateT SimplifyState Identity (Decl Type)
simDecl env :: InlineEnv
env (FunctionDecl p :: SpanInfo
p ty :: Type
ty f :: Ident
f eqs :: [Equation Type]
eqs) = SpanInfo -> Type -> Ident -> [Equation Type] -> Decl Type
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p Type
ty Ident
f
                                        ([Equation Type] -> Decl Type)
-> StateT SimplifyState Identity [Equation Type]
-> StateT SimplifyState Identity (Decl Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Equation Type -> StateT SimplifyState Identity [Equation Type])
-> [Equation Type] -> StateT SimplifyState Identity [Equation Type]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (InlineEnv
-> Equation Type -> StateT SimplifyState Identity [Equation Type]
simEquation InlineEnv
env) [Equation Type]
eqs
simDecl env :: InlineEnv
env (PatternDecl     p :: SpanInfo
p t :: Pattern Type
t rhs :: Rhs Type
rhs) = SpanInfo -> Pattern Type -> Rhs Type -> Decl Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern Type
t (Rhs Type -> Decl Type)
-> StateT SimplifyState Identity (Rhs Type)
-> StateT SimplifyState Identity (Decl Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InlineEnv -> Rhs Type -> StateT SimplifyState Identity (Rhs Type)
simRhs InlineEnv
env Rhs Type
rhs
simDecl _   d :: Decl Type
d                         = Decl Type -> StateT SimplifyState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl Type
d

simEquation :: InlineEnv -> Equation Type -> SIM [Equation Type]
simEquation :: InlineEnv
-> Equation Type -> StateT SimplifyState Identity [Equation Type]
simEquation env :: InlineEnv
env (Equation p :: SpanInfo
p lhs :: Lhs Type
lhs rhs :: Rhs Type
rhs) = do
  Rhs Type
rhs'  <- InlineEnv -> Rhs Type -> StateT SimplifyState Identity (Rhs Type)
simRhs InlineEnv
env Rhs Type
rhs
  InlineEnv
-> SpanInfo
-> Lhs Type
-> Rhs Type
-> StateT SimplifyState Identity [Equation Type]
inlineFun InlineEnv
env SpanInfo
p Lhs Type
lhs Rhs Type
rhs'

simRhs :: InlineEnv -> Rhs Type -> SIM (Rhs Type)
simRhs :: InlineEnv -> Rhs Type -> StateT SimplifyState Identity (Rhs Type)
simRhs env :: InlineEnv
env (SimpleRhs p :: SpanInfo
p e :: Expression Type
e _) = SpanInfo -> Expression Type -> Rhs Type
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p (Expression Type -> Rhs Type)
-> StateT SimplifyState Identity (Expression Type)
-> StateT SimplifyState Identity (Rhs Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env Expression Type
e
simRhs _   (GuardedRhs  _ _ _) = String -> StateT SimplifyState Identity (Rhs Type)
forall a. HasCallStack => String -> a
error "Simplify.simRhs: guarded rhs"

-- -----------------------------------------------------------------------------
-- Inlining of Functions
-- -----------------------------------------------------------------------------

-- After simplifying the right hand side of an equation, the compiler
-- transforms declarations of the form
--
--   f t_1 ... t_{k-l} x_{k-l+1} ... x_k =
--     let g y_1 ... y_l = e
--     in  g x_{k-l+1} ... x_k
--
-- into the equivalent definition
--
--   f t_1 ... t_{k-l} x_{k-l+1} x_k = let y_1   = x_{k-l+1}
--                                              ...
--                                         y_l   = x_k
--                                     in  e
--
-- where the arities of 'f' and 'g' are 'k' and 'l', respectively, and
-- 'x_{k-l+1}, ... ,x_k' are variables. The transformation can obviously be
-- generalized to the case where 'g' is defined by more than one equation.
-- However, we must be careful not to change the evaluation mode of arguments.
-- Therefore, the transformation is applied only all of the arguments of 'g'
-- are variables.
--
-- This transformation is actually just a special case of inlining a
-- (local) function definition. We are unable to handle the general case
-- because it would require to represent the pattern matching code
-- explicitly in a Curry expression.

inlineFun :: InlineEnv -> SpanInfo -> Lhs Type -> Rhs Type
          -> SIM [Equation Type]
inlineFun :: InlineEnv
-> SpanInfo
-> Lhs Type
-> Rhs Type
-> StateT SimplifyState Identity [Equation Type]
inlineFun env :: InlineEnv
env p :: SpanInfo
p lhs :: Lhs Type
lhs rhs :: Rhs Type
rhs = do
  ModuleIdent
m <- SIM ModuleIdent
getModuleIdent
  case Rhs Type
rhs of
    SimpleRhs _ (Let NoSpanInfo [FunctionDecl _ _ f' :: Ident
f' eqs' :: [Equation Type]
eqs'] e :: Expression Type
e) _
      | -- @f'@ is not recursive
        Ident
f' Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ModuleIdent -> [Equation Type] -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m [Equation Type]
eqs'
        -- @f'@ does not perform any pattern matching
        Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [(Pattern Type -> Bool) -> [Pattern Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pattern Type -> Bool
forall a. Pattern a -> Bool
isVariablePattern [Pattern Type]
ts1 | Equation _ (FunLhs _ _ ts1 :: [Pattern Type]
ts1) _ <- [Equation Type]
eqs']
      -> do
        let a :: Int
a = Equation Type -> Int
forall a. Equation a -> Int
eqnArity (Equation Type -> Int) -> Equation Type -> Int
forall a b. (a -> b) -> a -> b
$ [Equation Type] -> Equation Type
forall a. [a] -> a
head [Equation Type]
eqs'
            (n :: Int
n, vs' :: [(Type, Ident)]
vs', e' :: Expression Type
e') = Int
-> [(Type, Ident)]
-> [Pattern Type]
-> Expression Type
-> (Int, [(Type, Ident)], Expression Type)
forall a a a.
Num a =>
a
-> [(a, Ident)]
-> [Pattern a]
-> Expression a
-> (a, [(a, Ident)], Expression a)
etaReduce 0 [] ([Pattern Type] -> [Pattern Type]
forall a. [a] -> [a]
reverse ((Ident, [Pattern Type]) -> [Pattern Type]
forall a b. (a, b) -> b
snd ((Ident, [Pattern Type]) -> [Pattern Type])
-> (Ident, [Pattern Type]) -> [Pattern Type]
forall a b. (a -> b) -> a -> b
$ Lhs Type -> (Ident, [Pattern Type])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs Lhs Type
lhs)) Expression Type
e
        if  -- the eta-reduced rhs of @f@ is a call to @f'@
            Expression Type
e' Expression Type -> Expression Type -> Bool
forall a. Eq a => a -> a -> Bool
== SpanInfo -> Type -> QualIdent -> Expression Type
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo (Expression Type -> Type
forall a. Typeable a => a -> Type
typeOf Expression Type
e') (Ident -> QualIdent
qualify Ident
f')
            -- @f'@ was fully applied before eta-reduction
            Bool -> Bool -> Bool
&& Int
n  Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
a
          then (Equation Type -> StateT SimplifyState Identity (Equation Type))
-> [Equation Type] -> StateT SimplifyState Identity [Equation Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> [(Type, Ident)]
-> Equation Type
-> StateT SimplifyState Identity (Equation Type)
mergeEqns SpanInfo
p [(Type, Ident)]
vs') [Equation Type]
eqs'
          else [Equation Type] -> StateT SimplifyState Identity [Equation Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [SpanInfo -> Lhs Type -> Rhs Type -> Equation Type
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p Lhs Type
lhs Rhs Type
rhs]
    _ -> [Equation Type] -> StateT SimplifyState Identity [Equation Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [SpanInfo -> Lhs Type -> Rhs Type -> Equation Type
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p Lhs Type
lhs Rhs Type
rhs]
  where
  etaReduce :: a
-> [(a, Ident)]
-> [Pattern a]
-> Expression a
-> (a, [(a, Ident)], Expression a)
etaReduce n1 :: a
n1 vs :: [(a, Ident)]
vs (VariablePattern _ ty :: a
ty v :: Ident
v : ts1 :: [Pattern a]
ts1)
                  (Apply NoSpanInfo e1 :: Expression a
e1 (Variable NoSpanInfo _ v' :: QualIdent
v'))
    | Ident -> QualIdent
qualify Ident
v QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
v' = a
-> [(a, Ident)]
-> [Pattern a]
-> Expression a
-> (a, [(a, Ident)], Expression a)
etaReduce (a
n1 a -> a -> a
forall a. Num a => a -> a -> a
+ 1) ((a
ty, Ident
v) (a, Ident) -> [(a, Ident)] -> [(a, Ident)]
forall a. a -> [a] -> [a]
: [(a, Ident)]
vs) [Pattern a]
ts1 Expression a
e1
  etaReduce n1 :: a
n1 vs :: [(a, Ident)]
vs _ e1 :: Expression a
e1 = (a
n1, [(a, Ident)]
vs, Expression a
e1)

  mergeEqns :: SpanInfo
-> [(Type, Ident)]
-> Equation Type
-> StateT SimplifyState Identity (Equation Type)
mergeEqns p1 :: SpanInfo
p1 vs :: [(Type, Ident)]
vs (Equation _ (FunLhs _ _ ts2 :: [Pattern Type]
ts2) (SimpleRhs p2 :: SpanInfo
p2 e :: Expression Type
e _))
    = SpanInfo -> Lhs Type -> Rhs Type -> Equation Type
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p1 Lhs Type
lhs (Rhs Type -> Equation Type)
-> StateT SimplifyState Identity (Rhs Type)
-> StateT SimplifyState Identity (Equation Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InlineEnv -> Rhs Type -> StateT SimplifyState Identity (Rhs Type)
simRhs InlineEnv
env (SpanInfo -> Expression Type -> Rhs Type
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p2 (SpanInfo -> [Decl Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
NoSpanInfo [Decl Type]
ds Expression Type
e))
      where
      ds :: [Decl Type]
ds = (Pattern Type -> (Type, Ident) -> Decl Type)
-> [Pattern Type] -> [(Type, Ident)] -> [Decl Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\t :: Pattern Type
t v :: (Type, Ident)
v -> SpanInfo -> Pattern Type -> Rhs Type -> Decl Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
NoSpanInfo Pattern Type
t (SpanInfo -> Expression Type -> Rhs Type
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p2 ((Type -> Ident -> Expression Type)
-> (Type, Ident) -> Expression Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> Expression Type
forall a. a -> Ident -> Expression a
mkVar (Type, Ident)
v)))
                   [Pattern Type]
ts2
                   [(Type, Ident)]
vs
  mergeEqns _ _ _ = String -> StateT SimplifyState Identity (Equation Type)
forall a. HasCallStack => String -> a
error "Simplify.inlineFun.mergeEqns: no pattern match"

-- -----------------------------------------------------------------------------
-- Simplification of Expressions
-- -----------------------------------------------------------------------------

-- Variables that are bound to (simple) constants and aliases to other
-- variables are substituted. In terms of conventional compiler technology,
-- these optimizations correspond to constant propagation and copy propagation,
-- respectively. The transformation is applied recursively to a substituted
-- variable in order to handle chains of variable definitions.

-- Applications of let-expressions and case-expressions to other expressions
-- are simplified according to the following rules:
--   (let ds in e_1)            e_2 -> let ds in (e1 e2)
--   (case e_1 of p'_n -> e'_n) e_2 -> case e_1 of p'_n -> (e'n e_2)

-- The bindings of a let expression are sorted topologically in
-- order to split them into minimal binding groups. In addition,
-- local declarations occurring on the right hand side of a pattern
-- declaration are lifted into the enclosing binding group using the
-- equivalence (modulo alpha-conversion) of 'let x = let ds in e_1 in e_2'
-- and 'let ds; x = e_1 in e_2'.
-- This transformation avoids the creation of some redundant lifted
-- functions in later phases of the compiler.

simExpr :: InlineEnv -> Expression Type -> SIM (Expression Type)
simExpr :: InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr _   l :: Expression Type
l@(Literal     _ _ _) = Expression Type -> StateT SimplifyState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression Type
l
simExpr _   c :: Expression Type
c@(Constructor _ _ _) = Expression Type -> StateT SimplifyState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression Type
c
-- subsitution of variables
simExpr env :: InlineEnv
env v :: Expression Type
v@(Variable   _ ty :: Type
ty x :: QualIdent
x)
  | QualIdent -> Bool
isQualified QualIdent
x = Expression Type -> StateT SimplifyState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression Type
v
  | Bool
otherwise     =
    StateT SimplifyState Identity (Expression Type)
-> (Expression Type
    -> StateT SimplifyState Identity (Expression Type))
-> Maybe (Expression Type)
-> StateT SimplifyState Identity (Expression Type)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Expression Type -> StateT SimplifyState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression Type
v) (InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env (Expression Type
 -> StateT SimplifyState Identity (Expression Type))
-> (Expression Type -> Expression Type)
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Expression Type -> Expression Type
forall (f :: * -> *).
(Functor f, Typeable (f Type)) =>
Type -> f Type -> f Type
withType Type
ty) (Ident -> InlineEnv -> Maybe (Expression Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (QualIdent -> Ident
unqualify QualIdent
x) InlineEnv
env)
-- simplification of application
simExpr env :: InlineEnv
env (Apply       _ e1 :: Expression Type
e1 e2 :: Expression Type
e2) = case Expression Type
e1 of
  Let _ ds :: [Decl Type]
ds e' :: Expression Type
e'     -> InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env (SpanInfo -> [Decl Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
NoSpanInfo [Decl Type]
ds (SpanInfo -> Expression Type -> Expression Type -> Expression Type
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo Expression Type
e' Expression Type
e2))
  Case _ ct :: CaseType
ct e' :: Expression Type
e' bs :: [Alt Type]
bs -> InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env (SpanInfo
-> CaseType -> Expression Type -> [Alt Type] -> Expression Type
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
NoSpanInfo CaseType
ct Expression Type
e' ((Alt Type -> Alt Type) -> [Alt Type] -> [Alt Type]
forall a b. (a -> b) -> [a] -> [b]
map (Expression Type -> Alt Type -> Alt Type
forall a. Expression a -> Alt a -> Alt a
applyToAlt Expression Type
e2) [Alt Type]
bs))
  _               -> SpanInfo -> Expression Type -> Expression Type -> Expression Type
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Expression Type -> Expression Type -> Expression Type)
-> StateT SimplifyState Identity (Expression Type)
-> StateT
     SimplifyState Identity (Expression Type -> Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env Expression Type
e1 StateT SimplifyState Identity (Expression Type -> Expression Type)
-> StateT SimplifyState Identity (Expression Type)
-> StateT SimplifyState Identity (Expression Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env Expression Type
e2
  where
  applyToAlt :: Expression a -> Alt a -> Alt a
applyToAlt e :: Expression a
e (Alt        p :: SpanInfo
p t :: Pattern a
t rhs :: Rhs a
rhs) = SpanInfo -> Pattern a -> Rhs a -> Alt a
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern a
t (Expression a -> Rhs a -> Rhs a
forall a. Expression a -> Rhs a -> Rhs a
applyToRhs Expression a
e Rhs a
rhs)
  applyToRhs :: Expression a -> Rhs a -> Rhs a
applyToRhs e :: Expression a
e (SimpleRhs  p :: SpanInfo
p e1' :: Expression a
e1' _) = SpanInfo -> Expression a -> Rhs a
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p (SpanInfo -> Expression a -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo Expression a
e1' Expression a
e)
  applyToRhs _ (GuardedRhs   _ _ _) = String -> Rhs a
forall a. HasCallStack => String -> a
error "Simplify.simExpr.applyRhs: Guarded rhs"
-- simplification of declarations
simExpr env :: InlineEnv
env (Let          _ ds :: [Decl Type]
ds e :: Expression Type
e) = do
  ModuleIdent
m   <- SIM ModuleIdent
getModuleIdent
  [[Decl Type]]
dss <- (Decl Type -> StateT SimplifyState Identity [Decl Type])
-> [Decl Type] -> StateT SimplifyState Identity [[Decl Type]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl Type -> StateT SimplifyState Identity [Decl Type]
sharePatternRhs [Decl Type]
ds
  InlineEnv
-> [[Decl Type]]
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simplifyLet InlineEnv
env ((Decl Type -> [Ident])
-> (Decl Type -> [Ident]) -> [Decl Type] -> [[Decl Type]]
forall b a. Eq b => (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc Decl Type -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv (ModuleIdent -> Decl Type -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m) ((Decl Type -> [Decl Type] -> [Decl Type])
-> [Decl Type] -> [Decl Type] -> [Decl Type]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl Type -> [Decl Type] -> [Decl Type]
forall a. Decl a -> [Decl a] -> [Decl a]
hoistDecls [] ([[Decl Type]] -> [Decl Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Decl Type]]
dss))) Expression Type
e
simExpr env :: InlineEnv
env (Case      _ ct :: CaseType
ct e :: Expression Type
e bs :: [Alt Type]
bs) =
  SpanInfo
-> CaseType -> Expression Type -> [Alt Type] -> Expression Type
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
NoSpanInfo CaseType
ct (Expression Type -> [Alt Type] -> Expression Type)
-> StateT SimplifyState Identity (Expression Type)
-> StateT SimplifyState Identity ([Alt Type] -> Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env Expression Type
e StateT SimplifyState Identity ([Alt Type] -> Expression Type)
-> StateT SimplifyState Identity [Alt Type]
-> StateT SimplifyState Identity (Expression Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt Type -> StateT SimplifyState Identity (Alt Type))
-> [Alt Type] -> StateT SimplifyState Identity [Alt Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InlineEnv -> Alt Type -> StateT SimplifyState Identity (Alt Type)
simplifyAlt InlineEnv
env) [Alt Type]
bs
simExpr env :: InlineEnv
env (Typed       _ e :: Expression Type
e qty :: QualTypeExpr
qty) =
  (Expression Type -> QualTypeExpr -> Expression Type)
-> QualTypeExpr -> Expression Type -> Expression Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression Type -> QualTypeExpr -> Expression Type
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
NoSpanInfo) QualTypeExpr
qty (Expression Type -> Expression Type)
-> StateT SimplifyState Identity (Expression Type)
-> StateT SimplifyState Identity (Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env Expression Type
e
simExpr _   _                     = String -> StateT SimplifyState Identity (Expression Type)
forall a. HasCallStack => String -> a
error "Simplify.simExpr: no pattern match"

-- Simplify a case alternative
simplifyAlt :: InlineEnv -> Alt Type -> SIM (Alt Type)
simplifyAlt :: InlineEnv -> Alt Type -> StateT SimplifyState Identity (Alt Type)
simplifyAlt env :: InlineEnv
env (Alt p :: SpanInfo
p t :: Pattern Type
t rhs :: Rhs Type
rhs) = SpanInfo -> Pattern Type -> Rhs Type -> Alt Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern Type
t (Rhs Type -> Alt Type)
-> StateT SimplifyState Identity (Rhs Type)
-> StateT SimplifyState Identity (Alt Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InlineEnv -> Rhs Type -> StateT SimplifyState Identity (Rhs Type)
simRhs InlineEnv
env Rhs Type
rhs

-- Transform a pattern declaration @t = e@ into two declarations
-- @t = v, v = e@ whenever @t@ is not a variable. This is used to share
-- the expression @e@ using the fresh variable @v@.
sharePatternRhs :: Decl Type -> SIM [Decl Type]
--TODO: change to patterns instead of case
sharePatternRhs :: Decl Type -> StateT SimplifyState Identity [Decl Type]
sharePatternRhs (PatternDecl p :: SpanInfo
p t :: Pattern Type
t rhs :: Rhs Type
rhs) = case Pattern Type
t of
  VariablePattern _ _ _ -> [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [SpanInfo -> Pattern Type -> Rhs Type -> Decl Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern Type
t Rhs Type
rhs]
  _                     -> do
    let ty :: Type
ty = Pattern Type -> Type
forall a. Typeable a => a -> Type
typeOf Pattern Type
t
    Ident
v  <- (Int -> Ident) -> SIM Ident
freshIdent Int -> Ident
forall a. Show a => a -> Ident
patternId
    [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [ SpanInfo -> Pattern Type -> Rhs Type -> Decl Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern Type
t                      (SpanInfo -> Expression Type -> Rhs Type
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p (Type -> Ident -> Expression Type
forall a. a -> Ident -> Expression a
mkVar Type
ty Ident
v))
           , SpanInfo -> Pattern Type -> Rhs Type -> Decl Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p (SpanInfo -> Type -> Ident -> Pattern Type
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo Type
ty Ident
v) Rhs Type
rhs
           ]
  where patternId :: a -> Ident
patternId n :: a
n = String -> Ident
mkIdent ("_#pat" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n)
sharePatternRhs d :: Decl Type
d                     = [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl Type
d]

-- Lift up nested let declarations in pattern declarations, i.e., replace
-- @let p = let ds' in e'; ds in e@ by @let ds'; p = e'; ds in e@.
hoistDecls :: Decl a -> [Decl a] -> [Decl a]
hoistDecls :: Decl a -> [Decl a] -> [Decl a]
hoistDecls (PatternDecl p :: SpanInfo
p t :: Pattern a
t (SimpleRhs p' :: SpanInfo
p' (Let NoSpanInfo ds' :: [Decl a]
ds' e :: Expression a
e) _)) ds :: [Decl a]
ds
 = (Decl a -> [Decl a] -> [Decl a])
-> [Decl a] -> [Decl a] -> [Decl a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl a -> [Decl a] -> [Decl a]
forall a. Decl a -> [Decl a] -> [Decl a]
hoistDecls [Decl a]
ds (SpanInfo -> Pattern a -> Rhs a -> Decl a
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern a
t (SpanInfo -> Expression a -> Rhs a
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p' Expression a
e) Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a]
ds')
hoistDecls d :: Decl a
d ds :: [Decl a]
ds = Decl a
d Decl a -> [Decl a] -> [Decl a]
forall a. a -> [a] -> [a]
: [Decl a]
ds

-- The declaration groups of a let expression are first processed from
-- outside to inside, simplifying the right hand sides and collecting
-- inlineable expressions on the fly. At present, only simple constants
-- and aliases to other variables are inlined. A constant is considered
-- simple if it is either a literal, a constructor, or a non-nullary
-- function. Note that it is not possible to define nullary functions in
-- local declarations in Curry. Thus, an unqualified name always refers
-- to either a variable or a non-nullary function. Applications of
-- constructors and partial applications of functions to at least one
-- argument are not inlined because the compiler has to allocate space
-- for them, anyway. In order to prevent non-termination, recursive
-- binding groups are not processed for inlining.

-- With the list of inlineable expressions, the body of the let is
-- simplified and then the declaration groups are processed from inside
-- to outside to construct the simplified, nested let expression. In
-- doing so, unused bindings are discarded. In addition, all pattern
-- bindings are replaced by simple variable declarations using selector
-- functions to access the pattern variables.

simplifyLet :: InlineEnv -> [[Decl Type]] -> Expression Type
            -> SIM (Expression Type)
simplifyLet :: InlineEnv
-> [[Decl Type]]
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simplifyLet env :: InlineEnv
env []       e :: Expression Type
e = InlineEnv
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simExpr InlineEnv
env Expression Type
e
simplifyLet env :: InlineEnv
env (ds :: [Decl Type]
ds:dss :: [[Decl Type]]
dss) e :: Expression Type
e = do
  ModuleIdent
m     <- SIM ModuleIdent
getModuleIdent
  [Decl Type]
ds'   <- (Decl Type -> StateT SimplifyState Identity (Decl Type))
-> [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InlineEnv -> Decl Type -> StateT SimplifyState Identity (Decl Type)
simDecl InlineEnv
env) [Decl Type]
ds  -- simplify declarations
  InlineEnv
env'  <- InlineEnv -> [Decl Type] -> SIM InlineEnv
inlineVars InlineEnv
env [Decl Type]
ds'     -- inline a simple variable binding
  Expression Type
e'    <- InlineEnv
-> [[Decl Type]]
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simplifyLet InlineEnv
env' [[Decl Type]]
dss Expression Type
e -- simplify remaining bindings
  [Decl Type]
ds''  <- (Decl Type -> StateT SimplifyState Identity [Decl Type])
-> [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ([Ident] -> Decl Type -> StateT SimplifyState Identity [Decl Type]
expandPatternBindings (ModuleIdent -> [Decl Type] -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m [Decl Type]
ds' [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ ModuleIdent -> Expression Type -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m Expression Type
e')) [Decl Type]
ds'
  Expression Type -> StateT SimplifyState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type
 -> StateT SimplifyState Identity (Expression Type))
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ ([Decl Type] -> Expression Type -> Expression Type)
-> Expression Type -> [[Decl Type]] -> Expression Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> [Decl Type] -> Expression Type -> Expression Type
mkLet' ModuleIdent
m) Expression Type
e' ((Decl Type -> [Ident])
-> (Decl Type -> [Ident]) -> [Decl Type] -> [[Decl Type]]
forall b a. Eq b => (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc Decl Type -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv (ModuleIdent -> Decl Type -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m) [Decl Type]
ds'')

inlineVars :: InlineEnv -> [Decl Type] -> SIM InlineEnv
inlineVars :: InlineEnv -> [Decl Type] -> SIM InlineEnv
inlineVars env :: InlineEnv
env ds :: [Decl Type]
ds = case [Decl Type]
ds of
  [PatternDecl _ (VariablePattern _ _ v :: Ident
v) (SimpleRhs _ e :: Expression Type
e _)] -> do
    Bool
allowed <- Ident -> Expression Type -> StateT SimplifyState Identity Bool
forall a.
Ident -> Expression a -> StateT SimplifyState Identity Bool
canInlineVar Ident
v Expression Type
e
    InlineEnv -> SIM InlineEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (InlineEnv -> SIM InlineEnv) -> InlineEnv -> SIM InlineEnv
forall a b. (a -> b) -> a -> b
$ if Bool
allowed then Ident -> Expression Type -> InlineEnv -> InlineEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
v Expression Type
e InlineEnv
env else InlineEnv
env
  _ -> InlineEnv -> SIM InlineEnv
forall (m :: * -> *) a. Monad m => a -> m a
return InlineEnv
env
  where
  canInlineVar :: Ident -> Expression a -> StateT SimplifyState Identity Bool
canInlineVar _ (Literal     _ _ _) = Bool -> StateT SimplifyState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  canInlineVar _ (Constructor _ _ _) = Bool -> StateT SimplifyState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  canInlineVar v :: Ident
v (Variable   _ _ v' :: QualIdent
v')
    | QualIdent -> Bool
isQualified QualIdent
v'             = (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Int -> Bool) -> SIM Int -> StateT SimplifyState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> SIM Int
getFunArity QualIdent
v'
    | Bool
otherwise                  = Bool -> StateT SimplifyState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> StateT SimplifyState Identity Bool)
-> Bool -> StateT SimplifyState Identity Bool
forall a b. (a -> b) -> a -> b
$ Ident
v Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
/= QualIdent -> Ident
unqualify QualIdent
v'
  canInlineVar _ _               = Bool -> StateT SimplifyState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

mkLet' :: ModuleIdent -> [Decl Type] -> Expression Type -> Expression Type
mkLet' :: ModuleIdent -> [Decl Type] -> Expression Type -> Expression Type
mkLet' m :: ModuleIdent
m [FreeDecl p :: SpanInfo
p vs :: [Var Type]
vs] e :: Expression Type
e
  | [Var Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var Type]
vs'  = Expression Type
e
  | Bool
otherwise = SpanInfo -> [Decl Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
NoSpanInfo [SpanInfo -> [Var Type] -> Decl Type
forall a. SpanInfo -> [Var a] -> Decl a
FreeDecl SpanInfo
p [Var Type]
vs'] Expression Type
e -- remove unused free variables
  where vs' :: [Var Type]
vs' = (Var Type -> Bool) -> [Var Type] -> [Var Type]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ModuleIdent -> Expression Type -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m Expression Type
e) (Ident -> Bool) -> (Var Type -> Ident) -> Var Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var Type -> Ident
forall a. Var a -> Ident
varIdent) [Var Type]
vs
mkLet' m :: ModuleIdent
m [PatternDecl _ (VariablePattern _ ty :: Type
ty v :: Ident
v) (SimpleRhs _ e :: Expression Type
e _)] (Variable _ _ v' :: QualIdent
v')
  | QualIdent
v' QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== Ident -> QualIdent
qualify Ident
v Bool -> Bool -> Bool
&& Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ModuleIdent -> Expression Type -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m Expression Type
e = Type -> Expression Type -> Expression Type
forall (f :: * -> *).
(Functor f, Typeable (f Type)) =>
Type -> f Type -> f Type
withType Type
ty Expression Type
e -- inline single binding
mkLet' m :: ModuleIdent
m ds :: [Decl Type]
ds e :: Expression Type
e
  | Bool -> Bool
not ((Ident -> Bool) -> [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ModuleIdent -> Expression Type -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m Expression Type
e) ([Decl Type] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Decl Type]
ds)) = Expression Type
e -- removed unused bindings
  | Bool
otherwise                              = SpanInfo -> [Decl Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
NoSpanInfo [Decl Type]
ds Expression Type
e

-- In order to implement lazy pattern matching in local declarations,
-- pattern declarations 't = e' where 't' is not a variable
-- are transformed into a list of declarations
-- 'v_0 = e; v_1 = f_1 v_0; ...; v_n = f_n v_0' where 'v_0' is a fresh
-- variable, 'v_1,...,v_n' are the variables occurring in 't' and the
-- auxiliary functions 'f_i' are defined by 'f_i t = v_i' (see also
-- appendix D.8 of the Curry report). The bindings 'v_0 = e' are introduced
-- before splitting the declaration groups of the enclosing let expression
-- (cf. the 'Let' case in 'simExpr' above) so that they are placed in their own
-- declaration group whenever possible. In particular, this ensures that
-- the new binding is discarded when the expression 'e' is itself a variable.

-- fvs contains all variables used in the declarations and the body
-- of the let expression.
expandPatternBindings :: [Ident] -> Decl Type -> SIM [Decl Type]
expandPatternBindings :: [Ident] -> Decl Type -> StateT SimplifyState Identity [Decl Type]
expandPatternBindings fvs :: [Ident]
fvs d :: Decl Type
d@(PatternDecl p :: SpanInfo
p t :: Pattern Type
t (SimpleRhs _ e :: Expression Type
e _)) = case Pattern Type
t of
  VariablePattern _ _ _ -> [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl Type
d]
  _                     ->
    -- used variables
    ((Ident, Int, Type) -> StateT SimplifyState Identity (Decl Type))
-> [(Ident, Int, Type)]
-> StateT SimplifyState Identity [Decl Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Ident, Int, Type) -> StateT SimplifyState Identity (Decl Type)
forall b.
(Ident, b, Type) -> StateT SimplifyState Identity (Decl Type)
mkSelectorDecl (((Ident, Int, Type) -> Bool)
-> [(Ident, Int, Type)] -> [(Ident, Int, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
fvs) (Ident -> Bool)
-> ((Ident, Int, Type) -> Ident) -> (Ident, Int, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, Int, Type) -> Ident
forall a b c. (a, b, c) -> a
fst3) (Pattern Type -> [(Ident, Int, Type)]
forall t.
(Eq t, Typeable t, ValueType t) =>
Pattern t -> [(Ident, Int, t)]
patternVars Pattern Type
t))
  where
    pty :: Type
pty = Pattern Type -> Type
forall a. Typeable a => a -> Type
typeOf Pattern Type
t -- type of patternNoSpaNoSpanInfonInfo
    mkSelectorDecl :: (Ident, b, Type) -> StateT SimplifyState Identity (Decl Type)
mkSelectorDecl (v :: Ident
v, _, vty :: Type
vty) = do
      let fty :: Type
fty = Type -> Type -> Type
TypeArrow Type
pty Type
vty
      Ident
f <- (Int -> Ident) -> SIM Ident
freshIdent ((String -> String) -> Ident -> Ident
updIdentName (String -> String -> String
forall a. [a] -> [a] -> [a]
++ '#' Char -> String -> String
forall a. a -> [a] -> [a]
: Ident -> String
idName Ident
v) (Ident -> Ident) -> (Int -> Ident) -> Int -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Ident
fpSelectorId)
      Decl Type -> StateT SimplifyState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT SimplifyState Identity (Decl Type))
-> Decl Type -> StateT SimplifyState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Type -> Ident -> Expression Type -> Decl Type
forall a. SpanInfo -> a -> Ident -> Expression a -> Decl a
varDecl SpanInfo
p Type
vty Ident
v (Expression Type -> Decl Type) -> Expression Type -> Decl Type
forall a b. (a -> b) -> a -> b
$
        SpanInfo -> [Decl Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
NoSpanInfo [SpanInfo
-> Type -> Ident -> [Pattern Type] -> Expression Type -> Decl Type
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
p Type
fty Ident
f [Pattern Type
t] (Type -> Ident -> Expression Type
forall a. a -> Ident -> Expression a
mkVar Type
vty Ident
v)]
        (SpanInfo -> Expression Type -> Expression Type -> Expression Type
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Type -> Ident -> Expression Type
forall a. a -> Ident -> Expression a
mkVar Type
fty Ident
f) Expression Type
e)
expandPatternBindings _ d :: Decl Type
d = [Decl Type] -> StateT SimplifyState Identity [Decl Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl Type
d]