{-# LANGUAGE CPP #-}
module Transformations.Newtypes (removeNewtypes) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import qualified Control.Monad.Reader as R
import Curry.Base.Ident
import Curry.Syntax
import Base.Messages (internalError)
import Base.Types
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
removeNewtypes :: ValueEnv -> Module Type -> Module Type
removeNewtypes :: ValueEnv -> Module Type -> Module Type
removeNewtypes vEnv :: ValueEnv
vEnv mdl :: Module Type
mdl = Reader ValueEnv (Module Type) -> ValueEnv -> Module Type
forall r a. Reader r a -> r -> a
R.runReader (Module Type -> Reader ValueEnv (Module Type)
forall a. Newtypes a => a -> NTM a
nt Module Type
mdl) ValueEnv
vEnv
type NTM a = R.Reader ValueEnv a
class Show a => Newtypes a where
nt :: a -> NTM a
instance Newtypes a => Newtypes [a] where
nt :: [a] -> NTM [a]
nt = (a -> ReaderT ValueEnv Identity a) -> [a] -> NTM [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> ReaderT ValueEnv Identity a
forall a. Newtypes a => a -> NTM a
nt
instance Show a => Newtypes (Module a) where
nt :: Module a -> NTM (Module a)
nt (Module spi :: SpanInfo
spi ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl a]
ds) = SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
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 a] -> Module a)
-> ReaderT ValueEnv Identity [Decl a] -> NTM (Module a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl a -> ReaderT ValueEnv Identity (Decl a))
-> [Decl a] -> ReaderT ValueEnv Identity [Decl a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl a -> ReaderT ValueEnv Identity (Decl a)
forall a. Newtypes a => a -> NTM a
nt [Decl a]
ds
instance Show a => Newtypes (Decl a) where
nt :: Decl a -> NTM (Decl a)
nt d :: Decl a
d@(InfixDecl _ _ _ _) = Decl a -> NTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl a
d
nt d :: Decl a
d@(DataDecl _ _ _ _ _) = Decl a -> NTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl a
d
nt d :: Decl a
d@(ExternalDataDecl _ _ _) = Decl a -> NTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl a
d
nt (NewtypeDecl p :: SpanInfo
p tc :: Ident
tc vs :: [Ident]
vs nc :: NewConstrDecl
nc []) = Decl a -> NTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl a -> NTM (Decl a)) -> Decl a -> NTM (Decl a)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Ident -> [Ident] -> TypeExpr -> Decl a
forall a. SpanInfo -> Ident -> [Ident] -> TypeExpr -> Decl a
TypeDecl SpanInfo
p Ident
tc [Ident]
vs (TypeExpr -> Decl a) -> TypeExpr -> Decl a
forall a b. (a -> b) -> a -> b
$ NewConstrDecl -> TypeExpr
nconstrType NewConstrDecl
nc
nt d :: Decl a
d@(TypeDecl _ _ _ _) = Decl a -> NTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl a
d
nt (FunctionDecl p :: SpanInfo
p a :: a
a f :: Ident
f eqs :: [Equation a]
eqs) = SpanInfo -> a -> Ident -> [Equation a] -> Decl a
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p a
a Ident
f ([Equation a] -> Decl a)
-> ReaderT ValueEnv Identity [Equation a] -> NTM (Decl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Equation a] -> ReaderT ValueEnv Identity [Equation a]
forall a. Newtypes a => a -> NTM a
nt [Equation a]
eqs
nt d :: Decl a
d@(ExternalDecl _ _) = Decl a -> NTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl a
d
nt (PatternDecl p :: SpanInfo
p t :: Pattern a
t rhs :: Rhs a
rhs) = SpanInfo -> Pattern a -> Rhs a -> Decl a
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p (Pattern a -> Rhs a -> Decl a)
-> ReaderT ValueEnv Identity (Pattern a)
-> ReaderT ValueEnv Identity (Rhs a -> Decl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> ReaderT ValueEnv Identity (Pattern a)
forall a. Newtypes a => a -> NTM a
nt Pattern a
t ReaderT ValueEnv Identity (Rhs a -> Decl a)
-> ReaderT ValueEnv Identity (Rhs a) -> NTM (Decl a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs a -> ReaderT ValueEnv Identity (Rhs a)
forall a. Newtypes a => a -> NTM a
nt Rhs a
rhs
nt d :: Decl a
d@(FreeDecl _ _) = Decl a -> NTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl a
d
nt d :: Decl a
d = String -> NTM (Decl a)
forall a. String -> a
internalError (String -> NTM (Decl a)) -> String -> NTM (Decl a)
forall a b. (a -> b) -> a -> b
$
"Newtypes.Newtypes.nt: unexpected declaration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Decl a -> String
forall a. Show a => a -> String
show Decl a
d
instance Show a => Newtypes (Equation a) where
nt :: Equation a -> NTM (Equation a)
nt (Equation p :: SpanInfo
p lhs :: Lhs a
lhs rhs :: Rhs a
rhs) = SpanInfo -> Lhs a -> Rhs a -> Equation a
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p (Lhs a -> Rhs a -> Equation a)
-> ReaderT ValueEnv Identity (Lhs a)
-> ReaderT ValueEnv Identity (Rhs a -> Equation a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lhs a -> ReaderT ValueEnv Identity (Lhs a)
forall a. Newtypes a => a -> NTM a
nt Lhs a
lhs ReaderT ValueEnv Identity (Rhs a -> Equation a)
-> ReaderT ValueEnv Identity (Rhs a) -> NTM (Equation a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs a -> ReaderT ValueEnv Identity (Rhs a)
forall a. Newtypes a => a -> NTM a
nt Rhs a
rhs
instance Show a => Newtypes (Lhs a) where
nt :: Lhs a -> NTM (Lhs a)
nt (FunLhs spi :: SpanInfo
spi f :: Ident
f ts :: [Pattern a]
ts) = SpanInfo -> Ident -> [Pattern a] -> Lhs a
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f ([Pattern a] -> Lhs a)
-> ReaderT ValueEnv Identity [Pattern a] -> NTM (Lhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern a] -> ReaderT ValueEnv Identity [Pattern a]
forall a. Newtypes a => a -> NTM a
nt [Pattern a]
ts
nt lhs :: Lhs a
lhs = String -> NTM (Lhs a)
forall a. String -> a
internalError (String -> NTM (Lhs a)) -> String -> NTM (Lhs a)
forall a b. (a -> b) -> a -> b
$
"Newtypes.Newtypes.nt: unexpected left-hand-side: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Lhs a -> String
forall a. Show a => a -> String
show Lhs a
lhs
instance Show a => Newtypes (Rhs a) where
nt :: Rhs a -> NTM (Rhs a)
nt (SimpleRhs p :: SpanInfo
p e :: Expression a
e []) = (Expression a -> [Decl a] -> Rhs a)
-> [Decl a] -> Expression a -> Rhs a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression a -> [Decl a] -> Rhs a
forall a. SpanInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
p) [] (Expression a -> Rhs a)
-> ReaderT ValueEnv Identity (Expression a) -> NTM (Rhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> ReaderT ValueEnv Identity (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e
nt rhs :: Rhs a
rhs = String -> NTM (Rhs a)
forall a. String -> a
internalError (String -> NTM (Rhs a)) -> String -> NTM (Rhs a)
forall a b. (a -> b) -> a -> b
$
"Newtypes.Newtypes.nt: unexpected right-hand-side: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rhs a -> String
forall a. Show a => a -> String
show Rhs a
rhs
instance Show a => Newtypes (Pattern a) where
nt :: Pattern a -> NTM (Pattern a)
nt t :: Pattern a
t@(LiteralPattern _ _ _) = Pattern a -> NTM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t
nt t :: Pattern a
t@(VariablePattern _ _ _) = Pattern a -> NTM (Pattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern a
t
nt (ConstructorPattern spi :: SpanInfo
spi a :: a
a c :: QualIdent
c ts :: [Pattern a]
ts) = case [Pattern a]
ts of
[t :: Pattern a
t] -> do
Bool
isNc <- QualIdent -> NTM Bool
isNewtypeConstr QualIdent
c
if Bool
isNc then Pattern a -> NTM (Pattern a)
forall a. Newtypes a => a -> NTM a
nt Pattern a
t
else SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi a
a QualIdent
c ([Pattern a] -> Pattern a)
-> ReaderT ValueEnv Identity [Pattern a] -> NTM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Pattern a -> [Pattern a] -> [Pattern a]
forall a. a -> [a] -> [a]
: []) (Pattern a -> [Pattern a])
-> NTM (Pattern a) -> ReaderT ValueEnv Identity [Pattern a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> NTM (Pattern a)
forall a. Newtypes a => a -> NTM a
nt Pattern a
t)
_ -> SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
spi a
a QualIdent
c ([Pattern a] -> Pattern a)
-> ReaderT ValueEnv Identity [Pattern a] -> NTM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> NTM (Pattern a))
-> [Pattern a] -> ReaderT ValueEnv Identity [Pattern a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> NTM (Pattern a)
forall a. Newtypes a => a -> NTM a
nt [Pattern a]
ts
nt (AsPattern spi :: SpanInfo
spi v :: Ident
v t :: Pattern a
t) = SpanInfo -> Ident -> Pattern a -> Pattern a
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
spi Ident
v (Pattern a -> Pattern a) -> NTM (Pattern a) -> NTM (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> NTM (Pattern a)
forall a. Newtypes a => a -> NTM a
nt Pattern a
t
nt t :: Pattern a
t = String -> NTM (Pattern a)
forall a. String -> a
internalError (String -> NTM (Pattern a)) -> String -> NTM (Pattern a)
forall a b. (a -> b) -> a -> b
$
"Newtypes.Newtypes.nt: unexpected pattern: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern a -> String
forall a. Show a => a -> String
show Pattern a
t
instance Show a => Newtypes (Expression a) where
nt :: Expression a -> NTM (Expression a)
nt e :: Expression a
e@(Literal _ _ _) = Expression a -> NTM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression a
e
nt e :: Expression a
e@(Variable _ _ _) = Expression a -> NTM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression a
e
nt (Constructor spi :: SpanInfo
spi a :: a
a c :: QualIdent
c) = do
Bool
isNc <- QualIdent -> NTM Bool
isNewtypeConstr QualIdent
c
Expression a -> NTM (Expression a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression a -> NTM (Expression a))
-> Expression a -> NTM (Expression a)
forall a b. (a -> b) -> a -> b
$ if Bool
isNc then SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
spi a
a QualIdent
qIdId else SpanInfo -> a -> QualIdent -> Expression a
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
spi a
a QualIdent
c
nt (Apply spi :: SpanInfo
spi e1 :: Expression a
e1 e2 :: Expression a
e2) = case Expression a
e1 of
Constructor _ _ c :: QualIdent
c -> do
Bool
isNc <- QualIdent -> NTM Bool
isNewtypeConstr QualIdent
c
if Bool
isNc then Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e2 else SpanInfo -> Expression a -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
spi (Expression a -> Expression a -> Expression a)
-> NTM (Expression a)
-> ReaderT ValueEnv Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e1 ReaderT ValueEnv Identity (Expression a -> Expression a)
-> NTM (Expression a) -> NTM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e2
_ -> SpanInfo -> Expression a -> Expression a -> Expression a
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
spi (Expression a -> Expression a -> Expression a)
-> NTM (Expression a)
-> ReaderT ValueEnv Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e1 ReaderT ValueEnv Identity (Expression a -> Expression a)
-> NTM (Expression a) -> NTM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e2
nt (Case spi :: SpanInfo
spi ct :: CaseType
ct e :: Expression a
e as :: [Alt a]
as) = SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
spi CaseType
ct (Expression a -> [Alt a] -> Expression a)
-> NTM (Expression a)
-> ReaderT ValueEnv Identity ([Alt a] -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e ReaderT ValueEnv Identity ([Alt a] -> Expression a)
-> ReaderT ValueEnv Identity [Alt a] -> NTM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt a -> ReaderT ValueEnv Identity (Alt a))
-> [Alt a] -> ReaderT ValueEnv Identity [Alt a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt a -> ReaderT ValueEnv Identity (Alt a)
forall a. Newtypes a => a -> NTM a
nt [Alt a]
as
nt (Let spi :: SpanInfo
spi ds :: [Decl a]
ds e :: Expression a
e) = SpanInfo -> [Decl a] -> Expression a -> Expression a
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi ([Decl a] -> Expression a -> Expression a)
-> ReaderT ValueEnv Identity [Decl a]
-> ReaderT ValueEnv Identity (Expression a -> Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl a] -> ReaderT ValueEnv Identity [Decl a]
forall a. Newtypes a => a -> NTM a
nt [Decl a]
ds ReaderT ValueEnv Identity (Expression a -> Expression a)
-> NTM (Expression a) -> NTM (Expression a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e
nt (Typed spi :: SpanInfo
spi e :: Expression a
e qty :: QualTypeExpr
qty) = (Expression a -> QualTypeExpr -> Expression a)
-> QualTypeExpr -> Expression a -> Expression a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo -> Expression a -> QualTypeExpr -> Expression a
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
spi) QualTypeExpr
qty (Expression a -> Expression a)
-> NTM (Expression a) -> NTM (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> NTM (Expression a)
forall a. Newtypes a => a -> NTM a
nt Expression a
e
nt e :: Expression a
e = String -> NTM (Expression a)
forall a. String -> a
internalError (String -> NTM (Expression a)) -> String -> NTM (Expression a)
forall a b. (a -> b) -> a -> b
$
"Newtypes.Newtypes.nt: unexpected expression: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression a -> String
forall a. Show a => a -> String
show Expression a
e
instance Show a => Newtypes (Alt a) where
nt :: Alt a -> NTM (Alt a)
nt (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 -> Rhs a -> Alt a)
-> ReaderT ValueEnv Identity (Pattern a)
-> ReaderT ValueEnv Identity (Rhs a -> Alt a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> ReaderT ValueEnv Identity (Pattern a)
forall a. Newtypes a => a -> NTM a
nt Pattern a
t ReaderT ValueEnv Identity (Rhs a -> Alt a)
-> ReaderT ValueEnv Identity (Rhs a) -> NTM (Alt a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs a -> ReaderT ValueEnv Identity (Rhs a)
forall a. Newtypes a => a -> NTM a
nt Rhs a
rhs
isNewtypeConstr :: QualIdent -> NTM Bool
isNewtypeConstr :: QualIdent -> NTM Bool
isNewtypeConstr c :: QualIdent
c = ReaderT ValueEnv Identity ValueEnv
forall r (m :: * -> *). MonadReader r m => m r
R.ask ReaderT ValueEnv Identity ValueEnv
-> (ValueEnv -> NTM Bool) -> NTM Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \vEnv :: ValueEnv
vEnv -> Bool -> NTM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> NTM Bool) -> Bool -> NTM Bool
forall a b. (a -> b) -> a -> b
$
case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
c ValueEnv
vEnv of
[NewtypeConstructor _ _ _] -> Bool
True
[DataConstructor _ _ _ _] -> Bool
False
_ -> String -> Bool
forall a. String -> a
internalError (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ "Newtypes.isNewtypeConstr: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c