{- |
    Module      :  $Header$
    Description :  Translation of Curry into IL
    Copyright   :  (c) 1999 - 2003 Wolfgang Lux
                                   Martin Engelke
                       2011 - 2015 Björn Peemöller
                       2015        Jan Tikovsky
                       2016 - 2017 Finn Teegen
    License     :  BSD-3-clause

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

   After desugaring and lifting have been performed, the source code is
   translated into the intermediate language. Besides translating from
   source terms and expressions into intermediate language terms and
   expressions, this phase in particular has to implement the pattern
   matching algorithm for equations and case expressions.

   Because of name conflicts between the source and intermediate language
   data structures, we can use only a qualified import for the 'IL' module.
-}
{-# 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


-- -----------------------------------------------------------------------------
-- Computation of necessary imports
-- -----------------------------------------------------------------------------

-- The list of import declarations in the intermediate language code is
-- determined by collecting all module qualifiers used in the current module.

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)

-- -----------------------------------------------------------------------------
-- Internal reader monad
-- -----------------------------------------------------------------------------

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

-- Return the type of a constructor
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

-- Return the kinds of a type constructor's type variables
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

-- -----------------------------------------------------------------------------
-- Translation
-- -----------------------------------------------------------------------------

-- At the top-level, the compiler has to translate data type, newtype,
-- function, and external declarations. When translating a data type or
-- newtype declaration, we ignore the types in the declaration and lookup
-- the types of the constructors in the type environment instead because
-- these types are already fully expanded, i.e., they do not include any
-- alias types.

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)

-- The type representation in the intermediate language does not support
-- types with higher order kinds. Therefore, the type transformations has
-- to transform all types to first order terms. To that end, we assume the
-- existence of a type synonym 'type Apply f a = f a'. In addition, the type
-- representation of the intermediate language does not support constrained
-- type variables and skolem types. The former are fixed and the later are
-- replaced by fresh type constructors.

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]

-- We need to existentially quantify all variables in some types
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

-- We need to infer kinds for the quantified variables.
-- We already checked the correctness of all Kinds earlier,
-- thus we know that we will be able to unify all the inferred equations.
-- We can also keep a flat environment,
-- as all variables have already been renamed.

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
      -- get current kind
      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
      -- unify it
      let s :: Map Int Kind
s = Kind -> Kind -> Map Int Kind
unifyKind Kind
k Kind
k'
      -- apply substitution
      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 -- var of forall
          -- construct new kind vars
          [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
          -- infer kind for v
          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)
          -- infer kinds for args
          ((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

-- Each function in the program is translated into a function of the
-- intermediate language. The arguments of the function are renamed such
-- that all variables occurring in the same position (in different
-- equations) have the same name. This is necessary in order to
-- facilitate the translation of pattern matching into a 'case' expression.
-- We use the following simple convention here: The top-level
-- arguments of the function are named from left to right '_1', '_2',
-- and so on. The names of nested arguments are constructed by appending
-- '_1', '_2', etc. from left to right to the name that were assigned
-- to a variable occurring at the position of the constructor term.

-- Some special care is needed for the selector functions introduced by
-- the compiler in place of pattern bindings. In order to generate the
-- code for updating all pattern variables, the equality of names between
-- the pattern variables in the first argument of the selector function
-- and their repeated occurrences in the remaining arguments must be
-- preserved. This means that the second and following arguments of a
-- selector function have to be renamed according to the name mapping
-- computed for its first argument.

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
  -- vs are the variables needed for the function: _1, _2, etc.
  -- ws is an infinite list for introducing additional variables later
  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]       -- identifiers for the function's parameters
           -> [Ident]       -- infinite list of additional identifiers
           -> Equation Type -- equation to be translated
           -> TransM Match  -- nested constructor terms + translated RHS
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
  -- construct renaming of variables inside constructor terms
  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
  -- translate right-hand-side
  Expression
rhs' <- [Ident] -> RenameEnv -> Rhs Type -> TransM Expression
trRhs [Ident]
vs' RenameEnv
patternRenaming Rhs Type
rhs
  -- convert patterns
  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

-- Construct a renaming of all variables inside the pattern to fresh identifiers
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"

-- Note that the case matching algorithm assumes that the matched
-- expression is accessible through a variable. The translation of case
-- expressions therefore introduces a let binding for the scrutinized
-- expression and immediately throws it away after the matching -- except
-- if the matching algorithm has decided to use that variable in the
-- right hand sides of the case expression. This may happen, for
-- instance, if one of the alternatives contains an as-pattern.

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 --TODO: Replace case by fromJust?
      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' -- apply renaming
  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
  -- the ident v is used for the case expression subject, as this could
  -- be referenced in the case alternatives by a variable pattern
  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'
        -- subject is not referenced -> forget v and insert subject
      | 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'
    _
        -- subject is referenced -> introduce binding for v as subject
      | 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"

-- -----------------------------------------------------------------------------
-- Translation of Patterns
-- -----------------------------------------------------------------------------

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]
++ "_"

