{-# 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)
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)
data SimplifyState = SimplifyState
{ SimplifyState -> ModuleIdent
moduleIdent :: ModuleIdent
, SimplifyState -> ValueEnv
valueEnv :: ValueEnv
, SimplifyState -> Int
nextId :: Int
}
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
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
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"
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) _
|
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'
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
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')
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"
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
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)
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"
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"
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
sharePatternRhs :: Decl Type -> SIM [Decl Type]
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]
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
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
InlineEnv
env' <- InlineEnv -> [Decl Type] -> SIM InlineEnv
inlineVars InlineEnv
env [Decl Type]
ds'
Expression Type
e' <- InlineEnv
-> [[Decl Type]]
-> Expression Type
-> StateT SimplifyState Identity (Expression Type)
simplifyLet InlineEnv
env' [[Decl Type]]
dss Expression Type
e
[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
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
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
| 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
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]
_ ->
((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
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]