{-# LANGUAGE CPP #-}
module Transformations.CurryToIL (ilTrans, transType) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Monad.Extra (concatMapM)
import qualified Control.Monad.Reader as R
import qualified Control.Monad.State as S
import Data.List (nub, partition)
import Data.Maybe (fromJust)
import qualified Data.Map as Map
import qualified Data.Set as Set (Set, empty, insert, delete, toList)
import Curry.Base.Ident
import Curry.Syntax hiding (caseAlt)
import Base.Expr
import Base.Messages (internalError)
import Base.Types hiding (polyType)
import Base.Kinds
import Base.Typing
import Base.Utils (foldr2)
import Env.TypeConstructor
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import qualified IL as IL
ilTrans :: Bool -> ValueEnv -> TCEnv -> Module Type -> IL.Module
ilTrans :: Bool -> ValueEnv -> TCEnv -> Module Type -> Module
ilTrans remIm :: Bool
remIm vEnv :: ValueEnv
vEnv tcEnv :: TCEnv
tcEnv (Module _ _ _ m :: ModuleIdent
m _ im :: [ImportDecl]
im ds :: [Decl Type]
ds) = ModuleIdent -> [ModuleIdent] -> [Decl] -> Module
IL.Module ModuleIdent
m [ModuleIdent]
im' [Decl]
ds'
where ds' :: [Decl]
ds' = Reader TransEnv [Decl] -> TransEnv -> [Decl]
forall r a. Reader r a -> r -> a
R.runReader ((Decl Type -> Reader TransEnv [Decl])
-> [Decl Type] -> Reader TransEnv [Decl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl Type -> Reader TransEnv [Decl]
trDecl [Decl Type]
ds) (ModuleIdent -> ValueEnv -> TCEnv -> TransEnv
TransEnv ModuleIdent
m ValueEnv
vEnv TCEnv
tcEnv)
im' :: [ModuleIdent]
im' = ModuleIdent
preludeMIdent ModuleIdent -> [ModuleIdent] -> [ModuleIdent]
forall a. a -> [a] -> [a]
: if Bool
remIm then ModuleIdent -> [Decl] -> [ModuleIdent]
imports ModuleIdent
m [Decl]
ds' else (ImportDecl -> ModuleIdent) -> [ImportDecl] -> [ModuleIdent]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl -> ModuleIdent
moduleImport [ImportDecl]
im
moduleImport :: ImportDecl -> ModuleIdent
moduleImport (ImportDecl _ mdl :: ModuleIdent
mdl _ _ _) = ModuleIdent
mdl
imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]
imports :: ModuleIdent -> [Decl] -> [ModuleIdent]
imports m :: ModuleIdent
m = Set ModuleIdent -> [ModuleIdent]
forall a. Set a -> [a]
Set.toList (Set ModuleIdent -> [ModuleIdent])
-> ([Decl] -> Set ModuleIdent) -> [Decl] -> [ModuleIdent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Set ModuleIdent -> Set ModuleIdent
forall a. Ord a => a -> Set a -> Set a
Set.delete ModuleIdent
m (Set ModuleIdent -> Set ModuleIdent)
-> ([Decl] -> Set ModuleIdent) -> [Decl] -> Set ModuleIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Decl -> Set ModuleIdent -> Set ModuleIdent)
-> Set ModuleIdent -> [Decl] -> Set ModuleIdent
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl -> Set ModuleIdent -> Set ModuleIdent
mdlsDecl Set ModuleIdent
forall a. Set a
Set.empty
mdlsDecl :: IL.Decl -> Set.Set ModuleIdent -> Set.Set ModuleIdent
mdlsDecl :: Decl -> Set ModuleIdent -> Set ModuleIdent
mdlsDecl (IL.DataDecl _ _ cs :: [ConstrDecl]
cs) ms :: Set ModuleIdent
ms = (ConstrDecl -> Set ModuleIdent -> Set ModuleIdent)
-> Set ModuleIdent -> [ConstrDecl] -> Set ModuleIdent
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ConstrDecl -> Set ModuleIdent -> Set ModuleIdent
mdlsConstrsDecl Set ModuleIdent
ms [ConstrDecl]
cs
where mdlsConstrsDecl :: ConstrDecl -> Set ModuleIdent -> Set ModuleIdent
mdlsConstrsDecl (IL.ConstrDecl _ tys :: [Type]
tys) ms' :: Set ModuleIdent
ms' = (Type -> Set ModuleIdent -> Set ModuleIdent)
-> Set ModuleIdent -> [Type] -> Set ModuleIdent
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Set ModuleIdent
ms' [Type]
tys
mdlsDecl (IL.NewtypeDecl _ _ nc :: NewConstrDecl
nc) ms :: Set ModuleIdent
ms = NewConstrDecl -> Set ModuleIdent
mdlsNewConstrDecl NewConstrDecl
nc
where mdlsNewConstrDecl :: NewConstrDecl -> Set ModuleIdent
mdlsNewConstrDecl (IL.NewConstrDecl _ ty :: Type
ty) = Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Type
ty Set ModuleIdent
ms
mdlsDecl (IL.ExternalDataDecl _ _) ms :: Set ModuleIdent
ms = Set ModuleIdent
ms
mdlsDecl (IL.FunctionDecl _ _ ty :: Type
ty e :: Expression
e) ms :: Set ModuleIdent
ms = Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Type
ty (Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e Set ModuleIdent
ms)
mdlsDecl (IL.ExternalDecl _ _ ty :: Type
ty) ms :: Set ModuleIdent
ms = Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Type
ty Set ModuleIdent
ms
mdlsType :: IL.Type -> Set.Set ModuleIdent -> Set.Set ModuleIdent
mdlsType :: Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType (IL.TypeConstructor tc :: QualIdent
tc tys :: [Type]
tys) ms :: Set ModuleIdent
ms = QualIdent -> Set ModuleIdent -> Set ModuleIdent
modules QualIdent
tc ((Type -> Set ModuleIdent -> Set ModuleIdent)
-> Set ModuleIdent -> [Type] -> Set ModuleIdent
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Set ModuleIdent
ms [Type]
tys)
mdlsType (IL.TypeVariable _) ms :: Set ModuleIdent
ms = Set ModuleIdent
ms
mdlsType (IL.TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2) ms :: Set ModuleIdent
ms = Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Type
ty1 (Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Type
ty2 Set ModuleIdent
ms)
mdlsType (IL.TypeForall _ ty :: Type
ty) ms :: Set ModuleIdent
ms = Type -> Set ModuleIdent -> Set ModuleIdent
mdlsType Type
ty Set ModuleIdent
ms
mdlsExpr :: IL.Expression -> Set.Set ModuleIdent -> Set.Set ModuleIdent
mdlsExpr :: Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr (IL.Function _ f :: QualIdent
f _) ms :: Set ModuleIdent
ms = QualIdent -> Set ModuleIdent -> Set ModuleIdent
modules QualIdent
f Set ModuleIdent
ms
mdlsExpr (IL.Constructor _ c :: QualIdent
c _) ms :: Set ModuleIdent
ms = QualIdent -> Set ModuleIdent -> Set ModuleIdent
modules QualIdent
c Set ModuleIdent
ms
mdlsExpr (IL.Apply e1 :: Expression
e1 e2 :: Expression
e2) ms :: Set ModuleIdent
ms = Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e1 (Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e2 Set ModuleIdent
ms)
mdlsExpr (IL.Case _ e :: Expression
e as :: [Alt]
as) ms :: Set ModuleIdent
ms = Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e ((Alt -> Set ModuleIdent -> Set ModuleIdent)
-> Set ModuleIdent -> [Alt] -> Set ModuleIdent
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Alt -> Set ModuleIdent -> Set ModuleIdent
mdlsAlt Set ModuleIdent
ms [Alt]
as)
where
mdlsAlt :: Alt -> Set ModuleIdent -> Set ModuleIdent
mdlsAlt (IL.Alt t :: ConstrTerm
t e' :: Expression
e') = ConstrTerm -> Set ModuleIdent -> Set ModuleIdent
mdlsPattern ConstrTerm
t (Set ModuleIdent -> Set ModuleIdent)
-> (Set ModuleIdent -> Set ModuleIdent)
-> Set ModuleIdent
-> Set ModuleIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e'
mdlsPattern :: ConstrTerm -> Set ModuleIdent -> Set ModuleIdent
mdlsPattern (IL.ConstructorPattern _ c :: QualIdent
c _) = QualIdent -> Set ModuleIdent -> Set ModuleIdent
modules QualIdent
c
mdlsPattern _ = Set ModuleIdent -> Set ModuleIdent
forall a. a -> a
id
mdlsExpr (IL.Or e1 :: Expression
e1 e2 :: Expression
e2) ms :: Set ModuleIdent
ms = Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e1 (Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e2 Set ModuleIdent
ms)
mdlsExpr (IL.Exist _ _ e :: Expression
e) ms :: Set ModuleIdent
ms = Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e Set ModuleIdent
ms
mdlsExpr (IL.Let b :: Binding
b e :: Expression
e) ms :: Set ModuleIdent
ms = Binding -> Set ModuleIdent -> Set ModuleIdent
mdlsBinding Binding
b (Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e Set ModuleIdent
ms)
mdlsExpr (IL.Letrec bs :: [Binding]
bs e :: Expression
e) ms :: Set ModuleIdent
ms = (Binding -> Set ModuleIdent -> Set ModuleIdent)
-> Set ModuleIdent -> [Binding] -> Set ModuleIdent
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Binding -> Set ModuleIdent -> Set ModuleIdent
mdlsBinding (Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e Set ModuleIdent
ms) [Binding]
bs
mdlsExpr _ ms :: Set ModuleIdent
ms = Set ModuleIdent
ms
mdlsBinding :: IL.Binding -> Set.Set ModuleIdent -> Set.Set ModuleIdent
mdlsBinding :: Binding -> Set ModuleIdent -> Set ModuleIdent
mdlsBinding (IL.Binding _ e :: Expression
e) = Expression -> Set ModuleIdent -> Set ModuleIdent
mdlsExpr Expression
e
modules :: QualIdent -> Set.Set ModuleIdent -> Set.Set ModuleIdent
modules :: QualIdent -> Set ModuleIdent -> Set ModuleIdent
modules x :: QualIdent
x ms :: Set ModuleIdent
ms = Set ModuleIdent
-> (ModuleIdent -> Set ModuleIdent)
-> Maybe ModuleIdent
-> Set ModuleIdent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set ModuleIdent
ms (ModuleIdent -> Set ModuleIdent -> Set ModuleIdent
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set ModuleIdent
ms) (QualIdent -> Maybe ModuleIdent
qidModule QualIdent
x)
data TransEnv = TransEnv
{ TransEnv -> ModuleIdent
moduleIdent :: ModuleIdent
, TransEnv -> ValueEnv
valueEnv :: ValueEnv
, TransEnv -> TCEnv
tyconEnv :: TCEnv
}
type TransM a = R.Reader TransEnv a
getValueEnv :: TransM ValueEnv
getValueEnv :: TransM ValueEnv
getValueEnv = (TransEnv -> ValueEnv) -> TransM ValueEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
R.asks TransEnv -> ValueEnv
valueEnv
getTCEnv :: TransM TCEnv
getTCEnv :: TransM TCEnv
getTCEnv = (TransEnv -> TCEnv) -> TransM TCEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
R.asks TransEnv -> TCEnv
tyconEnv
trQualify :: Ident -> TransM QualIdent
trQualify :: Ident -> TransM QualIdent
trQualify i :: Ident
i = (ModuleIdent -> Ident -> QualIdent)
-> Ident -> ModuleIdent -> QualIdent
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleIdent -> Ident -> QualIdent
qualifyWith Ident
i (ModuleIdent -> QualIdent)
-> ReaderT TransEnv Identity ModuleIdent -> TransM QualIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TransEnv -> ModuleIdent) -> ReaderT TransEnv Identity ModuleIdent
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
R.asks TransEnv -> ModuleIdent
moduleIdent
getArity :: QualIdent -> TransM Int
getArity :: QualIdent -> TransM Int
getArity qid :: QualIdent
qid = do
ValueEnv
vEnv <- TransM ValueEnv
getValueEnv
Int -> TransM Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> TransM Int) -> Int -> TransM Int
forall a b. (a -> b) -> a -> b
$ case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
qid ValueEnv
vEnv of
[DataConstructor _ a :: Int
a _ _] -> Int
a
[NewtypeConstructor _ _ _] -> 1
[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
$ "CurryToIL.getArity: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
qid
constrType :: QualIdent -> TransM Type
constrType :: QualIdent -> TransM Type
constrType c :: QualIdent
c = do
ValueEnv
vEnv <- TransM ValueEnv
getValueEnv
case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
c ValueEnv
vEnv of
[DataConstructor _ _ _ (ForAll _ (PredType _ ty :: Type
ty))] -> Type -> TransM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
[NewtypeConstructor _ _ (ForAll _ (PredType _ ty :: Type
ty))] -> Type -> TransM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
_ -> String -> TransM Type
forall a. String -> a
internalError (String -> TransM Type) -> String -> TransM Type
forall a b. (a -> b) -> a -> b
$ "CurryToIL.constrType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c
tcTVarKinds :: QualIdent -> TransM [Kind]
tcTVarKinds :: QualIdent -> TransM [Kind]
tcTVarKinds qid :: QualIdent
qid = do
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
let mid :: ModuleIdent
mid = Maybe ModuleIdent -> ModuleIdent
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ModuleIdent -> ModuleIdent)
-> Maybe ModuleIdent -> ModuleIdent
forall a b. (a -> b) -> a -> b
$ QualIdent -> Maybe ModuleIdent
qidModule QualIdent
qid
kind :: Kind
kind = ModuleIdent -> QualIdent -> TCEnv -> Kind
tcKind ModuleIdent
mid QualIdent
qid TCEnv
tcEnv
[Kind] -> TransM [Kind]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Kind] -> TransM [Kind]) -> [Kind] -> TransM [Kind]
forall a b. (a -> b) -> a -> b
$ Kind -> [Kind]
kindArgs Kind
kind
trDecl :: Decl Type -> TransM [IL.Decl]
trDecl :: Decl Type -> Reader TransEnv [Decl]
trDecl (DataDecl _ tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs _) = (Decl -> [Decl] -> [Decl]
forall a. a -> [a] -> [a]
:[]) (Decl -> [Decl])
-> ReaderT TransEnv Identity Decl -> Reader TransEnv [Decl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> [Ident] -> [ConstrDecl] -> ReaderT TransEnv Identity Decl
trData Ident
tc [Ident]
tvs [ConstrDecl]
cs
trDecl (NewtypeDecl _ tc :: Ident
tc tvs :: [Ident]
tvs nc :: NewConstrDecl
nc _) = (Decl -> [Decl] -> [Decl]
forall a. a -> [a] -> [a]
:[]) (Decl -> [Decl])
-> ReaderT TransEnv Identity Decl -> Reader TransEnv [Decl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> [Ident] -> NewConstrDecl -> ReaderT TransEnv Identity Decl
trNewtype Ident
tc [Ident]
tvs NewConstrDecl
nc
trDecl (ExternalDataDecl _ tc :: Ident
tc tvs :: [Ident]
tvs) = (Decl -> [Decl] -> [Decl]
forall a. a -> [a] -> [a]
:[]) (Decl -> [Decl])
-> ReaderT TransEnv Identity Decl -> Reader TransEnv [Decl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> [Ident] -> ReaderT TransEnv Identity Decl
trExternalData Ident
tc [Ident]
tvs
trDecl (FunctionDecl _ _ f :: Ident
f eqs :: [Equation Type]
eqs) = (Decl -> [Decl] -> [Decl]
forall a. a -> [a] -> [a]
:[]) (Decl -> [Decl])
-> ReaderT TransEnv Identity Decl -> Reader TransEnv [Decl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> [Equation Type] -> ReaderT TransEnv Identity Decl
trFunction Ident
f [Equation Type]
eqs
trDecl (ExternalDecl _ vs :: [Var Type]
vs) = (Var Type -> ReaderT TransEnv Identity Decl)
-> [Var Type] -> Reader TransEnv [Decl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Var Type -> ReaderT TransEnv Identity Decl
trExternal [Var Type]
vs
trDecl _ = [Decl] -> Reader TransEnv [Decl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
trData :: Ident -> [Ident] -> [ConstrDecl] -> TransM IL.Decl
trData :: Ident -> [Ident] -> [ConstrDecl] -> ReaderT TransEnv Identity Decl
trData tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs = do
QualIdent
tc' <- Ident -> TransM QualIdent
trQualify Ident
tc
[Kind]
ks <- QualIdent -> TransM [Kind]
tcTVarKinds QualIdent
tc'
QualIdent -> [Kind] -> [ConstrDecl] -> Decl
IL.DataDecl QualIdent
tc' (Kind -> Kind
transKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks) ([ConstrDecl] -> Decl)
-> ReaderT TransEnv Identity [ConstrDecl]
-> ReaderT TransEnv Identity Decl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConstrDecl -> ReaderT TransEnv Identity ConstrDecl)
-> [ConstrDecl] -> ReaderT TransEnv Identity [ConstrDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstrDecl -> ReaderT TransEnv Identity ConstrDecl
trConstrDecl [ConstrDecl]
cs
trNewtype :: Ident -> [Ident] -> NewConstrDecl -> TransM IL.Decl
trNewtype :: Ident -> [Ident] -> NewConstrDecl -> ReaderT TransEnv Identity Decl
trNewtype tc :: Ident
tc tvs :: [Ident]
tvs nc :: NewConstrDecl
nc = do
QualIdent
tc' <- Ident -> TransM QualIdent
trQualify Ident
tc
[Kind]
ks <- QualIdent -> TransM [Kind]
tcTVarKinds QualIdent
tc'
QualIdent -> [Kind] -> NewConstrDecl -> Decl
IL.NewtypeDecl QualIdent
tc' (Kind -> Kind
transKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks) (NewConstrDecl -> Decl)
-> ReaderT TransEnv Identity NewConstrDecl
-> ReaderT TransEnv Identity Decl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NewConstrDecl -> ReaderT TransEnv Identity NewConstrDecl
trNewConstrDecl NewConstrDecl
nc
trConstrDecl :: ConstrDecl -> TransM IL.ConstrDecl
trConstrDecl :: ConstrDecl -> ReaderT TransEnv Identity ConstrDecl
trConstrDecl d :: ConstrDecl
d = do
QualIdent
c' <- Ident -> TransM QualIdent
trQualify (ConstrDecl -> Ident
constr ConstrDecl
d)
[Type]
ty' <- Type -> [Type]
arrowArgs (Type -> [Type]) -> TransM Type -> ReaderT TransEnv Identity [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> TransM Type
constrType QualIdent
c'
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
ConstrDecl -> ReaderT TransEnv Identity ConstrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstrDecl -> ReaderT TransEnv Identity ConstrDecl)
-> ConstrDecl -> ReaderT TransEnv Identity ConstrDecl
forall a b. (a -> b) -> a -> b
$ QualIdent -> [Type] -> ConstrDecl
IL.ConstrDecl QualIdent
c' ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCEnv -> Type -> Type
transType TCEnv
tcEnv) [Type]
ty')
where
constr :: ConstrDecl -> Ident
constr (ConstrDecl _ c :: Ident
c _) = Ident
c
constr (ConOpDecl _ _ op :: Ident
op _) = Ident
op
constr (RecordDecl _ c :: Ident
c _) = Ident
c
trNewConstrDecl :: NewConstrDecl -> TransM IL.NewConstrDecl
trNewConstrDecl :: NewConstrDecl -> ReaderT TransEnv Identity NewConstrDecl
trNewConstrDecl d :: NewConstrDecl
d = do
QualIdent
c' <- Ident -> TransM QualIdent
trQualify (NewConstrDecl -> Ident
constr NewConstrDecl
d)
[Type]
ty' <- Type -> [Type]
arrowArgs (Type -> [Type]) -> TransM Type -> ReaderT TransEnv Identity [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> TransM Type
constrType QualIdent
c'
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
case [Type]
ty' of
[ty :: Type
ty] -> NewConstrDecl -> ReaderT TransEnv Identity NewConstrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (NewConstrDecl -> ReaderT TransEnv Identity NewConstrDecl)
-> NewConstrDecl -> ReaderT TransEnv Identity NewConstrDecl
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> NewConstrDecl
IL.NewConstrDecl QualIdent
c' (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty)
_ -> String -> ReaderT TransEnv Identity NewConstrDecl
forall a. String -> a
internalError "CurryToIL.trNewConstrDecl: invalid constructor type"
where
constr :: NewConstrDecl -> Ident
constr (NewConstrDecl _ c :: Ident
c _) = Ident
c
constr (NewRecordDecl _ c :: Ident
c _) = Ident
c
trExternalData :: Ident -> [Ident] -> TransM IL.Decl
trExternalData :: Ident -> [Ident] -> ReaderT TransEnv Identity Decl
trExternalData tc :: Ident
tc tvs :: [Ident]
tvs = do
QualIdent
tc' <- Ident -> TransM QualIdent
trQualify Ident
tc
[Kind]
ks <- QualIdent -> TransM [Kind]
tcTVarKinds QualIdent
tc'
Decl -> ReaderT TransEnv Identity Decl
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl -> ReaderT TransEnv Identity Decl)
-> Decl -> ReaderT TransEnv Identity Decl
forall a b. (a -> b) -> a -> b
$ QualIdent -> [Kind] -> Decl
IL.ExternalDataDecl QualIdent
tc' (Kind -> Kind
transKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks)
trExternal :: Var Type -> TransM IL.Decl
trExternal :: Var Type -> ReaderT TransEnv Identity Decl
trExternal (Var ty :: Type
ty f :: Ident
f) = do
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
QualIdent
f' <- Ident -> TransM QualIdent
trQualify Ident
f
Int
a <- QualIdent -> TransM Int
getArity QualIdent
f'
Decl -> ReaderT TransEnv Identity Decl
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl -> ReaderT TransEnv Identity Decl)
-> Decl -> ReaderT TransEnv Identity Decl
forall a b. (a -> b) -> a -> b
$ QualIdent -> Int -> Type -> Decl
IL.ExternalDecl QualIdent
f' Int
a (TCEnv -> Type -> Type
transType TCEnv
tcEnv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
polyType Type
ty)
transType :: TCEnv -> Type -> IL.Type
transType :: TCEnv -> Type -> Type
transType tcEnv :: TCEnv
tcEnv ty' :: Type
ty' = Type -> [Type] -> Type
transType' Type
ty' []
where
ks :: [(Int, Kind)]
ks = TCEnv -> Type -> [(Int, Kind)]
transTVars TCEnv
tcEnv Type
ty'
transType' :: Type -> [Type] -> Type
transType' (TypeConstructor tc :: QualIdent
tc) = QualIdent -> [Type] -> Type
IL.TypeConstructor QualIdent
tc
transType' (TypeApply ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> [Type] -> Type
transType' Type
ty1 ([Type] -> Type) -> ([Type] -> [Type]) -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Type] -> Type
transType' Type
ty2 [] Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:)
transType' (TypeVariable tv :: Int
tv) = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
applyType' (Int -> Type
IL.TypeVariable Int
tv)
transType' (TypeConstrained tys :: [Type]
tys _) = Type -> [Type] -> Type
transType' ([Type] -> Type
forall a. [a] -> a
head [Type]
tys)
transType' (TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2) =
(Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
applyType' (Type -> Type -> Type
IL.TypeArrow (Type -> [Type] -> Type
transType' Type
ty1 []) (Type -> [Type] -> Type
transType' Type
ty2 []))
transType' (TypeForall tvs :: [Int]
tvs ty :: Type
ty) =
(Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
applyType' ([(Int, Kind)] -> Type -> Type
IL.TypeForall [(Int, Kind)]
tvs' (Type -> [Type] -> Type
transType' Type
ty []))
where tvs' :: [(Int, Kind)]
tvs' = ((Int, Kind) -> Bool) -> [(Int, Kind)] -> [(Int, Kind)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
tvs) (Int -> Bool) -> ((Int, Kind) -> Int) -> (Int, Kind) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Kind) -> Int
forall a b. (a, b) -> a
fst) [(Int, Kind)]
ks
applyType' :: IL.Type -> IL.Type -> IL.Type
applyType' :: Type -> Type -> Type
applyType' ty1 :: Type
ty1 ty2 :: Type
ty2 =
QualIdent -> [Type] -> Type
IL.TypeConstructor (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (String -> Ident
mkIdent "Apply")) [Type
ty1, Type
ty2]
polyType :: Type -> Type
polyType :: Type -> Type
polyType (TypeForall _ ty :: Type
ty) = Type -> Type
polyType Type
ty
polyType ty :: Type
ty =
let vs :: [Int]
vs = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Type -> [Int]
forall t. IsType t => t -> [Int]
typeVars Type
ty
in if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
vs then Type
ty else [Int] -> Type -> Type
TypeForall [Int]
vs Type
ty
data KIS = KIS
{ KIS -> Int
_nextId :: Int
, KIS -> Map Int Kind
kinds :: Map.Map Int IL.Kind
}
freshId :: S.State KIS Int
freshId :: State KIS Int
freshId = do
KIS i :: Int
i ks :: Map Int Kind
ks <- StateT KIS Identity KIS
forall s (m :: * -> *). MonadState s m => m s
S.get
KIS -> StateT KIS Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Int -> Map Int Kind -> KIS
KIS (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) Map Int Kind
ks)
Int -> State KIS Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
transTVars :: TCEnv -> Type -> [(Int, IL.Kind)]
transTVars :: TCEnv -> Type -> [(Int, Kind)]
transTVars tcEnv :: TCEnv
tcEnv ty' :: Type
ty' =
Map Int Kind -> [(Int, Kind)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int Kind -> [(Int, Kind)]) -> Map Int Kind -> [(Int, Kind)]
forall a b. (a -> b) -> a -> b
$ KIS -> Map Int Kind
kinds (KIS -> Map Int Kind) -> KIS -> Map Int Kind
forall a b. (a -> b) -> a -> b
$ StateT KIS Identity () -> KIS -> KIS
forall s a. State s a -> s -> s
S.execState (Type -> Kind -> StateT KIS Identity ()
build Type
ty' Kind
IL.KindStar) (Int -> Map Int Kind -> KIS
KIS 0 Map Int Kind
forall k a. Map k a
Map.empty)
where
build :: Type -> IL.Kind -> S.State KIS ()
build :: Type -> Kind -> StateT KIS Identity ()
build (TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2) _ =
Type -> Kind -> StateT KIS Identity ()
build Type
ty1 Kind
IL.KindStar StateT KIS Identity ()
-> StateT KIS Identity () -> StateT KIS Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Kind -> StateT KIS Identity ()
build Type
ty2 Kind
IL.KindStar
build (TypeConstrained tys :: [Type]
tys _) k :: Kind
k =
Type -> Kind -> StateT KIS Identity ()
build ([Type] -> Type
forall a. [a] -> a
head [Type]
tys) Kind
k
build (TypeForall _ ty :: Type
ty) k :: Kind
k =
Type -> Kind -> StateT KIS Identity ()
build Type
ty Kind
k
build (TypeVariable tv :: Int
tv) k :: Kind
k = do
KIS i :: Int
i ks :: Map Int Kind
ks <- StateT KIS Identity KIS
forall s (m :: * -> *). MonadState s m => m s
S.get
let k' :: Kind
k' = Kind -> Int -> Map Int Kind -> Kind
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Kind
k Int
tv Map Int Kind
ks
let s :: Map Int Kind
s = Kind -> Kind -> Map Int Kind
unifyKind Kind
k Kind
k'
let ks' :: Map Int Kind
ks' = (Kind -> Kind) -> Map Int Kind -> Map Int Kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Int Kind -> Kind -> Kind
applyKindSubst Map Int Kind
s) (Map Int Kind -> Map Int Kind) -> Map Int Kind -> Map Int Kind
forall a b. (a -> b) -> a -> b
$ Int -> Kind -> Map Int Kind -> Map Int Kind
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
tv Kind
k' Map Int Kind
ks
KIS -> StateT KIS Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Int -> Map Int Kind -> KIS
KIS Int
i Map Int Kind
ks')
build (TypeConstructor _) _ = () -> StateT KIS Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
build ta :: Type
ta@(TypeApply _ _) k :: Kind
k =
let (ty :: Type
ty, tys :: [Type]
tys) = Bool -> Type -> (Type, [Type])
unapplyType Bool
True Type
ta
in case Type
ty of
TypeConstructor tc :: QualIdent
tc -> do
let k' :: Kind
k' = ModuleIdent -> QualIdent -> TCEnv -> Kind
tcKind (Maybe ModuleIdent -> ModuleIdent
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ModuleIdent -> ModuleIdent)
-> Maybe ModuleIdent -> ModuleIdent
forall a b. (a -> b) -> a -> b
$ QualIdent -> Maybe ModuleIdent
qidModule QualIdent
tc) QualIdent
tc TCEnv
tcEnv
((Type, Kind) -> StateT KIS Identity ())
-> [(Type, Kind)] -> StateT KIS Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Type -> Kind -> StateT KIS Identity ())
-> (Type, Kind) -> StateT KIS Identity ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Kind -> StateT KIS Identity ()
build) ([Type] -> [Kind] -> [(Type, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
tys ([Kind] -> [(Type, Kind)]) -> [Kind] -> [(Type, Kind)]
forall a b. (a -> b) -> a -> b
$ Kind -> [Kind]
unarrowKind (Kind -> [Kind]) -> Kind -> [Kind]
forall a b. (a -> b) -> a -> b
$ Kind -> Kind
transKind Kind
k')
_ -> do
[Kind]
ks <- (Type -> StateT KIS Identity Kind)
-> [Type] -> StateT KIS Identity [Kind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT KIS Identity Kind -> Type -> StateT KIS Identity Kind
forall a b. a -> b -> a
const (State KIS Int
freshId State KIS Int
-> (Int -> StateT KIS Identity Kind) -> StateT KIS Identity Kind
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kind -> StateT KIS Identity Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> StateT KIS Identity Kind)
-> (Int -> Kind) -> Int -> StateT KIS Identity Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Kind
IL.KindVariable)) [Type]
tys
Type -> Kind -> StateT KIS Identity ()
build Type
ty ((Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Kind -> Kind -> Kind
IL.KindArrow Kind
k [Kind]
ks)
((Type, Kind) -> StateT KIS Identity ())
-> [(Type, Kind)] -> StateT KIS Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Type -> Kind -> StateT KIS Identity ())
-> (Type, Kind) -> StateT KIS Identity ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Kind -> StateT KIS Identity ()
build) ([Type] -> [Kind] -> [(Type, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
tys [Kind]
ks)
type KindSubst = Map.Map Int IL.Kind
transKind :: Kind -> IL.Kind
transKind :: Kind -> Kind
transKind KindStar = Kind
IL.KindStar
transKind (KindVariable _) = Kind
IL.KindStar
transKind (KindArrow k1 :: Kind
k1 k2 :: Kind
k2) = Kind -> Kind -> Kind
IL.KindArrow (Kind -> Kind
transKind Kind
k1) (Kind -> Kind
transKind Kind
k2)
unarrowKind :: IL.Kind -> [IL.Kind]
unarrowKind :: Kind -> [Kind]
unarrowKind (IL.KindArrow k1 :: Kind
k1 k2 :: Kind
k2) = Kind
k1 Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: Kind -> [Kind]
unarrowKind Kind
k2
unarrowKind k :: Kind
k = [Kind
k]
applyKindSubst :: KindSubst -> IL.Kind -> IL.Kind
applyKindSubst :: Map Int Kind -> Kind -> Kind
applyKindSubst _ IL.KindStar =
Kind
IL.KindStar
applyKindSubst s :: Map Int Kind
s (IL.KindArrow k1 :: Kind
k1 k2 :: Kind
k2) =
Kind -> Kind -> Kind
IL.KindArrow (Map Int Kind -> Kind -> Kind
applyKindSubst Map Int Kind
s Kind
k1) (Map Int Kind -> Kind -> Kind
applyKindSubst Map Int Kind
s Kind
k2)
applyKindSubst s :: Map Int Kind
s v :: Kind
v@(IL.KindVariable i :: Int
i) =
Kind -> Int -> Map Int Kind -> Kind
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Kind
v Int
i Map Int Kind
s
composeKindSubst :: KindSubst -> KindSubst -> KindSubst
composeKindSubst :: Map Int Kind -> Map Int Kind -> Map Int Kind
composeKindSubst s1 :: Map Int Kind
s1 s2 :: Map Int Kind
s2 = (Kind -> Kind) -> Map Int Kind -> Map Int Kind
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Map Int Kind -> Kind -> Kind
applyKindSubst Map Int Kind
s1) Map Int Kind
s2 Map Int Kind -> Map Int Kind -> Map Int Kind
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Int Kind
s1
unifyKind :: IL.Kind -> IL.Kind -> KindSubst
unifyKind :: Kind -> Kind -> Map Int Kind
unifyKind IL.KindStar IL.KindStar = Map Int Kind
forall k a. Map k a
Map.empty
unifyKind (IL.KindVariable i :: Int
i) k :: Kind
k = Int -> Kind -> Map Int Kind
forall k a. k -> a -> Map k a
Map.singleton Int
i Kind
k
unifyKind k :: Kind
k (IL.KindVariable i :: Int
i) = Int -> Kind -> Map Int Kind
forall k a. k -> a -> Map k a
Map.singleton Int
i Kind
k
unifyKind (IL.KindArrow k1 :: Kind
k1 k2 :: Kind
k2) (IL.KindArrow k1' :: Kind
k1' k2' :: Kind
k2') =
let s1 :: Map Int Kind
s1 = Kind -> Kind -> Map Int Kind
unifyKind Kind
k1 Kind
k1'
s2 :: Map Int Kind
s2 = Kind -> Kind -> Map Int Kind
unifyKind (Map Int Kind -> Kind -> Kind
applyKindSubst Map Int Kind
s1 Kind
k2) (Map Int Kind -> Kind -> Kind
applyKindSubst Map Int Kind
s1 Kind
k2')
in Map Int Kind
s1 Map Int Kind -> Map Int Kind -> Map Int Kind
`composeKindSubst` Map Int Kind
s2
unifyKind k1 :: Kind
k1 k2 :: Kind
k2 = String -> Map Int Kind
forall a. HasCallStack => String -> a
error (String -> Map Int Kind) -> String -> Map Int Kind
forall a b. (a -> b) -> a -> b
$ "Transformation.CurryToIL.unifyKind: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
k1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
k2
trFunction :: Ident -> [Equation Type] -> TransM IL.Decl
trFunction :: Ident -> [Equation Type] -> ReaderT TransEnv Identity Decl
trFunction f :: Ident
f eqs :: [Equation Type]
eqs = do
QualIdent
f' <- Ident -> TransM QualIdent
trQualify Ident
f
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
let tys :: [Type]
tys = (Pattern Type -> Type) -> [Pattern Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pattern Type -> Type
forall a. Typeable a => a -> Type
typeOf [Pattern Type]
ts
ty' :: Type
ty' = TCEnv -> Type -> Type
transType TCEnv
tcEnv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
polyType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow (Rhs Type -> Type
forall a. Typeable a => a -> Type
typeOf Rhs Type
rhs) [Type]
tys
vs' :: [(Type, Ident)]
vs' = [Type] -> [Ident] -> [(Type, Ident)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCEnv -> Type -> Type
transType TCEnv
tcEnv) [Type]
tys) [Ident]
vs
[Match]
alts <- (Equation Type -> ReaderT TransEnv Identity Match)
-> [Equation Type] -> ReaderT TransEnv Identity [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident]
-> [Ident] -> Equation Type -> ReaderT TransEnv Identity Match
trEquation [Ident]
vs [Ident]
ws) [Equation Type]
eqs
Decl -> ReaderT TransEnv Identity Decl
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl -> ReaderT TransEnv Identity Decl)
-> Decl -> ReaderT TransEnv Identity Decl
forall a b. (a -> b) -> a -> b
$ QualIdent -> [(Type, Ident)] -> Type -> Expression -> Decl
IL.FunctionDecl QualIdent
f' [(Type, Ident)]
vs' Type
ty' ([(Type, Ident)] -> [Match] -> Expression
flexMatch [(Type, Ident)]
vs' [Match]
alts)
where
Equation _ lhs :: Lhs Type
lhs rhs :: Rhs Type
rhs = [Equation Type] -> Equation Type
forall a. [a] -> a
head [Equation Type]
eqs
(_, ts :: [Pattern Type]
ts) = Lhs Type -> (Ident, [Pattern Type])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs Lhs Type
lhs
(vs :: [Ident]
vs, ws :: [Ident]
ws) = Int -> [Ident] -> ([Ident], [Ident])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Pattern Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern Type]
ts) (Ident -> [Ident]
argNames (String -> Ident
mkIdent ""))
trEquation :: [Ident]
-> [Ident]
-> Equation Type
-> TransM Match
trEquation :: [Ident]
-> [Ident] -> Equation Type -> ReaderT TransEnv Identity Match
trEquation vs :: [Ident]
vs vs' :: [Ident]
vs' (Equation _ (FunLhs _ _ ts :: [Pattern Type]
ts) rhs :: Rhs Type
rhs) = do
let patternRenaming :: RenameEnv
patternRenaming = (Ident -> Pattern Type -> RenameEnv -> RenameEnv)
-> RenameEnv -> [Ident] -> [Pattern Type] -> RenameEnv
forall a b c. (a -> b -> c -> c) -> c -> [a] -> [b] -> c
foldr2 Ident -> Pattern Type -> RenameEnv -> RenameEnv
forall a. Ident -> Pattern a -> RenameEnv -> RenameEnv
bindRenameEnv RenameEnv
forall k a. Map k a
Map.empty [Ident]
vs [Pattern Type]
ts
Expression
rhs' <- [Ident] -> RenameEnv -> Rhs Type -> TransM Expression
trRhs [Ident]
vs' RenameEnv
patternRenaming Rhs Type
rhs
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
Match -> ReaderT TransEnv Identity Match
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident -> Pattern Type -> NestedTerm)
-> [Ident] -> [Pattern Type] -> [NestedTerm]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TCEnv -> Ident -> Pattern Type -> NestedTerm
trPattern TCEnv
tcEnv) [Ident]
vs [Pattern Type]
ts, Expression
rhs')
trEquation _ _ _
= String -> ReaderT TransEnv Identity Match
forall a. String -> a
internalError "Translation of non-FunLhs euqation not defined"
type RenameEnv = Map.Map Ident Ident
bindRenameEnv :: Ident -> Pattern a -> RenameEnv -> RenameEnv
bindRenameEnv :: Ident -> Pattern a -> RenameEnv -> RenameEnv
bindRenameEnv _ (LiteralPattern _ _ _) env :: RenameEnv
env = RenameEnv
env
bindRenameEnv v :: Ident
v (VariablePattern _ _ v' :: Ident
v') env :: RenameEnv
env = Ident -> Ident -> RenameEnv -> RenameEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
v' Ident
v RenameEnv
env
bindRenameEnv v :: Ident
v (ConstructorPattern _ _ _ ts :: [Pattern a]
ts) env :: RenameEnv
env
= (Ident -> Pattern a -> RenameEnv -> RenameEnv)
-> RenameEnv -> [Ident] -> [Pattern a] -> RenameEnv
forall a b c. (a -> b -> c -> c) -> c -> [a] -> [b] -> c
foldr2 Ident -> Pattern a -> RenameEnv -> RenameEnv
forall a. Ident -> Pattern a -> RenameEnv -> RenameEnv
bindRenameEnv RenameEnv
env (Ident -> [Ident]
argNames Ident
v) [Pattern a]
ts
bindRenameEnv v :: Ident
v (AsPattern _ v' :: Ident
v' t :: Pattern a
t) env :: RenameEnv
env
= Ident -> Ident -> RenameEnv -> RenameEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
v' Ident
v (Ident -> Pattern a -> RenameEnv -> RenameEnv
forall a. Ident -> Pattern a -> RenameEnv -> RenameEnv
bindRenameEnv Ident
v Pattern a
t RenameEnv
env)
bindRenameEnv _ _ _
= String -> RenameEnv
forall a. String -> a
internalError "CurryToIL.bindRenameEnv"
trRhs :: [Ident] -> RenameEnv -> Rhs Type -> TransM IL.Expression
trRhs :: [Ident] -> RenameEnv -> Rhs Type -> TransM Expression
trRhs vs :: [Ident]
vs env :: RenameEnv
env (SimpleRhs _ _ e :: Expression Type
e _) = [Ident] -> RenameEnv -> Expression Type -> TransM Expression
trExpr [Ident]
vs RenameEnv
env Expression Type
e
trRhs _ _ (GuardedRhs _ _ _ _) = String -> TransM Expression
forall a. String -> a
internalError "CurryToIL.trRhs: GuardedRhs"
trExpr :: [Ident] -> RenameEnv -> Expression Type -> TransM IL.Expression
trExpr :: [Ident] -> RenameEnv -> Expression Type -> TransM Expression
trExpr _ _ (Literal _ ty :: Type
ty l :: Literal
l) = do
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
Expression -> TransM Expression
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> TransM Expression)
-> Expression -> TransM Expression
forall a b. (a -> b) -> a -> b
$ Type -> Literal -> Expression
IL.Literal (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty) (Literal -> Literal
trLiteral Literal
l)
trExpr _ env :: RenameEnv
env (Variable _ ty :: Type
ty v :: QualIdent
v)
| QualIdent -> Bool
isQualified QualIdent
v = TransM TCEnv
getTCEnv TransM TCEnv -> (TCEnv -> TransM Expression) -> TransM Expression
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TCEnv -> TransM Expression
fun
| Bool
otherwise = do
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
case Ident -> RenameEnv -> Maybe Ident
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (QualIdent -> Ident
unqualify QualIdent
v) RenameEnv
env of
Nothing -> String -> TransM Expression
forall a. HasCallStack => String -> a
error (String -> TransM Expression) -> String -> TransM Expression
forall a b. (a -> b) -> a -> b
$ "unexpected variable" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
v
Just v' :: Ident
v' -> Expression -> TransM Expression
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> TransM Expression)
-> Expression -> TransM Expression
forall a b. (a -> b) -> a -> b
$ Type -> Ident -> Expression
IL.Variable (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty) Ident
v'
where
fun :: TCEnv -> TransM Expression
fun tcEnv :: TCEnv
tcEnv = Type -> QualIdent -> Int -> Expression
IL.Function (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty) QualIdent
v (Int -> Expression) -> TransM Int -> TransM Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> TransM Int
getArity QualIdent
v
trExpr _ _ (Constructor _ ty :: Type
ty c :: QualIdent
c) = do
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
Type -> QualIdent -> Int -> Expression
IL.Constructor (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty) QualIdent
c (Int -> Expression) -> TransM Int -> TransM Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> TransM Int
getArity QualIdent
c
trExpr vs :: [Ident]
vs env :: RenameEnv
env (Apply _ e1 :: Expression Type
e1 e2 :: Expression Type
e2)
= Expression -> Expression -> Expression
IL.Apply (Expression -> Expression -> Expression)
-> TransM Expression
-> ReaderT TransEnv Identity (Expression -> Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ident] -> RenameEnv -> Expression Type -> TransM Expression
trExpr [Ident]
vs RenameEnv
env Expression Type
e1 ReaderT TransEnv Identity (Expression -> Expression)
-> TransM Expression -> TransM Expression
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Ident] -> RenameEnv -> Expression Type -> TransM Expression
trExpr [Ident]
vs RenameEnv
env Expression Type
e2
trExpr vs :: [Ident]
vs env :: RenameEnv
env (Let _ _ ds :: [Decl Type]
ds e :: Expression Type
e) = do
Expression
e' <- [Ident] -> RenameEnv -> Expression Type -> TransM Expression
trExpr [Ident]
vs RenameEnv
env' Expression Type
e
case [Decl Type]
ds of
[FreeDecl _ vs' :: [Var Type]
vs']
-> do TCEnv
tcEnv <- TransM TCEnv
getTCEnv
Expression -> TransM Expression
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> TransM Expression)
-> Expression -> TransM Expression
forall a b. (a -> b) -> a -> b
$
(Var Type -> Expression -> Expression)
-> Expression -> [Var Type] -> Expression
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Var ty :: Type
ty v :: Ident
v) -> Ident -> Type -> Expression -> Expression
IL.Exist Ident
v (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty)) Expression
e' [Var Type]
vs'
[d :: Decl Type
d] | (Ident -> Bool) -> [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Decl Type -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Decl Type
d) (ModuleIdent -> Decl Type -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
emptyMIdent Decl Type
d)
-> (Binding -> Expression -> Expression)
-> Expression -> Binding -> Expression
forall a b c. (a -> b -> c) -> b -> a -> c
flip Binding -> Expression -> Expression
IL.Let Expression
e' (Binding -> Expression)
-> ReaderT TransEnv Identity Binding -> TransM Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decl Type -> ReaderT TransEnv Identity Binding
trBinding Decl Type
d
_ -> ([Binding] -> Expression -> Expression)
-> Expression -> [Binding] -> Expression
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Binding] -> Expression -> Expression
IL.Letrec Expression
e' ([Binding] -> Expression)
-> ReaderT TransEnv Identity [Binding] -> TransM Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl Type -> ReaderT TransEnv Identity Binding)
-> [Decl Type] -> ReaderT TransEnv Identity [Binding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl Type -> ReaderT TransEnv Identity Binding
trBinding [Decl Type]
ds
where
env' :: RenameEnv
env' = (Ident -> Ident -> RenameEnv -> RenameEnv)
-> RenameEnv -> [Ident] -> [Ident] -> RenameEnv
forall a b c. (a -> b -> c -> c) -> c -> [a] -> [b] -> c
foldr2 Ident -> Ident -> RenameEnv -> RenameEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RenameEnv
env [Ident]
bvs [Ident]
bvs
bvs :: [Ident]
bvs = [Decl Type] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [Decl Type]
ds
trBinding :: Decl Type -> ReaderT TransEnv Identity Binding
trBinding (PatternDecl _ (VariablePattern _ _ v :: Ident
v) rhs :: Rhs Type
rhs)
= Ident -> Expression -> Binding
IL.Binding Ident
v (Expression -> Binding)
-> TransM Expression -> ReaderT TransEnv Identity Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ident] -> RenameEnv -> Rhs Type -> TransM Expression
trRhs [Ident]
vs RenameEnv
env' Rhs Type
rhs
trBinding p :: Decl Type
p = String -> ReaderT TransEnv Identity Binding
forall a. HasCallStack => String -> a
error (String -> ReaderT TransEnv Identity Binding)
-> String -> ReaderT TransEnv Identity Binding
forall a b. (a -> b) -> a -> b
$ "unexpected binding: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Decl Type -> String
forall a. Show a => a -> String
show Decl Type
p
trExpr (v :: Ident
v:vs :: [Ident]
vs) env :: RenameEnv
env (Case _ _ ct :: CaseType
ct e :: Expression Type
e alts :: [Alt Type]
alts) = do
Expression
e' <- [Ident] -> RenameEnv -> Expression Type -> TransM Expression
trExpr [Ident]
vs RenameEnv
env Expression Type
e
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
let matcher :: [(Type, Ident)] -> [Match] -> Expression
matcher = if CaseType
ct CaseType -> CaseType -> Bool
forall a. Eq a => a -> a -> Bool
== CaseType
Flex then [(Type, Ident)] -> [Match] -> Expression
flexMatch else [(Type, Ident)] -> [Match] -> Expression
rigidMatch
ty' :: Type
ty' = TCEnv -> Type -> Type
transType TCEnv
tcEnv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expression Type -> Type
forall a. Typeable a => a -> Type
typeOf Expression Type
e
Expression
expr <- [(Type, Ident)] -> [Match] -> Expression
matcher [(Type
ty', Ident
v)] ([Match] -> Expression)
-> ReaderT TransEnv Identity [Match] -> TransM Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Alt Type -> ReaderT TransEnv Identity Match)
-> [Alt Type] -> ReaderT TransEnv Identity [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Ident] -> RenameEnv -> Alt Type -> ReaderT TransEnv Identity Match
trAlt (Ident
vIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
vs) RenameEnv
env) [Alt Type]
alts
Expression -> TransM Expression
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> TransM Expression)
-> Expression -> TransM Expression
forall a b. (a -> b) -> a -> b
$ case Expression
expr of
IL.Case mode :: Eval
mode (IL.Variable _ v' :: Ident
v') alts' :: [Alt]
alts'
| Ident
v Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
v' Bool -> Bool -> Bool
&& Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Alt] -> [Ident]
forall e. Expr e => e -> [Ident]
fv [Alt]
alts' -> Eval -> Expression -> [Alt] -> Expression
IL.Case Eval
mode Expression
e' [Alt]
alts'
_
| Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Expression -> [Ident]
forall e. Expr e => e -> [Ident]
fv Expression
expr -> Binding -> Expression -> Expression
IL.Let (Ident -> Expression -> Binding
IL.Binding Ident
v Expression
e') Expression
expr
| Bool
otherwise -> Expression
expr
trExpr vs :: [Ident]
vs env :: RenameEnv
env (Typed _ e :: Expression Type
e _) = do
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
Expression
e' <- [Ident] -> RenameEnv -> Expression Type -> TransM Expression
trExpr [Ident]
vs RenameEnv
env Expression Type
e
Expression -> TransM Expression
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> TransM Expression)
-> Expression -> TransM Expression
forall a b. (a -> b) -> a -> b
$ Expression -> Type -> Expression
IL.Typed Expression
e' (TCEnv -> Type -> Type
transType TCEnv
tcEnv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expression Type -> Type
forall a. Typeable a => a -> Type
typeOf Expression Type
e)
trExpr _ _ _ = String -> TransM Expression
forall a. String -> a
internalError "CurryToIL.trExpr"
trAlt :: [Ident] -> RenameEnv -> Alt Type -> TransM Match
trAlt :: [Ident] -> RenameEnv -> Alt Type -> ReaderT TransEnv Identity Match
trAlt ~(v :: Ident
v:vs :: [Ident]
vs) env :: RenameEnv
env (Alt _ t :: Pattern Type
t rhs :: Rhs Type
rhs) = do
TCEnv
tcEnv <- TransM TCEnv
getTCEnv
Expression
rhs' <- [Ident] -> RenameEnv -> Rhs Type -> TransM Expression
trRhs [Ident]
vs (Ident -> Pattern Type -> RenameEnv -> RenameEnv
forall a. Ident -> Pattern a -> RenameEnv -> RenameEnv
bindRenameEnv Ident
v Pattern Type
t RenameEnv
env) Rhs Type
rhs
Match -> ReaderT TransEnv Identity Match
forall (m :: * -> *) a. Monad m => a -> m a
return ([TCEnv -> Ident -> Pattern Type -> NestedTerm
trPattern TCEnv
tcEnv Ident
v Pattern Type
t], Expression
rhs')
trLiteral :: Literal -> IL.Literal
trLiteral :: Literal -> Literal
trLiteral (Char c :: Char
c) = Char -> Literal
IL.Char Char
c
trLiteral (Int i :: Integer
i) = Integer -> Literal
IL.Int Integer
i
trLiteral (Float f :: Double
f) = Double -> Literal
IL.Float Double
f
trLiteral _ = String -> Literal
forall a. String -> a
internalError "CurryToIL.trLiteral"
data NestedTerm = NestedTerm IL.ConstrTerm [NestedTerm] deriving Int -> NestedTerm -> String -> String
[NestedTerm] -> String -> String
NestedTerm -> String
(Int -> NestedTerm -> String -> String)
-> (NestedTerm -> String)
-> ([NestedTerm] -> String -> String)
-> Show NestedTerm
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [NestedTerm] -> String -> String
$cshowList :: [NestedTerm] -> String -> String
show :: NestedTerm -> String
$cshow :: NestedTerm -> String
showsPrec :: Int -> NestedTerm -> String -> String
$cshowsPrec :: Int -> NestedTerm -> String -> String
Show
pattern :: NestedTerm -> IL.ConstrTerm
pattern :: NestedTerm -> ConstrTerm
pattern (NestedTerm t :: ConstrTerm
t _) = ConstrTerm
t
arguments :: NestedTerm -> [NestedTerm]
arguments :: NestedTerm -> [NestedTerm]
arguments (NestedTerm _ ts :: [NestedTerm]
ts) = [NestedTerm]
ts
trPattern :: TCEnv -> Ident -> Pattern Type -> NestedTerm
trPattern :: TCEnv -> Ident -> Pattern Type -> NestedTerm
trPattern tcEnv :: TCEnv
tcEnv _ (LiteralPattern _ ty :: Type
ty l :: Literal
l)
= ConstrTerm -> [NestedTerm] -> NestedTerm
NestedTerm (Type -> Literal -> ConstrTerm
IL.LiteralPattern (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty) (Literal -> ConstrTerm) -> Literal -> ConstrTerm
forall a b. (a -> b) -> a -> b
$ Literal -> Literal
trLiteral Literal
l) []
trPattern tcEnv :: TCEnv
tcEnv v :: Ident
v (VariablePattern _ ty :: Type
ty _)
= ConstrTerm -> [NestedTerm] -> NestedTerm
NestedTerm (Type -> Ident -> ConstrTerm
IL.VariablePattern (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty) Ident
v) []
trPattern tcEnv :: TCEnv
tcEnv v :: Ident
v (ConstructorPattern _ ty :: Type
ty c :: QualIdent
c ts :: [Pattern Type]
ts)
= ConstrTerm -> [NestedTerm] -> NestedTerm
NestedTerm (Type -> QualIdent -> [(Type, Ident)] -> ConstrTerm
IL.ConstructorPattern (TCEnv -> Type -> Type
transType TCEnv
tcEnv Type
ty) QualIdent
c [(Type, Ident)]
vs')
((Ident -> Pattern Type -> NestedTerm)
-> [Ident] -> [Pattern Type] -> [NestedTerm]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (TCEnv -> Ident -> Pattern Type -> NestedTerm
trPattern TCEnv
tcEnv) [Ident]
vs [Pattern Type]
ts)
where vs :: [Ident]
vs = Ident -> [Ident]
argNames Ident
v
vs' :: [(Type, Ident)]
vs' = [Type] -> [Ident] -> [(Type, Ident)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Pattern Type -> Type) -> [Pattern Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TCEnv -> Type -> Type
transType TCEnv
tcEnv (Type -> Type) -> (Pattern Type -> Type) -> Pattern Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern Type -> Type
forall a. Typeable a => a -> Type
typeOf) [Pattern Type]
ts) [Ident]
vs
trPattern tcEnv :: TCEnv
tcEnv v :: Ident
v (AsPattern _ _ t :: Pattern Type
t)
= TCEnv -> Ident -> Pattern Type -> NestedTerm
trPattern TCEnv
tcEnv Ident
v Pattern Type
t
trPattern _ _ _
= String -> NestedTerm
forall a. String -> a
internalError "CurryToIL.trPattern"
argNames :: Ident -> [Ident]
argNames :: Ident -> [Ident]
argNames v :: Ident
v = [String -> Ident
mkIdent (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i) | Integer
i <- [1 :: Integer ..] ]
where prefix :: String
prefix = Ident -> String
idName Ident
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_"
type Match = ([NestedTerm], IL.Expression)
type Match' = (FunList NestedTerm, [NestedTerm], IL.Expression)
type FunList a = [a] -> [a]
flexMatch :: [(IL.Type, Ident)]
-> [Match]
-> IL.Expression
flexMatch :: [(Type, Ident)] -> [Match] -> Expression
flexMatch [] alts :: [Match]
alts = (Expression -> Expression -> Expression)
-> [Expression] -> Expression
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Expression -> Expression -> Expression
IL.Or ((Match -> Expression) -> [Match] -> [Expression]
forall a b. (a -> b) -> [a] -> [b]
map Match -> Expression
forall a b. (a, b) -> b
snd [Match]
alts)
flexMatch (v :: (Type, Ident)
v:vs :: [(Type, Ident)]
vs) alts :: [Match]
alts
| Bool
notDemanded = Expression
varExp
| Bool
isInductive = Expression
conExp
| Bool
otherwise = Expression
-> FunList (Type, Ident)
-> [(Type, Ident)]
-> [Match']
-> Expression
optFlexMatch (Expression -> Expression -> Expression
IL.Or Expression
conExp Expression
varExp) ((Type, Ident)
v(Type, Ident) -> FunList (Type, Ident)
forall a. a -> [a] -> [a]
:) [(Type, Ident)]
vs ((Match -> Match') -> [Match] -> [Match']
forall a b. (a -> b) -> [a] -> [b]
map Match -> Match'
skipPat [Match]
alts)
where
isInductive :: Bool
isInductive = [(ConstrTerm, Match)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ConstrTerm, Match)]
varAlts
notDemanded :: Bool
notDemanded = [(ConstrTerm, Match)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ConstrTerm, Match)]
conAlts
(varAlts :: [(ConstrTerm, Match)]
varAlts, conAlts :: [(ConstrTerm, Match)]
conAlts) = ((ConstrTerm, Match) -> Bool)
-> [(ConstrTerm, Match)]
-> ([(ConstrTerm, Match)], [(ConstrTerm, Match)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (ConstrTerm, Match) -> Bool
forall a. (ConstrTerm, a) -> Bool
isVarMatch ((Match -> (ConstrTerm, Match)) -> [Match] -> [(ConstrTerm, Match)]
forall a b. (a -> b) -> [a] -> [b]
map Match -> (ConstrTerm, Match)
tagAlt [Match]
alts)
varExp :: Expression
varExp = [(Type, Ident)] -> [Match] -> Expression
flexMatch [(Type, Ident)]
vs (((ConstrTerm, Match) -> Match) -> [(ConstrTerm, Match)] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map (ConstrTerm, Match) -> Match
forall a b. (a, b) -> b
snd [(ConstrTerm, Match)]
varAlts)
conExp :: Expression
conExp = FunList (Type, Ident)
-> (Type, Ident)
-> [(Type, Ident)]
-> [(ConstrTerm, Match')]
-> Expression
flexMatchInductive FunList (Type, Ident)
forall a. a -> a
id (Type, Ident)
v [(Type, Ident)]
vs (((ConstrTerm, Match) -> (ConstrTerm, Match'))
-> [(ConstrTerm, Match)] -> [(ConstrTerm, Match')]
forall a b. (a -> b) -> [a] -> [b]
map (ConstrTerm, Match) -> (ConstrTerm, Match')
forall a b c a. (a, (b, c)) -> (a, (a -> a, b, c))
prep [(ConstrTerm, Match)]
conAlts)
prep :: (a, (b, c)) -> (a, (a -> a, b, c))
prep (p :: a
p, (ts :: b
ts, e :: c
e)) = (a
p, (a -> a
forall a. a -> a
id, b
ts, c
e))
optFlexMatch :: IL.Expression
-> FunList (IL.Type, Ident)
-> [(IL.Type, Ident)]
-> [Match']
-> IL.Expression
optFlexMatch :: Expression
-> FunList (Type, Ident)
-> [(Type, Ident)]
-> [Match']
-> Expression
optFlexMatch def :: Expression
def _ [] _ = Expression
def
optFlexMatch def :: Expression
def prefix :: FunList (Type, Ident)
prefix (v :: (Type, Ident)
v:vs :: [(Type, Ident)]
vs) alts :: [Match']
alts
| Bool
isInductive = FunList (Type, Ident)
-> (Type, Ident)
-> [(Type, Ident)]
-> [(ConstrTerm, Match')]
-> Expression
flexMatchInductive FunList (Type, Ident)
prefix (Type, Ident)
v [(Type, Ident)]
vs [(ConstrTerm, Match')]
alts'
| Bool
otherwise = Expression
-> FunList (Type, Ident)
-> [(Type, Ident)]
-> [Match']
-> Expression
optFlexMatch Expression
def (FunList (Type, Ident)
prefix FunList (Type, Ident)
-> FunList (Type, Ident) -> FunList (Type, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Ident)
v(Type, Ident) -> FunList (Type, Ident)
forall a. a -> [a] -> [a]
:)) [(Type, Ident)]
vs ((Match' -> Match') -> [Match'] -> [Match']
forall a b. (a -> b) -> [a] -> [b]
map Match' -> Match'
skipPat' [Match']
alts)
where
isInductive :: Bool
isInductive = Bool -> Bool
not (((ConstrTerm, Match') -> Bool) -> [(ConstrTerm, Match')] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ConstrTerm, Match') -> Bool
forall a. (ConstrTerm, a) -> Bool
isVarMatch [(ConstrTerm, Match')]
alts')
alts' :: [(ConstrTerm, Match')]
alts' = (Match' -> (ConstrTerm, Match'))
-> [Match'] -> [(ConstrTerm, Match')]
forall a b. (a -> b) -> [a] -> [b]
map Match' -> (ConstrTerm, Match')
tagAlt' [Match']
alts
flexMatchInductive :: FunList (IL.Type, Ident)
-> (IL.Type, Ident)
-> [(IL.Type, Ident)]
-> [(IL.ConstrTerm, Match')]
-> IL.Expression
flexMatchInductive :: FunList (Type, Ident)
-> (Type, Ident)
-> [(Type, Ident)]
-> [(ConstrTerm, Match')]
-> Expression
flexMatchInductive prefix :: FunList (Type, Ident)
prefix v :: (Type, Ident)
v vs :: [(Type, Ident)]
vs as :: [(ConstrTerm, Match')]
as
= Eval -> Expression -> [Alt] -> Expression
IL.Case Eval
IL.Flex ((Type -> Ident -> Expression) -> (Type, Ident) -> Expression
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> Expression
IL.Variable (Type, Ident)
v) ([(ConstrTerm, Match')] -> [Alt]
forall t.
[(ConstrTerm, (t -> [NestedTerm], t, Expression))] -> [Alt]
flexMatchAlts [(ConstrTerm, Match')]
as)
where
flexMatchAlts :: [(ConstrTerm, (t -> [NestedTerm], t, Expression))] -> [Alt]
flexMatchAlts [] = []
flexMatchAlts ((t :: ConstrTerm
t, e :: (t -> [NestedTerm], t, Expression)
e) : alts :: [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
alts) = ConstrTerm -> Expression -> Alt
IL.Alt ConstrTerm
t Expression
expr Alt -> [Alt] -> [Alt]
forall a. a -> [a] -> [a]
: [(ConstrTerm, (t -> [NestedTerm], t, Expression))] -> [Alt]
flexMatchAlts [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
others
where
expr :: Expression
expr = [(Type, Ident)] -> [Match] -> Expression
flexMatch (FunList (Type, Ident)
prefix (ConstrTerm -> [(Type, Ident)]
vars ConstrTerm
t [(Type, Ident)] -> FunList (Type, Ident)
forall a. [a] -> [a] -> [a]
++ [(Type, Ident)]
vs)) (((t -> [NestedTerm], t, Expression) -> Match)
-> [(t -> [NestedTerm], t, Expression)] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map (t -> [NestedTerm], t, Expression) -> Match
forall t a b. (t -> a, t, b) -> (a, b)
expandVars ((t -> [NestedTerm], t, Expression)
e (t -> [NestedTerm], t, Expression)
-> [(t -> [NestedTerm], t, Expression)]
-> [(t -> [NestedTerm], t, Expression)]
forall a. a -> [a] -> [a]
: ((ConstrTerm, (t -> [NestedTerm], t, Expression))
-> (t -> [NestedTerm], t, Expression))
-> [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
-> [(t -> [NestedTerm], t, Expression)]
forall a b. (a -> b) -> [a] -> [b]
map (ConstrTerm, (t -> [NestedTerm], t, Expression))
-> (t -> [NestedTerm], t, Expression)
forall a b. (a, b) -> b
snd [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
same))
expandVars :: (t -> a, t, b) -> (a, b)
expandVars (pref :: t -> a
pref, ts1 :: t
ts1, e' :: b
e') = (t -> a
pref t
ts1, b
e')
(same :: [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
same, others :: [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
others) = ((ConstrTerm, (t -> [NestedTerm], t, Expression)) -> Bool)
-> [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
-> ([(ConstrTerm, (t -> [NestedTerm], t, Expression))],
[(ConstrTerm, (t -> [NestedTerm], t, Expression))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ConstrTerm
t ConstrTerm -> ConstrTerm -> Bool
forall a. Eq a => a -> a -> Bool
==) (ConstrTerm -> Bool)
-> ((ConstrTerm, (t -> [NestedTerm], t, Expression)) -> ConstrTerm)
-> (ConstrTerm, (t -> [NestedTerm], t, Expression))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstrTerm, (t -> [NestedTerm], t, Expression)) -> ConstrTerm
forall a b. (a, b) -> a
fst) [(ConstrTerm, (t -> [NestedTerm], t, Expression))]
alts
rigidMatch :: [(IL.Type, Ident)] -> [Match] -> IL.Expression
rigidMatch :: [(Type, Ident)] -> [Match] -> Expression
rigidMatch vs :: [(Type, Ident)]
vs alts :: [Match]
alts = Expression
-> FunList (Type, Ident)
-> [(Type, Ident)]
-> [Match']
-> Expression
rigidOptMatch (Match -> Expression
forall a b. (a, b) -> b
snd (Match -> Expression) -> Match -> Expression
forall a b. (a -> b) -> a -> b
$ [Match] -> Match
forall a. [a] -> a
head [Match]
alts) FunList (Type, Ident)
forall a. a -> a
id [(Type, Ident)]
vs ((Match -> Match') -> [Match] -> [Match']
forall a b. (a -> b) -> [a] -> [b]
map Match -> Match'
forall b c a. (b, c) -> (a -> a, b, c)
prepare [Match]
alts)
where prepare :: (b, c) -> (a -> a, b, c)
prepare (ts :: b
ts, e :: c
e) = (a -> a
forall a. a -> a
id, b
ts, c
e)
rigidOptMatch :: IL.Expression
-> FunList (IL.Type, Ident)
-> [(IL.Type, Ident)]
-> [Match']
-> IL.Expression
rigidOptMatch :: Expression
-> FunList (Type, Ident)
-> [(Type, Ident)]
-> [Match']
-> Expression
rigidOptMatch def :: Expression
def _ [] _ = Expression
def
rigidOptMatch def :: Expression
def prefix :: FunList (Type, Ident)
prefix (v :: (Type, Ident)
v : vs :: [(Type, Ident)]
vs) alts :: [Match']
alts
| Bool
isDemanded = FunList (Type, Ident)
-> (Type, Ident)
-> [(Type, Ident)]
-> [(ConstrTerm, Match')]
-> Expression
rigidMatchDemanded FunList (Type, Ident)
prefix (Type, Ident)
v [(Type, Ident)]
vs [(ConstrTerm, Match')]
alts'
| Bool
otherwise = Expression
-> FunList (Type, Ident)
-> [(Type, Ident)]
-> [Match']
-> Expression
rigidOptMatch Expression
def (FunList (Type, Ident)
prefix FunList (Type, Ident)
-> FunList (Type, Ident) -> FunList (Type, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Type, Ident)
v(Type, Ident) -> FunList (Type, Ident)
forall a. a -> [a] -> [a]
:)) [(Type, Ident)]
vs ((Match' -> Match') -> [Match'] -> [Match']
forall a b. (a -> b) -> [a] -> [b]
map Match' -> Match'
skipPat' [Match']
alts)
where
isDemanded :: Bool
isDemanded = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (ConstrTerm, Match') -> Bool
forall a. (ConstrTerm, a) -> Bool
isVarMatch ([(ConstrTerm, Match')] -> (ConstrTerm, Match')
forall a. [a] -> a
head [(ConstrTerm, Match')]
alts')
alts' :: [(ConstrTerm, Match')]
alts' = (Match' -> (ConstrTerm, Match'))
-> [Match'] -> [(ConstrTerm, Match')]
forall a b. (a -> b) -> [a] -> [b]
map Match' -> (ConstrTerm, Match')
tagAlt' [Match']
alts
rigidMatchDemanded :: FunList (IL.Type, Ident)
-> (IL.Type, Ident)
-> [(IL.Type, Ident)]
-> [(IL.ConstrTerm, Match')]
-> IL.Expression
rigidMatchDemanded :: FunList (Type, Ident)
-> (Type, Ident)
-> [(Type, Ident)]
-> [(ConstrTerm, Match')]
-> Expression
rigidMatchDemanded prefix :: FunList (Type, Ident)
prefix v :: (Type, Ident)
v vs :: [(Type, Ident)]
vs alts :: [(ConstrTerm, Match')]
alts = Eval -> Expression -> [Alt] -> Expression
IL.Case Eval
IL.Rigid ((Type -> Ident -> Expression) -> (Type, Ident) -> Expression
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> Expression
IL.Variable (Type, Ident)
v)
([Alt] -> Expression) -> [Alt] -> Expression
forall a b. (a -> b) -> a -> b
$ (ConstrTerm -> Alt) -> [ConstrTerm] -> [Alt]
forall a b. (a -> b) -> [a] -> [b]
map ConstrTerm -> Alt
caseAlt ([ConstrTerm]
consPats [ConstrTerm] -> [ConstrTerm] -> [ConstrTerm]
forall a. [a] -> [a] -> [a]
++ [ConstrTerm]
varPats)
where
(varPats :: [ConstrTerm]
varPats, consPats :: [ConstrTerm]
consPats) = (ConstrTerm -> Bool)
-> [ConstrTerm] -> ([ConstrTerm], [ConstrTerm])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ConstrTerm -> Bool
isVarPattern ([ConstrTerm] -> ([ConstrTerm], [ConstrTerm]))
-> [ConstrTerm] -> ([ConstrTerm], [ConstrTerm])
forall a b. (a -> b) -> a -> b
$ [ConstrTerm] -> [ConstrTerm]
forall a. Eq a => [a] -> [a]
nub ([ConstrTerm] -> [ConstrTerm]) -> [ConstrTerm] -> [ConstrTerm]
forall a b. (a -> b) -> a -> b
$ ((ConstrTerm, Match') -> ConstrTerm)
-> [(ConstrTerm, Match')] -> [ConstrTerm]
forall a b. (a -> b) -> [a] -> [b]
map (ConstrTerm, Match') -> ConstrTerm
forall a b. (a, b) -> a
fst [(ConstrTerm, Match')]
alts
caseAlt :: ConstrTerm -> Alt
caseAlt t :: ConstrTerm
t = ConstrTerm -> Expression -> Alt
IL.Alt ConstrTerm
t Expression
expr
where
expr :: Expression
expr = [(Type, Ident)] -> [Match] -> Expression
rigidMatch (FunList (Type, Ident)
prefix FunList (Type, Ident) -> FunList (Type, Ident)
forall a b. (a -> b) -> a -> b
$ ConstrTerm -> [(Type, Ident)]
vars ConstrTerm
t [(Type, Ident)] -> FunList (Type, Ident)
forall a. [a] -> [a] -> [a]
++ [(Type, Ident)]
vs) ([(ConstrTerm, Match')] -> [Match]
forall a b.
[(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))] -> [(a, b)]
matchingCases [(ConstrTerm, Match')]
alts)
matchingCases :: [(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))] -> [(a, b)]
matchingCases a :: [(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))]
a = ((ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b)) -> (a, b))
-> [(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map ([(Type, Ident)]
-> (ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b)) -> (a, b)
forall a b.
[(Type, Ident)]
-> (ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b)) -> (a, b)
expandVars (ConstrTerm -> [(Type, Ident)]
vars ConstrTerm
t)) ([(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))] -> [(a, b)])
-> [(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))] -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ ((ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b)) -> Bool)
-> [(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))]
-> [(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))]
forall a. (a -> Bool) -> [a] -> [a]
filter (ConstrTerm -> Bool
matches (ConstrTerm -> Bool)
-> ((ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))
-> ConstrTerm)
-> (ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b)) -> ConstrTerm
forall a b. (a, b) -> a
fst) [(ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b))]
a
matches :: ConstrTerm -> Bool
matches t' :: ConstrTerm
t' = ConstrTerm
t ConstrTerm -> ConstrTerm -> Bool
forall a. Eq a => a -> a -> Bool
== ConstrTerm
t' Bool -> Bool -> Bool
|| ConstrTerm -> Bool
isVarPattern ConstrTerm
t'
expandVars :: [(Type, Ident)]
-> (ConstrTerm, ([NestedTerm] -> a, [NestedTerm], b)) -> (a, b)
expandVars vs' :: [(Type, Ident)]
vs' (p :: ConstrTerm
p, (pref :: [NestedTerm] -> a
pref, ts1 :: [NestedTerm]
ts1, e :: b
e)) = ([NestedTerm] -> a
pref [NestedTerm]
ts2, b
e)
where ts2 :: [NestedTerm]
ts2 | ConstrTerm -> Bool
isVarPattern ConstrTerm
p = ((Type, Ident) -> NestedTerm) -> [(Type, Ident)] -> [NestedTerm]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Ident) -> NestedTerm
var2Pattern [(Type, Ident)]
vs' [NestedTerm] -> [NestedTerm] -> [NestedTerm]
forall a. [a] -> [a] -> [a]
++ [NestedTerm]
ts1
| Bool
otherwise = [NestedTerm]
ts1
var2Pattern :: (Type, Ident) -> NestedTerm
var2Pattern v' :: (Type, Ident)
v' = ConstrTerm -> [NestedTerm] -> NestedTerm
NestedTerm ((Type -> Ident -> ConstrTerm) -> (Type, Ident) -> ConstrTerm
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> ConstrTerm
IL.VariablePattern (Type, Ident)
v') []
isVarPattern :: IL.ConstrTerm -> Bool
isVarPattern :: ConstrTerm -> Bool
isVarPattern (IL.VariablePattern _ _) = Bool
True
isVarPattern _ = Bool
False
isVarMatch :: (IL.ConstrTerm, a) -> Bool
isVarMatch :: (ConstrTerm, a) -> Bool
isVarMatch = ConstrTerm -> Bool
isVarPattern (ConstrTerm -> Bool)
-> ((ConstrTerm, a) -> ConstrTerm) -> (ConstrTerm, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstrTerm, a) -> ConstrTerm
forall a b. (a, b) -> a
fst
vars :: IL.ConstrTerm -> [(IL.Type, Ident)]
vars :: ConstrTerm -> [(Type, Ident)]
vars (IL.ConstructorPattern _ _ vs :: [(Type, Ident)]
vs) = [(Type, Ident)]
vs
vars _ = []
tagAlt :: Match -> (IL.ConstrTerm, Match)
tagAlt :: Match -> (ConstrTerm, Match)
tagAlt (t :: NestedTerm
t:ts :: [NestedTerm]
ts, e :: Expression
e) = (NestedTerm -> ConstrTerm
pattern NestedTerm
t, (NestedTerm -> [NestedTerm]
arguments NestedTerm
t [NestedTerm] -> [NestedTerm] -> [NestedTerm]
forall a. [a] -> [a] -> [a]
++ [NestedTerm]
ts, Expression
e))
tagAlt ([] , _) = String -> (ConstrTerm, Match)
forall a. HasCallStack => String -> a
error "CurryToIL.tagAlt: empty pattern list"
skipPat :: Match -> Match'
skipPat :: Match -> Match'
skipPat (t :: NestedTerm
t:ts :: [NestedTerm]
ts, e :: Expression
e) = ((NestedTerm
tNestedTerm -> [NestedTerm] -> [NestedTerm]
forall a. a -> [a] -> [a]
:), [NestedTerm]
ts, Expression
e)
skipPat ([] , _) = String -> Match'
forall a. HasCallStack => String -> a
error "CurryToIL.skipPat: empty pattern list"
tagAlt' :: Match' -> (IL.ConstrTerm, Match')
tagAlt' :: Match' -> (ConstrTerm, Match')
tagAlt' (pref :: [NestedTerm] -> [NestedTerm]
pref, t :: NestedTerm
t:ts :: [NestedTerm]
ts, e' :: Expression
e') = (NestedTerm -> ConstrTerm
pattern NestedTerm
t, ([NestedTerm] -> [NestedTerm]
pref, NestedTerm -> [NestedTerm]
arguments NestedTerm
t [NestedTerm] -> [NestedTerm] -> [NestedTerm]
forall a. [a] -> [a] -> [a]
++ [NestedTerm]
ts, Expression
e'))
tagAlt' (_ , [] , _ ) = String -> (ConstrTerm, Match')
forall a. HasCallStack => String -> a
error "CurryToIL.tagAlt': empty pattern list"
skipPat' :: Match' -> Match'
skipPat' :: Match' -> Match'
skipPat' (pref :: [NestedTerm] -> [NestedTerm]
pref, t :: NestedTerm
t:ts :: [NestedTerm]
ts, e' :: Expression
e') = ([NestedTerm] -> [NestedTerm]
pref ([NestedTerm] -> [NestedTerm])
-> ([NestedTerm] -> [NestedTerm]) -> [NestedTerm] -> [NestedTerm]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NestedTerm
tNestedTerm -> [NestedTerm] -> [NestedTerm]
forall a. a -> [a] -> [a]
:), [NestedTerm]
ts, Expression
e')
skipPat' (_ , [] , _ ) = String -> Match'
forall a. HasCallStack => String -> a
error "CurryToIL.skipPat': empty pattern list"