-- -----------------------------------------------------------------------------
-- Flexible Pattern Matching Algorithm
-- -----------------------------------------------------------------------------

-- The pattern matching code searches for the left-most inductive
-- argument position in the left hand sides of all rules defining an
-- equation. An inductive position is a position where all rules have a
-- constructor rooted term. If such a position is found, a flexible 'case'
-- expression is generated for the argument at that position. The
-- matching code is then computed recursively for all of the alternatives
-- independently. If no inductive position is found, the algorithm looks
-- for the left-most demanded argument position, i.e., a position where
-- at least one of the rules has a constructor rooted term. If such a
-- position is found, an 'or' expression is generated with those
-- cases that have a variable at the argument position in one branch and
-- all other rules in the other branch. If there is no demanded position,
-- the pattern matching is finished and the compiler translates the right
-- hand sides of the remaining rules, eventually combining them using
-- 'or' expressions.

-- Actually, the algorithm below combines the search for inductive and
-- demanded positions. The function 'flexMatch' scans the argument
-- lists for the left-most demanded position. If this turns out to be
-- also an inductive position, the function 'flexMatchInductive' is
-- called in order to generate a flexible 'case' expression. Otherwise, the
-- function 'optFlexMatch' is called that tries to find an inductive
-- position in the remaining arguments. If one is found,
-- 'flexMatchInductive' is called, otherwise the function
-- 'optFlexMatch' uses the demanded argument position found by 'flexMatch'.

-- a @Match@ is a list of patterns and the respective expression.
type Match  = ([NestedTerm], IL.Expression)
-- a @Match'@ is a @Match@ with skipped patterns during the search for an
-- inductive position.
type Match' = (FunList NestedTerm, [NestedTerm], IL.Expression)
-- Functional lists
type FunList a = [a] -> [a]

flexMatch :: [(IL.Type, Ident)] -- variables to be matched
          -> [Match]            -- alternatives
          -> IL.Expression      -- result 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
  -- separate variable and constructor patterns
  (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)
  -- match variables
  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)
  -- match constructors
  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))

-- Search for the next inductive position
optFlexMatch :: IL.Expression            -- default expression
             -> FunList (IL.Type, Ident) -- skipped variables
             -> [(IL.Type, Ident)]       -- next variables
             -> [Match']                 -- alternatives
             -> 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

-- Generate a case expression matching the inductive position
flexMatchInductive :: FunList (IL.Type, Ident)  -- skipped variables
                   -> (IL.Type, Ident)          -- current variable
                   -> [(IL.Type, Ident)]        -- next variables
                   -> [(IL.ConstrTerm, Match')] -- alternatives
                   -> 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
  -- create alternatives for the different constructors
  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
    -- match nested patterns for same constructors
    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')
    -- split into same and other constructors
    (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

-- -----------------------------------------------------------------------------
-- Rigid Pattern Matching Algorithm
-- -----------------------------------------------------------------------------

-- Matching in a 'case'-expression works a little bit differently.
-- In this case, the alternatives are matched from the first to the last
-- alternative and the first matching alternative is chosen. All
-- remaining alternatives are discarded.

-- TODO: The case matching algorithm should use type information in order
-- to detect total matches and immediately discard all alternatives which
-- cannot be reached.

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            -- default expression
              -> FunList (IL.Type, Ident) -- variables to be matched next
              -> [(IL.Type, Ident)]       -- variables to be matched afterwards
              -> [Match']                 -- translated equations
              -> IL.Expression
-- if there are no variables left: return the default 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

-- Generate a case expression matching the demanded position.
-- This algorithm constructs a branch for all contained patterns, where
-- the right-hand side then respects the order of the patterns.
-- Thus, the expression
--    case x of
--      []   -> []
--      ys   -> ys
--      y:ys -> [y]
-- gets translated to
--    case x of
--      []   -> []
--      y:ys -> x
--      x    -> x
rigidMatchDemanded :: FunList (IL.Type, Ident)  -- skipped variables
                   -> (IL.Type, Ident)          -- current variable
                   -> [(IL.Type, Ident)]        -- next variables
                   -> [(IL.ConstrTerm, Match')] -- alternatives
                   -> 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
  -- N.B.: @varPats@ is either empty or a singleton list due to nub
  (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 selects the matching alternatives
    --  and recursively matches the remaining patterns
    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') []

-- -----------------------------------------------------------------------------
-- Pattern Matching Auxiliaries
-- -----------------------------------------------------------------------------

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 extracts the structure of the first pattern
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 skips the current pattern position for later matching
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' extracts the next pattern
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' skips the current argument for later matching
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"