{- |
    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           Data.List                   (nub, partition)
import qualified Data.Map             as Map (Map, empty, insert, lookup)
import qualified Data.Set             as Set (Set, empty, insert, delete, toList)

import Curry.Base.Ident
import Curry.Syntax hiding (caseAlt)

import Base.CurryTypes (toType)
import Base.Expr
import Base.Messages (internalError)
import Base.Types
import Base.Typing
import Base.Utils (foldr2)

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

import qualified IL as IL

ilTrans :: ValueEnv -> Module Type -> IL.Module
ilTrans :: ValueEnv -> Module Type -> Module
ilTrans vEnv :: ValueEnv
vEnv (Module _ _ m :: ModuleIdent
m _ _ ds :: [Decl Type]
ds) = ModuleIdent -> [ModuleIdent] -> [Decl] -> Module
IL.Module ModuleIdent
m (ModuleIdent -> [Decl] -> [ModuleIdent]
imports ModuleIdent
m [Decl]
ds') [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 -> TransEnv
TransEnv ModuleIdent
m ValueEnv
vEnv)

-- -----------------------------------------------------------------------------
-- 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.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
  }

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

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

-- Return the type of a variable
varType :: QualIdent -> TransM Type
varType :: QualIdent -> TransM Type
varType f :: QualIdent
f = do
  ValueEnv
tyEnv <- TransM ValueEnv
getValueEnv
  case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
f ValueEnv
tyEnv of
    [Value _ _ _ (ForAll _ (PredType _ ty :: Type
ty))] -> Type -> TransM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    [Label _ _ (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.varType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
f

-- 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

-- -----------------------------------------------------------------------------
-- 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 (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    _ ty :: Type
ty 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 -> Type -> [Equation Type] -> ReaderT TransEnv Identity Decl
trFunction Ident
f Type
ty [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
  QualIdent -> Int -> [ConstrDecl] -> Decl
IL.DataDecl QualIdent
tc' ([Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
tvs) ([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

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'
  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 Type -> Type
transType [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

trExternalData :: Ident -> [Ident] -> TransM IL.Decl
trExternalData :: Ident -> [Ident] -> ReaderT TransEnv Identity Decl
trExternalData tc :: Ident
tc tvs :: [Ident]
tvs = (QualIdent -> Int -> Decl) -> Int -> QualIdent -> Decl
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent -> Int -> Decl
IL.ExternalDataDecl ([Ident] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
tvs) (QualIdent -> Decl)
-> TransM QualIdent -> ReaderT TransEnv Identity Decl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> TransM QualIdent
trQualify Ident
tc

trExternal :: Var Type -> TransM IL.Decl
trExternal :: Var Type -> ReaderT TransEnv Identity Decl
trExternal (Var ty :: Type
ty f :: Ident
f) = (QualIdent -> Type -> Decl) -> Type -> QualIdent -> Decl
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent -> Type -> Decl
IL.ExternalDecl (Type -> Type
transType Type
ty) (QualIdent -> Decl)
-> TransM QualIdent -> ReaderT TransEnv Identity Decl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> TransM QualIdent
trQualify Ident
f

-- 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 @ 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 :: Type -> IL.Type
transType :: Type -> Type
transType ty :: Type
ty = Type -> [Type] -> Type
transType' Type
ty []

transType' :: Type -> [IL.Type] -> IL.Type
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
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
transType Type
ty1) (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] -> Type -> Type
IL.TypeForall [Int]
tvs (Type -> Type
transType Type
ty))

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]

-- 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 -> Type -> [Equation Type] -> TransM IL.Decl
trFunction :: Ident -> Type -> [Equation Type] -> ReaderT TransEnv Identity Decl
trFunction f :: Ident
f ty :: Type
ty eqs :: [Equation Type]
eqs = do
  QualIdent
f' <- Ident -> TransM QualIdent
trQualify Ident
f
  let ty' :: Type
ty' = Type -> Type
transType Type
ty
      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 (Type -> Type
transType (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
  [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 _ = [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
  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 Ident -> Pattern Type -> NestedTerm
trPattern [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) = 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 (Type -> Type
transType Type
ty) (Literal -> Literal
trLiteral Literal
l)
trExpr _  env :: RenameEnv
env (Variable    _ ty :: Type
ty v :: QualIdent
v)
  | QualIdent -> Bool
isQualified QualIdent
v = TransM Expression
fun
  | Bool
otherwise     = 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 -> TransM Expression
fun
      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 (Type -> Type
transType Type
ty) Ident
v' -- apply renaming
  where fun :: TransM Expression
fun = (Type -> QualIdent -> Int -> Expression
IL.Function (Type -> Type
transType Type
ty) QualIdent
v (Int -> Expression) -> (Type -> Int) -> Type -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int
arrowArity) (Type -> Expression) -> TransM Type -> TransM Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> TransM Type
varType QualIdent
v
trExpr _  _   (Constructor _ ty :: Type
ty c :: QualIdent
c)
  = (Type -> QualIdent -> Int -> Expression
IL.Constructor (Type -> Type
transType Type
ty) QualIdent
c (Int -> Expression) -> (Type -> Int) -> Type -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Int
arrowArity) (Type -> Expression) -> TransM Type -> TransM Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> TransM Type
constrType 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']
       -> 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 (Type -> Type
transType 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
  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'     = Type -> Type
transType (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 (QualTypeExpr _ _ ty :: TypeExpr
ty)) =
  (Expression -> Type -> Expression)
-> Type -> Expression -> Expression
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expression -> Type -> Expression
IL.Typed Type
ty' (Expression -> Expression)
-> TransM Expression -> TransM 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
e
  where ty' :: Type
ty' = Type -> Type
transType ([Ident] -> TypeExpr -> Type
toType [] TypeExpr
ty)
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
  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 ([Ident -> Pattern Type -> NestedTerm
trPattern 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 :: Ident -> Pattern Type -> NestedTerm
trPattern :: Ident -> Pattern Type -> NestedTerm
trPattern _ (LiteralPattern        _ ty :: Type
ty l :: Literal
l)
  = ConstrTerm -> [NestedTerm] -> NestedTerm
NestedTerm (Type -> Literal -> ConstrTerm
IL.LiteralPattern (Type -> Type
transType Type
ty) (Literal -> ConstrTerm) -> Literal -> ConstrTerm
forall a b. (a -> b) -> a -> b
$ Literal -> Literal
trLiteral Literal
l) []
trPattern v :: Ident
v (VariablePattern       _ ty :: Type
ty _)
  = ConstrTerm -> [NestedTerm] -> NestedTerm
NestedTerm (Type -> Ident -> ConstrTerm
IL.VariablePattern (Type -> Type
transType Type
ty) Ident
v) []
trPattern 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 (Type -> Type
transType 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 Ident -> Pattern Type -> NestedTerm
trPattern [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 (Type -> Type
transType (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 v :: Ident
v (AsPattern              _ _ t :: Pattern Type
t) = Ident -> Pattern Type -> NestedTerm
trPattern 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"