{- |
    Module      :  $Header$
    Description :  Generation of AbstractCurry program terms
    Copyright   :  (c) 2005        Martin Engelke
                       2011 - 2015 Björn Peemöller
                       2015        Jan Tikovsky
                       2016        Finn Teegen
    License     :  BSD-3-clause

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

    This module contains the generation of an 'AbstractCurry' program term
    for a given 'Curry' module.
-}
{-# LANGUAGE CPP #-}
module Generators.GenAbstractCurry (genAbstractCurry) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative          ((<$>), (<*>), pure)
#endif
import           Control.Monad.Extra
import qualified Control.Monad.State as S     (State, evalState, get, gets
                                              , modify, put, when)
import qualified Data.Map            as Map   (Map, empty, fromList, lookup
                                              , union)
import qualified Data.Maybe          as Maybe (fromJust, fromMaybe, listToMaybe)
import qualified Data.Set            as Set   (Set, empty, insert, member)
import qualified Data.Traversable    as T     (forM)

import Curry.AbstractCurry
import Curry.Base.Ident
import Curry.Base.SpanInfo
import Curry.Syntax

import Base.CurryTypes (fromPredType, toType, toPredType)
import Base.Expr       (bv)
import Base.Messages   (internalError)
import Base.NestEnv
import Base.Types      (arrowArity, PredType, unpredType, TypeScheme (..))
import Base.TypeSubst

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

import CompilerEnv

type GAC a = S.State AbstractEnv a

-- ---------------------------------------------------------------------------
-- Interface
-- ---------------------------------------------------------------------------

-- |Generate an AbstractCurry program term from the syntax tree
--  when uacy flag is set untype AbstractCurry is generated
genAbstractCurry :: Bool -> CompilerEnv -> Module PredType -> CurryProg
genAbstractCurry :: Bool -> CompilerEnv -> Module PredType -> CurryProg
genAbstractCurry uacy :: Bool
uacy env :: CompilerEnv
env mdl :: Module PredType
mdl
  = State AbstractEnv CurryProg -> AbstractEnv -> CurryProg
forall s a. State s a -> s -> a
S.evalState (Module PredType -> State AbstractEnv CurryProg
trModule Module PredType
mdl) (Bool -> CompilerEnv -> Module PredType -> AbstractEnv
forall a. Bool -> CompilerEnv -> Module a -> AbstractEnv
abstractEnv Bool
uacy CompilerEnv
env Module PredType
mdl)

-- ---------------------------------------------------------------------------
-- Conversion from Curry to AbstractCurry
-- ---------------------------------------------------------------------------

trModule :: Module PredType -> GAC CurryProg
trModule :: Module PredType -> State AbstractEnv CurryProg
trModule (Module _ _ _ mid :: ModuleIdent
mid _ is :: [ImportDecl]
is ds :: [Decl PredType]
ds) =
  MName
-> [MName]
-> Maybe CDefaultDecl
-> [CClassDecl]
-> [CInstanceDecl]
-> [CTypeDecl]
-> [CFuncDecl]
-> [COpDecl]
-> CurryProg
CurryProg MName
mid' [MName]
is' (Maybe CDefaultDecl
 -> [CClassDecl]
 -> [CInstanceDecl]
 -> [CTypeDecl]
 -> [CFuncDecl]
 -> [COpDecl]
 -> CurryProg)
-> StateT AbstractEnv Identity (Maybe CDefaultDecl)
-> StateT
     AbstractEnv
     Identity
     ([CClassDecl]
      -> [CInstanceDecl]
      -> [CTypeDecl]
      -> [CFuncDecl]
      -> [COpDecl]
      -> CurryProg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT AbstractEnv Identity (Maybe CDefaultDecl)
dflt' StateT
  AbstractEnv
  Identity
  ([CClassDecl]
   -> [CInstanceDecl]
   -> [CTypeDecl]
   -> [CFuncDecl]
   -> [COpDecl]
   -> CurryProg)
-> StateT AbstractEnv Identity [CClassDecl]
-> StateT
     AbstractEnv
     Identity
     ([CInstanceDecl]
      -> [CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> CurryProg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT AbstractEnv Identity [CClassDecl]
cds' StateT
  AbstractEnv
  Identity
  ([CInstanceDecl]
   -> [CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> CurryProg)
-> StateT AbstractEnv Identity [CInstanceDecl]
-> StateT
     AbstractEnv
     Identity
     ([CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> CurryProg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT AbstractEnv Identity [CInstanceDecl]
ids' StateT
  AbstractEnv
  Identity
  ([CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> CurryProg)
-> StateT AbstractEnv Identity [CTypeDecl]
-> StateT
     AbstractEnv Identity ([CFuncDecl] -> [COpDecl] -> CurryProg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT AbstractEnv Identity [CTypeDecl]
ts' StateT AbstractEnv Identity ([CFuncDecl] -> [COpDecl] -> CurryProg)
-> StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity ([COpDecl] -> CurryProg)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT AbstractEnv Identity [CFuncDecl]
fs' StateT AbstractEnv Identity ([COpDecl] -> CurryProg)
-> StateT AbstractEnv Identity [COpDecl]
-> State AbstractEnv CurryProg
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT AbstractEnv Identity [COpDecl]
os'
  where
  mid' :: MName
mid'  = ModuleIdent -> MName
moduleName ModuleIdent
mid
  is' :: [MName]
is'   = (ImportDecl -> MName) -> [ImportDecl] -> [MName]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl -> MName
cvImportDecl [ImportDecl]
is
  dflt' :: StateT AbstractEnv Identity (Maybe CDefaultDecl)
dflt' = [CDefaultDecl] -> Maybe CDefaultDecl
forall a. [a] -> Maybe a
Maybe.listToMaybe ([CDefaultDecl] -> Maybe CDefaultDecl)
-> StateT AbstractEnv Identity [CDefaultDecl]
-> StateT AbstractEnv Identity (Maybe CDefaultDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PredType -> StateT AbstractEnv Identity [CDefaultDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CDefaultDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (StateT AbstractEnv Identity [CDefaultDecl]
-> StateT AbstractEnv Identity [CDefaultDecl]
forall a. GAC a -> GAC a
withLocalEnv (StateT AbstractEnv Identity [CDefaultDecl]
 -> StateT AbstractEnv Identity [CDefaultDecl])
-> (Decl PredType -> StateT AbstractEnv Identity [CDefaultDecl])
-> Decl PredType
-> StateT AbstractEnv Identity [CDefaultDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl PredType -> StateT AbstractEnv Identity [CDefaultDecl]
forall a. Decl a -> StateT AbstractEnv Identity [CDefaultDecl]
trDefaultDecl) [Decl PredType]
ds
  cds' :: StateT AbstractEnv Identity [CClassDecl]
cds'  = (Decl PredType -> StateT AbstractEnv Identity [CClassDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CClassDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (StateT AbstractEnv Identity [CClassDecl]
-> StateT AbstractEnv Identity [CClassDecl]
forall a. GAC a -> GAC a
withLocalEnv (StateT AbstractEnv Identity [CClassDecl]
 -> StateT AbstractEnv Identity [CClassDecl])
-> (Decl PredType -> StateT AbstractEnv Identity [CClassDecl])
-> Decl PredType
-> StateT AbstractEnv Identity [CClassDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl PredType -> StateT AbstractEnv Identity [CClassDecl]
trClassDecl) [Decl PredType]
ds
  ids' :: StateT AbstractEnv Identity [CInstanceDecl]
ids'  = (Decl PredType -> StateT AbstractEnv Identity [CInstanceDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CInstanceDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (StateT AbstractEnv Identity [CInstanceDecl]
-> StateT AbstractEnv Identity [CInstanceDecl]
forall a. GAC a -> GAC a
withLocalEnv (StateT AbstractEnv Identity [CInstanceDecl]
 -> StateT AbstractEnv Identity [CInstanceDecl])
-> (Decl PredType -> StateT AbstractEnv Identity [CInstanceDecl])
-> Decl PredType
-> StateT AbstractEnv Identity [CInstanceDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl PredType -> StateT AbstractEnv Identity [CInstanceDecl]
trInstanceDecl) [Decl PredType]
ds
  ts' :: StateT AbstractEnv Identity [CTypeDecl]
ts'   = (Decl PredType -> StateT AbstractEnv Identity [CTypeDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CTypeDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (StateT AbstractEnv Identity [CTypeDecl]
-> StateT AbstractEnv Identity [CTypeDecl]
forall a. GAC a -> GAC a
withLocalEnv (StateT AbstractEnv Identity [CTypeDecl]
 -> StateT AbstractEnv Identity [CTypeDecl])
-> (Decl PredType -> StateT AbstractEnv Identity [CTypeDecl])
-> Decl PredType
-> StateT AbstractEnv Identity [CTypeDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl PredType -> StateT AbstractEnv Identity [CTypeDecl]
forall a. Decl a -> StateT AbstractEnv Identity [CTypeDecl]
trTypeDecl) [Decl PredType]
ds
  fs' :: StateT AbstractEnv Identity [CFuncDecl]
fs'   = (Decl PredType -> StateT AbstractEnv Identity [CFuncDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CFuncDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity [CFuncDecl]
forall a. GAC a -> GAC a
withLocalEnv (StateT AbstractEnv Identity [CFuncDecl]
 -> StateT AbstractEnv Identity [CFuncDecl])
-> (Decl PredType -> StateT AbstractEnv Identity [CFuncDecl])
-> Decl PredType
-> StateT AbstractEnv Identity [CFuncDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Decl PredType -> StateT AbstractEnv Identity [CFuncDecl]
trFuncDecl Bool
True) [Decl PredType]
ds
  os' :: StateT AbstractEnv Identity [COpDecl]
os'   = (Decl PredType -> StateT AbstractEnv Identity [COpDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [COpDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (StateT AbstractEnv Identity [COpDecl]
-> StateT AbstractEnv Identity [COpDecl]
forall a. GAC a -> GAC a
withLocalEnv (StateT AbstractEnv Identity [COpDecl]
 -> StateT AbstractEnv Identity [COpDecl])
-> (Decl PredType -> StateT AbstractEnv Identity [COpDecl])
-> Decl PredType
-> StateT AbstractEnv Identity [COpDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Decl PredType -> StateT AbstractEnv Identity [COpDecl]
forall a. Decl a -> StateT AbstractEnv Identity [COpDecl]
trInfixDecl) [Decl PredType]
ds

cvImportDecl :: ImportDecl -> String
cvImportDecl :: ImportDecl -> MName
cvImportDecl (ImportDecl _ mid :: ModuleIdent
mid _ _ _) = ModuleIdent -> MName
moduleName ModuleIdent
mid

trDefaultDecl :: Decl a -> GAC [CDefaultDecl]
trDefaultDecl :: Decl a -> StateT AbstractEnv Identity [CDefaultDecl]
trDefaultDecl (DefaultDecl _ tys :: [TypeExpr]
tys) = (\tys' :: [CTypeExpr]
tys' -> [[CTypeExpr] -> CDefaultDecl
CDefaultDecl [CTypeExpr]
tys'])
  ([CTypeExpr] -> [CDefaultDecl])
-> StateT AbstractEnv Identity [CTypeExpr]
-> StateT AbstractEnv Identity [CDefaultDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeExpr -> StateT AbstractEnv Identity CTypeExpr)
-> [TypeExpr] -> StateT AbstractEnv Identity [CTypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr [TypeExpr]
tys
trDefaultDecl _                   = [CDefaultDecl] -> StateT AbstractEnv Identity [CDefaultDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

trClassDecl :: Decl PredType -> GAC [CClassDecl]
trClassDecl :: Decl PredType -> StateT AbstractEnv Identity [CClassDecl]
trClassDecl (ClassDecl _ _ cx :: Context
cx cls :: Ident
cls tv :: Ident
tv ds :: [Decl PredType]
ds) =
  (\cls' :: QName
cls' v' :: CVisibility
v' cx' :: CContext
cx' tv' :: CTVarIName
tv' ds' :: [CFuncDecl]
ds' -> [QName
-> CVisibility
-> CContext
-> CTVarIName
-> [CFuncDecl]
-> CClassDecl
CClass QName
cls' CVisibility
v' CContext
cx' CTVarIName
tv' [CFuncDecl]
ds'])
    (QName
 -> CVisibility
 -> CContext
 -> CTVarIName
 -> [CFuncDecl]
 -> [CClassDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (CVisibility
      -> CContext -> CTVarIName -> [CFuncDecl] -> [CClassDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
cls StateT
  AbstractEnv
  Identity
  (CVisibility
   -> CContext -> CTVarIName -> [CFuncDecl] -> [CClassDecl])
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv
     Identity
     (CContext -> CTVarIName -> [CFuncDecl] -> [CClassDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getTypeVisibility Ident
cls StateT
  AbstractEnv
  Identity
  (CContext -> CTVarIName -> [CFuncDecl] -> [CClassDecl])
-> StateT AbstractEnv Identity CContext
-> StateT
     AbstractEnv Identity (CTVarIName -> [CFuncDecl] -> [CClassDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Context -> StateT AbstractEnv Identity CContext
trContext Context
cx
    StateT
  AbstractEnv Identity (CTVarIName -> [CFuncDecl] -> [CClassDecl])
-> StateT AbstractEnv Identity CTVarIName
-> StateT AbstractEnv Identity ([CFuncDecl] -> [CClassDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CTVarIName
getTVarIndex Ident
tv StateT AbstractEnv Identity ([CFuncDecl] -> [CClassDecl])
-> StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity [CClassDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Decl PredType -> StateT AbstractEnv Identity [CFuncDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CFuncDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ([(Ident, QualTypeExpr)]
-> [Ident]
-> Decl PredType
-> StateT AbstractEnv Identity [CFuncDecl]
trClassMethodDecl [(Ident, QualTypeExpr)]
sigs [Ident]
fs) [Decl PredType]
ds
  where fs :: [Ident]
fs = [Ident
f | FunctionDecl _ _ f :: Ident
f _ <- [Decl PredType]
ds]
        sigs :: [(Ident, QualTypeExpr)]
sigs = [Decl PredType] -> [(Ident, QualTypeExpr)]
forall a. [Decl a] -> [(Ident, QualTypeExpr)]
signatures [Decl PredType]
ds
trClassDecl _ = [CClassDecl] -> StateT AbstractEnv Identity [CClassDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- We ignore type signatures for class methods with a given default
-- implementation as declarations for those are generated anyway.
-- For function declarations we use the equation's arity instead of
-- the one from the value environment or 0.
trClassMethodDecl :: [(Ident, QualTypeExpr)] -> [Ident] -> Decl PredType
                  -> GAC [CFuncDecl]
trClassMethodDecl :: [(Ident, QualTypeExpr)]
-> [Ident]
-> Decl PredType
-> StateT AbstractEnv Identity [CFuncDecl]
trClassMethodDecl sigs :: [(Ident, QualTypeExpr)]
sigs fs :: [Ident]
fs (TypeSig p :: SpanInfo
p [f :: Ident
f] _) | Ident
f Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
fs =
  [(Ident, QualTypeExpr)]
-> [Ident]
-> Decl PredType
-> StateT AbstractEnv Identity [CFuncDecl]
trClassMethodDecl [(Ident, QualTypeExpr)]
sigs [Ident]
fs (Decl PredType -> StateT AbstractEnv Identity [CFuncDecl])
-> Decl PredType -> StateT AbstractEnv Identity [CFuncDecl]
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
forall a. HasCallStack => a
undefined Ident
f []
trClassMethodDecl sigs :: [(Ident, QualTypeExpr)]
sigs fs :: [Ident]
fs (TypeSig p :: SpanInfo
p (f :: Ident
f:f' :: Ident
f':fs' :: [Ident]
fs') qty :: QualTypeExpr
qty) =
  ([CFuncDecl] -> [CFuncDecl] -> [CFuncDecl])
-> StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity [CFuncDecl]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [CFuncDecl] -> [CFuncDecl] -> [CFuncDecl]
forall a. [a] -> [a] -> [a]
(++) ([(Ident, QualTypeExpr)]
-> [Ident]
-> Decl PredType
-> StateT AbstractEnv Identity [CFuncDecl]
trClassMethodDecl [(Ident, QualTypeExpr)]
sigs [Ident]
fs (Decl PredType -> StateT AbstractEnv Identity [CFuncDecl])
-> Decl PredType -> StateT AbstractEnv Identity [CFuncDecl]
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [Ident] -> QualTypeExpr -> Decl PredType
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
p [Ident
f] QualTypeExpr
qty)
              ([(Ident, QualTypeExpr)]
-> [Ident]
-> Decl PredType
-> StateT AbstractEnv Identity [CFuncDecl]
trClassMethodDecl [(Ident, QualTypeExpr)]
sigs [Ident]
fs (Decl PredType -> StateT AbstractEnv Identity [CFuncDecl])
-> Decl PredType -> StateT AbstractEnv Identity [CFuncDecl]
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [Ident] -> QualTypeExpr -> Decl PredType
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
p (Ident
f'Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
fs') QualTypeExpr
qty)
trClassMethodDecl sigs :: [(Ident, QualTypeExpr)]
sigs _ (FunctionDecl _ _ f :: Ident
f eqs :: [Equation PredType]
eqs) =
  (\f' :: QName
f' a :: Arity
a v :: CVisibility
v ty :: CQualTypeExpr
ty rs :: [CRule]
rs -> [QName
-> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl
CFunc QName
f' Arity
a CVisibility
v CQualTypeExpr
ty [CRule]
rs]) (QName
 -> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
f
  StateT
  AbstractEnv
  Identity
  (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity Arity
-> StateT
     AbstractEnv
     Identity
     (CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arity -> StateT AbstractEnv Identity Arity
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arity
-> (Equation PredType -> Arity)
-> Maybe (Equation PredType)
-> Arity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 Equation PredType -> Arity
forall a. Equation a -> Arity
eqnArity (Maybe (Equation PredType) -> Arity)
-> Maybe (Equation PredType) -> Arity
forall a b. (a -> b) -> a -> b
$ [Equation PredType] -> Maybe (Equation PredType)
forall a. [a] -> Maybe a
Maybe.listToMaybe [Equation PredType]
eqs)
  StateT
  AbstractEnv
  Identity
  (CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv Identity (CQualTypeExpr -> [CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility (Ident -> Ident
unRenameIdent Ident
f)
  StateT
  AbstractEnv Identity (CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity CQualTypeExpr
-> StateT AbstractEnv Identity ([CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
trQualTypeExpr (Maybe QualTypeExpr -> QualTypeExpr
forall a. HasCallStack => Maybe a -> a
Maybe.fromJust (Maybe QualTypeExpr -> QualTypeExpr)
-> Maybe QualTypeExpr -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$ Ident -> [(Ident, QualTypeExpr)] -> Maybe QualTypeExpr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
f [(Ident, QualTypeExpr)]
sigs) StateT AbstractEnv Identity ([CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity [CRule]
-> StateT AbstractEnv Identity [CFuncDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Equation PredType -> StateT AbstractEnv Identity CRule)
-> [Equation PredType] -> StateT AbstractEnv Identity [CRule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation PredType -> StateT AbstractEnv Identity CRule
trEquation [Equation PredType]
eqs
trClassMethodDecl _ _ _ = [CFuncDecl] -> StateT AbstractEnv Identity [CFuncDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

trInstanceDecl :: Decl PredType -> GAC [CInstanceDecl]
trInstanceDecl :: Decl PredType -> StateT AbstractEnv Identity [CInstanceDecl]
trInstanceDecl (InstanceDecl _ _ cx :: Context
cx qcls :: QualIdent
qcls ty :: TypeExpr
ty ds :: [Decl PredType]
ds) =
  (\qcls' :: QName
qcls' cx' :: CContext
cx' ty' :: CTypeExpr
ty' ds' :: [CFuncDecl]
ds' -> [QName -> CContext -> CTypeExpr -> [CFuncDecl] -> CInstanceDecl
CInstance QName
qcls' CContext
cx' CTypeExpr
ty' [CFuncDecl]
ds']) (QName -> CContext -> CTypeExpr -> [CFuncDecl] -> [CInstanceDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (CContext -> CTypeExpr -> [CFuncDecl] -> [CInstanceDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
qcls
  StateT
  AbstractEnv
  Identity
  (CContext -> CTypeExpr -> [CFuncDecl] -> [CInstanceDecl])
-> StateT AbstractEnv Identity CContext
-> StateT
     AbstractEnv Identity (CTypeExpr -> [CFuncDecl] -> [CInstanceDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Context -> StateT AbstractEnv Identity CContext
trContext Context
cx StateT
  AbstractEnv Identity (CTypeExpr -> [CFuncDecl] -> [CInstanceDecl])
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity ([CFuncDecl] -> [CInstanceDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty StateT AbstractEnv Identity ([CFuncDecl] -> [CInstanceDecl])
-> StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity [CInstanceDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Decl PredType -> StateT AbstractEnv Identity CFuncDecl)
-> [Decl PredType] -> StateT AbstractEnv Identity [CFuncDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (QualIdent
-> TypeExpr
-> Decl PredType
-> StateT AbstractEnv Identity CFuncDecl
trInstanceMethodDecl QualIdent
qcls TypeExpr
ty) [Decl PredType]
ds
trInstanceDecl _ = [CInstanceDecl] -> StateT AbstractEnv Identity [CInstanceDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Again, we use the equation's arity for function declarations instead of
-- the one from the value.
trInstanceMethodDecl :: QualIdent -> TypeExpr -> Decl PredType -> GAC CFuncDecl
trInstanceMethodDecl :: QualIdent
-> TypeExpr
-> Decl PredType
-> StateT AbstractEnv Identity CFuncDecl
trInstanceMethodDecl qcls :: QualIdent
qcls ty :: TypeExpr
ty (FunctionDecl _ _ f :: Ident
f eqs :: [Equation PredType]
eqs) = do
  Bool
uacy <- (AbstractEnv -> Bool) -> StateT AbstractEnv Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> Bool
untypedAcy
  QualTypeExpr
qty <- if Bool
uacy
           then QualTypeExpr -> StateT AbstractEnv Identity QualTypeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (QualTypeExpr -> StateT AbstractEnv Identity QualTypeExpr)
-> QualTypeExpr -> StateT AbstractEnv Identity QualTypeExpr
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo [] (TypeExpr -> QualTypeExpr) -> TypeExpr -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$
                           SpanInfo -> QualIdent -> TypeExpr
ConstructorType SpanInfo
NoSpanInfo QualIdent
prelUntyped
           else QualIdent -> StateT AbstractEnv Identity QualTypeExpr
getQualType' (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
qcls (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Ident -> Ident
unRenameIdent Ident
f)
  QName
-> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl
CFunc (QName
 -> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trLocalIdent Ident
f StateT
  AbstractEnv
  Identity
  (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity Arity
-> StateT
     AbstractEnv
     Identity
     (CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arity -> StateT AbstractEnv Identity Arity
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Equation PredType -> Arity
forall a. Equation a -> Arity
eqnArity (Equation PredType -> Arity) -> Equation PredType -> Arity
forall a b. (a -> b) -> a -> b
$ [Equation PredType] -> Equation PredType
forall a. [a] -> a
head [Equation PredType]
eqs) StateT
  AbstractEnv
  Identity
  (CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv Identity (CQualTypeExpr -> [CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CVisibility -> StateT AbstractEnv Identity CVisibility
forall (f :: * -> *) a. Applicative f => a -> f a
pure CVisibility
Public
        StateT AbstractEnv Identity (CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity CQualTypeExpr
-> StateT AbstractEnv Identity ([CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr
-> QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
trInstanceMethodType TypeExpr
ty QualTypeExpr
qty StateT AbstractEnv Identity ([CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity [CRule]
-> StateT AbstractEnv Identity CFuncDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Equation PredType -> StateT AbstractEnv Identity CRule)
-> [Equation PredType] -> StateT AbstractEnv Identity [CRule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation PredType -> StateT AbstractEnv Identity CRule
trEquation [Equation PredType]
eqs
trInstanceMethodDecl _ _ _ = MName -> StateT AbstractEnv Identity CFuncDecl
forall a. MName -> a
internalError "GenAbstractCurry.trInstanceMethodDecl"

-- Transforms a class method type into an instance method's type by replacing
-- the class variable with the given instance type. The implicit class context
-- is dropped in doing so.
trInstanceMethodType :: TypeExpr -> QualTypeExpr -> GAC CQualTypeExpr
trInstanceMethodType :: TypeExpr
-> QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
trInstanceMethodType ity :: TypeExpr
ity (QualTypeExpr _ cx :: Context
cx ty :: TypeExpr
ty) =
  QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
trQualTypeExpr (QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr)
-> QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
forall a b. (a -> b) -> a -> b
$ [Ident] -> PredType -> QualTypeExpr
fromPredType [Ident]
identSupply (PredType -> QualTypeExpr) -> PredType -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$
    TypeSubst -> PredType -> PredType
forall a. SubstType a => TypeSubst -> a -> a
subst (Arity -> Type -> TypeSubst -> TypeSubst
forall v e. Ord v => v -> e -> Subst v e -> Subst v e
bindSubst 0 ([Ident] -> TypeExpr -> Type
toType [] TypeExpr
ity) TypeSubst
forall a b. Subst a b
idSubst) (PredType -> PredType) -> PredType -> PredType
forall a b. (a -> b) -> a -> b
$
      [Ident] -> QualTypeExpr -> PredType
toPredType (Arity -> [Ident] -> [Ident]
forall a. Arity -> [a] -> [a]
take 1 [Ident]
identSupply) (QualTypeExpr -> PredType) -> QualTypeExpr -> PredType
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo (Arity -> Context -> Context
forall a. Arity -> [a] -> [a]
drop 1 Context
cx) TypeExpr
ty

trTypeDecl :: Decl a -> GAC [CTypeDecl]
trTypeDecl :: Decl a -> StateT AbstractEnv Identity [CTypeDecl]
trTypeDecl (DataDecl    _ t :: Ident
t vs :: [Ident]
vs cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss) =
  (\t' :: QName
t' v :: CVisibility
v vs' :: [CTVarIName]
vs' cs' :: [CConsDecl]
cs' clss' :: [QName]
clss' -> [QName
-> CVisibility
-> [CTVarIName]
-> [CConsDecl]
-> [QName]
-> CTypeDecl
CType QName
t' CVisibility
v [CTVarIName]
vs' [CConsDecl]
cs' [QName]
clss'])
  (QName
 -> CVisibility
 -> [CTVarIName]
 -> [CConsDecl]
 -> [QName]
 -> [CTypeDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (CVisibility
      -> [CTVarIName] -> [CConsDecl] -> [QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
t StateT
  AbstractEnv
  Identity
  (CVisibility
   -> [CTVarIName] -> [CConsDecl] -> [QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv
     Identity
     ([CTVarIName] -> [CConsDecl] -> [QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getTypeVisibility Ident
t
  StateT
  AbstractEnv
  Identity
  ([CTVarIName] -> [CConsDecl] -> [QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity [CTVarIName]
-> StateT
     AbstractEnv Identity ([CConsDecl] -> [QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Ident -> StateT AbstractEnv Identity CTVarIName)
-> [Ident] -> StateT AbstractEnv Identity [CTVarIName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT AbstractEnv Identity CTVarIName
genTVarIndex [Ident]
vs StateT AbstractEnv Identity ([CConsDecl] -> [QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity [CConsDecl]
-> StateT AbstractEnv Identity ([QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ConstrDecl -> StateT AbstractEnv Identity CConsDecl)
-> [ConstrDecl] -> StateT AbstractEnv Identity [CConsDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstrDecl -> StateT AbstractEnv Identity CConsDecl
trConsDecl [ConstrDecl]
cs
  StateT AbstractEnv Identity ([QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity [QName]
-> StateT AbstractEnv Identity [CTypeDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QualIdent -> StateT AbstractEnv Identity QName)
-> [QualIdent] -> StateT AbstractEnv Identity [QName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualIdent -> StateT AbstractEnv Identity QName
trQual [QualIdent]
clss
trTypeDecl (TypeDecl    _ t :: Ident
t vs :: [Ident]
vs ty :: TypeExpr
ty) = (\t' :: QName
t' v :: CVisibility
v vs' :: [CTVarIName]
vs' ty' :: CTypeExpr
ty' -> [QName -> CVisibility -> [CTVarIName] -> CTypeExpr -> CTypeDecl
CTypeSyn QName
t' CVisibility
v [CTVarIName]
vs' CTypeExpr
ty'])
  (QName -> CVisibility -> [CTVarIName] -> CTypeExpr -> [CTypeDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (CVisibility -> [CTVarIName] -> CTypeExpr -> [CTypeDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
t StateT
  AbstractEnv
  Identity
  (CVisibility -> [CTVarIName] -> CTypeExpr -> [CTypeDecl])
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv Identity ([CTVarIName] -> CTypeExpr -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getTypeVisibility Ident
t
  StateT
  AbstractEnv Identity ([CTVarIName] -> CTypeExpr -> [CTypeDecl])
-> StateT AbstractEnv Identity [CTVarIName]
-> StateT AbstractEnv Identity (CTypeExpr -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Ident -> StateT AbstractEnv Identity CTVarIName)
-> [Ident] -> StateT AbstractEnv Identity [CTVarIName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT AbstractEnv Identity CTVarIName
genTVarIndex [Ident]
vs StateT AbstractEnv Identity (CTypeExpr -> [CTypeDecl])
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity [CTypeDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty
trTypeDecl (NewtypeDecl _ t :: Ident
t vs :: [Ident]
vs nc :: NewConstrDecl
nc clss :: [QualIdent]
clss) =
  (\t' :: QName
t' v :: CVisibility
v vs' :: [CTVarIName]
vs' nc' :: CConsDecl
nc' clss' :: [QName]
clss' -> [QName
-> CVisibility -> [CTVarIName] -> CConsDecl -> [QName] -> CTypeDecl
CNewType QName
t' CVisibility
v [CTVarIName]
vs' CConsDecl
nc' [QName]
clss'])
  (QName
 -> CVisibility
 -> [CTVarIName]
 -> CConsDecl
 -> [QName]
 -> [CTypeDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (CVisibility
      -> [CTVarIName] -> CConsDecl -> [QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
t StateT
  AbstractEnv
  Identity
  (CVisibility
   -> [CTVarIName] -> CConsDecl -> [QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv
     Identity
     ([CTVarIName] -> CConsDecl -> [QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getTypeVisibility Ident
t
  StateT
  AbstractEnv
  Identity
  ([CTVarIName] -> CConsDecl -> [QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity [CTVarIName]
-> StateT
     AbstractEnv Identity (CConsDecl -> [QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Ident -> StateT AbstractEnv Identity CTVarIName)
-> [Ident] -> StateT AbstractEnv Identity [CTVarIName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT AbstractEnv Identity CTVarIName
genTVarIndex [Ident]
vs StateT AbstractEnv Identity (CConsDecl -> [QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity CConsDecl
-> StateT AbstractEnv Identity ([QName] -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NewConstrDecl -> StateT AbstractEnv Identity CConsDecl
trNewConsDecl NewConstrDecl
nc
  StateT AbstractEnv Identity ([QName] -> [CTypeDecl])
-> StateT AbstractEnv Identity [QName]
-> StateT AbstractEnv Identity [CTypeDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QualIdent -> StateT AbstractEnv Identity QName)
-> [QualIdent] -> StateT AbstractEnv Identity [QName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM QualIdent -> StateT AbstractEnv Identity QName
trQual [QualIdent]
clss
trTypeDecl (ExternalDataDecl _ t :: Ident
t vs :: [Ident]
vs) =
  (\t' :: QName
t' v :: CVisibility
v vs' :: [CTVarIName]
vs' -> [QName
-> CVisibility
-> [CTVarIName]
-> [CConsDecl]
-> [QName]
-> CTypeDecl
CType QName
t' CVisibility
v [CTVarIName]
vs' [] []])
  (QName -> CVisibility -> [CTVarIName] -> [CTypeDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv Identity (CVisibility -> [CTVarIName] -> [CTypeDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
t StateT
  AbstractEnv Identity (CVisibility -> [CTVarIName] -> [CTypeDecl])
-> StateT AbstractEnv Identity CVisibility
-> StateT AbstractEnv Identity ([CTVarIName] -> [CTypeDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getTypeVisibility Ident
t StateT AbstractEnv Identity ([CTVarIName] -> [CTypeDecl])
-> StateT AbstractEnv Identity [CTVarIName]
-> StateT AbstractEnv Identity [CTypeDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Ident -> StateT AbstractEnv Identity CTVarIName)
-> [Ident] -> StateT AbstractEnv Identity [CTVarIName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT AbstractEnv Identity CTVarIName
genTVarIndex [Ident]
vs
trTypeDecl _                       = [CTypeDecl] -> StateT AbstractEnv Identity [CTypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

trConsDecl :: ConstrDecl -> GAC CConsDecl
trConsDecl :: ConstrDecl -> StateT AbstractEnv Identity CConsDecl
trConsDecl (ConstrDecl  _ c :: Ident
c tys :: [TypeExpr]
tys) = StateT AbstractEnv Identity CConsDecl
-> StateT AbstractEnv Identity CConsDecl
forall a. GAC a -> GAC a
inNestedTScope (StateT AbstractEnv Identity CConsDecl
 -> StateT AbstractEnv Identity CConsDecl)
-> StateT AbstractEnv Identity CConsDecl
-> StateT AbstractEnv Identity CConsDecl
forall a b. (a -> b) -> a -> b
$ QName -> CVisibility -> [CTypeExpr] -> CConsDecl
CCons
  (QName -> CVisibility -> [CTypeExpr] -> CConsDecl)
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv Identity (CVisibility -> [CTypeExpr] -> CConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
c StateT
  AbstractEnv Identity (CVisibility -> [CTypeExpr] -> CConsDecl)
-> StateT AbstractEnv Identity CVisibility
-> StateT AbstractEnv Identity ([CTypeExpr] -> CConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility Ident
c StateT AbstractEnv Identity ([CTypeExpr] -> CConsDecl)
-> StateT AbstractEnv Identity [CTypeExpr]
-> StateT AbstractEnv Identity CConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeExpr -> StateT AbstractEnv Identity CTypeExpr)
-> [TypeExpr] -> StateT AbstractEnv Identity [CTypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr [TypeExpr]
tys
trConsDecl (ConOpDecl p :: SpanInfo
p ty1 :: TypeExpr
ty1 op :: Ident
op ty2 :: TypeExpr
ty2) = StateT AbstractEnv Identity CConsDecl
-> StateT AbstractEnv Identity CConsDecl
forall a. GAC a -> GAC a
inNestedTScope (StateT AbstractEnv Identity CConsDecl
 -> StateT AbstractEnv Identity CConsDecl)
-> StateT AbstractEnv Identity CConsDecl
-> StateT AbstractEnv Identity CConsDecl
forall a b. (a -> b) -> a -> b
$ ConstrDecl -> StateT AbstractEnv Identity CConsDecl
trConsDecl (ConstrDecl -> StateT AbstractEnv Identity CConsDecl)
-> ConstrDecl -> StateT AbstractEnv Identity CConsDecl
forall a b. (a -> b) -> a -> b
$
  SpanInfo -> Ident -> [TypeExpr] -> ConstrDecl
ConstrDecl SpanInfo
p Ident
op [TypeExpr
ty1, TypeExpr
ty2]
trConsDecl (RecordDecl   _ c :: Ident
c fs :: [FieldDecl]
fs) = StateT AbstractEnv Identity CConsDecl
-> StateT AbstractEnv Identity CConsDecl
forall a. GAC a -> GAC a
inNestedTScope (StateT AbstractEnv Identity CConsDecl
 -> StateT AbstractEnv Identity CConsDecl)
-> StateT AbstractEnv Identity CConsDecl
-> StateT AbstractEnv Identity CConsDecl
forall a b. (a -> b) -> a -> b
$ QName -> CVisibility -> [CFieldDecl] -> CConsDecl
CRecord
  (QName -> CVisibility -> [CFieldDecl] -> CConsDecl)
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv Identity (CVisibility -> [CFieldDecl] -> CConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
c StateT
  AbstractEnv Identity (CVisibility -> [CFieldDecl] -> CConsDecl)
-> StateT AbstractEnv Identity CVisibility
-> StateT AbstractEnv Identity ([CFieldDecl] -> CConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility Ident
c StateT AbstractEnv Identity ([CFieldDecl] -> CConsDecl)
-> StateT AbstractEnv Identity [CFieldDecl]
-> StateT AbstractEnv Identity CConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FieldDecl -> StateT AbstractEnv Identity [CFieldDecl])
-> [FieldDecl] -> StateT AbstractEnv Identity [CFieldDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM FieldDecl -> StateT AbstractEnv Identity [CFieldDecl]
trFieldDecl [FieldDecl]
fs

trFieldDecl :: FieldDecl -> GAC [CFieldDecl]
trFieldDecl :: FieldDecl -> StateT AbstractEnv Identity [CFieldDecl]
trFieldDecl (FieldDecl _ ls :: [Ident]
ls ty :: TypeExpr
ty) = [Ident]
-> (Ident -> StateT AbstractEnv Identity CFieldDecl)
-> StateT AbstractEnv Identity [CFieldDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM [Ident]
ls ((Ident -> StateT AbstractEnv Identity CFieldDecl)
 -> StateT AbstractEnv Identity [CFieldDecl])
-> (Ident -> StateT AbstractEnv Identity CFieldDecl)
-> StateT AbstractEnv Identity [CFieldDecl]
forall a b. (a -> b) -> a -> b
$ \l :: Ident
l ->
  QName -> CVisibility -> CTypeExpr -> CFieldDecl
CField (QName -> CVisibility -> CTypeExpr -> CFieldDecl)
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv Identity (CVisibility -> CTypeExpr -> CFieldDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
l StateT
  AbstractEnv Identity (CVisibility -> CTypeExpr -> CFieldDecl)
-> StateT AbstractEnv Identity CVisibility
-> StateT AbstractEnv Identity (CTypeExpr -> CFieldDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility Ident
l StateT AbstractEnv Identity (CTypeExpr -> CFieldDecl)
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity CFieldDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty

trNewConsDecl :: NewConstrDecl -> GAC CConsDecl
trNewConsDecl :: NewConstrDecl -> StateT AbstractEnv Identity CConsDecl
trNewConsDecl (NewConstrDecl _ nc :: Ident
nc      ty :: TypeExpr
ty) = QName -> CVisibility -> [CTypeExpr] -> CConsDecl
CCons
  (QName -> CVisibility -> [CTypeExpr] -> CConsDecl)
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv Identity (CVisibility -> [CTypeExpr] -> CConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
nc StateT
  AbstractEnv Identity (CVisibility -> [CTypeExpr] -> CConsDecl)
-> StateT AbstractEnv Identity CVisibility
-> StateT AbstractEnv Identity ([CTypeExpr] -> CConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility Ident
nc StateT AbstractEnv Identity ([CTypeExpr] -> CConsDecl)
-> StateT AbstractEnv Identity [CTypeExpr]
-> StateT AbstractEnv Identity CConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((CTypeExpr -> [CTypeExpr] -> [CTypeExpr]
forall a. a -> [a] -> [a]
:[]) (CTypeExpr -> [CTypeExpr])
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity [CTypeExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty)
trNewConsDecl (NewRecordDecl p :: SpanInfo
p nc :: Ident
nc (l :: Ident
l, ty :: TypeExpr
ty)) = QName -> CVisibility -> [CFieldDecl] -> CConsDecl
CRecord
  (QName -> CVisibility -> [CFieldDecl] -> CConsDecl)
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv Identity (CVisibility -> [CFieldDecl] -> CConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
nc StateT
  AbstractEnv Identity (CVisibility -> [CFieldDecl] -> CConsDecl)
-> StateT AbstractEnv Identity CVisibility
-> StateT AbstractEnv Identity ([CFieldDecl] -> CConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility Ident
nc StateT AbstractEnv Identity ([CFieldDecl] -> CConsDecl)
-> StateT AbstractEnv Identity [CFieldDecl]
-> StateT AbstractEnv Identity CConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FieldDecl -> StateT AbstractEnv Identity [CFieldDecl]
trFieldDecl (SpanInfo -> [Ident] -> TypeExpr -> FieldDecl
FieldDecl SpanInfo
p [Ident
l] TypeExpr
ty)

trTypeExpr :: TypeExpr -> GAC CTypeExpr
trTypeExpr :: TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr (ConstructorType _ q :: QualIdent
q) = QName -> CTypeExpr
CTCons (QName -> CTypeExpr)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity CTypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
q
trTypeExpr (ApplyType _ ty1 :: TypeExpr
ty1 ty2 :: TypeExpr
ty2) = CTypeExpr -> CTypeExpr -> CTypeExpr
CTApply (CTypeExpr -> CTypeExpr -> CTypeExpr)
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity (CTypeExpr -> CTypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty1 StateT AbstractEnv Identity (CTypeExpr -> CTypeExpr)
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity CTypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty2
trTypeExpr (VariableType    _ v :: Ident
v) = CTVarIName -> CTypeExpr
CTVar  (CTVarIName -> CTypeExpr)
-> StateT AbstractEnv Identity CTVarIName
-> StateT AbstractEnv Identity CTypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity CTVarIName
getTVarIndex Ident
v
trTypeExpr (TupleType     _ tys :: [TypeExpr]
tys) =
  TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr (TypeExpr -> StateT AbstractEnv Identity CTypeExpr)
-> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
forall a b. (a -> b) -> a -> b
$ (TypeExpr -> TypeExpr -> TypeExpr)
-> TypeExpr -> [TypeExpr] -> TypeExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (SpanInfo -> TypeExpr -> TypeExpr -> TypeExpr
ApplyType SpanInfo
NoSpanInfo)
                     (SpanInfo -> QualIdent -> TypeExpr
ConstructorType SpanInfo
NoSpanInfo (QualIdent -> TypeExpr) -> QualIdent -> TypeExpr
forall a b. (a -> b) -> a -> b
$ Arity -> QualIdent
qTupleId (Arity -> QualIdent) -> Arity -> QualIdent
forall a b. (a -> b) -> a -> b
$ [TypeExpr] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [TypeExpr]
tys) [TypeExpr]
tys
trTypeExpr (ListType       _ ty :: TypeExpr
ty) =
  TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr (TypeExpr -> StateT AbstractEnv Identity CTypeExpr)
-> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
forall a b. (a -> b) -> a -> b
$ SpanInfo -> TypeExpr -> TypeExpr -> TypeExpr
ApplyType SpanInfo
NoSpanInfo (SpanInfo -> QualIdent -> TypeExpr
ConstructorType SpanInfo
NoSpanInfo QualIdent
qListId) TypeExpr
ty
trTypeExpr (ArrowType _ ty1 :: TypeExpr
ty1 ty2 :: TypeExpr
ty2) = CTypeExpr -> CTypeExpr -> CTypeExpr
CFuncType (CTypeExpr -> CTypeExpr -> CTypeExpr)
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity (CTypeExpr -> CTypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty1 StateT AbstractEnv Identity (CTypeExpr -> CTypeExpr)
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity CTypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty2
trTypeExpr (ParenType      _ ty :: TypeExpr
ty) = TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty
trTypeExpr (ForallType    _ _ _) = MName -> StateT AbstractEnv Identity CTypeExpr
forall a. MName -> a
internalError "GenAbstractCurry.trTypeExpr"

trConstraint :: Constraint -> GAC CConstraint
trConstraint :: Constraint -> GAC CConstraint
trConstraint (Constraint _ q :: QualIdent
q ty :: TypeExpr
ty) = (,) (QName -> CTypeExpr -> CConstraint)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity (CTypeExpr -> CConstraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
q StateT AbstractEnv Identity (CTypeExpr -> CConstraint)
-> StateT AbstractEnv Identity CTypeExpr -> GAC CConstraint
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty

trContext :: Context -> GAC CContext
trContext :: Context -> StateT AbstractEnv Identity CContext
trContext cx :: Context
cx = [CConstraint] -> CContext
CContext ([CConstraint] -> CContext)
-> StateT AbstractEnv Identity [CConstraint]
-> StateT AbstractEnv Identity CContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Constraint -> GAC CConstraint)
-> Context -> StateT AbstractEnv Identity [CConstraint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Constraint -> GAC CConstraint
trConstraint Context
cx

trQualTypeExpr :: QualTypeExpr -> GAC CQualTypeExpr
trQualTypeExpr :: QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
trQualTypeExpr (QualTypeExpr _ cx :: Context
cx ty :: TypeExpr
ty) =
  CContext -> CTypeExpr -> CQualTypeExpr
CQualType (CContext -> CTypeExpr -> CQualTypeExpr)
-> StateT AbstractEnv Identity CContext
-> StateT AbstractEnv Identity (CTypeExpr -> CQualTypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> StateT AbstractEnv Identity CContext
trContext Context
cx StateT AbstractEnv Identity (CTypeExpr -> CQualTypeExpr)
-> StateT AbstractEnv Identity CTypeExpr
-> StateT AbstractEnv Identity CQualTypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> StateT AbstractEnv Identity CTypeExpr
trTypeExpr TypeExpr
ty

trInfixDecl :: Decl a -> GAC [COpDecl]
trInfixDecl :: Decl a -> StateT AbstractEnv Identity [COpDecl]
trInfixDecl (InfixDecl _ fix :: Infix
fix mprec :: Maybe Precedence
mprec ops :: [Ident]
ops) = (Ident -> StateT AbstractEnv Identity COpDecl)
-> [Ident] -> StateT AbstractEnv Identity [COpDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT AbstractEnv Identity COpDecl
trInfix ([Ident] -> [Ident]
forall a. [a] -> [a]
reverse [Ident]
ops)
  where
  trInfix :: Ident -> StateT AbstractEnv Identity COpDecl
trInfix op :: Ident
op = QName -> CFixity -> Arity -> COpDecl
COp (QName -> CFixity -> Arity -> COpDecl)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity (CFixity -> Arity -> COpDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity QName
trGlobalIdent Ident
op StateT AbstractEnv Identity (CFixity -> Arity -> COpDecl)
-> StateT AbstractEnv Identity CFixity
-> StateT AbstractEnv Identity (Arity -> COpDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CFixity -> StateT AbstractEnv Identity CFixity
forall (m :: * -> *) a. Monad m => a -> m a
return (Infix -> CFixity
cvFixity Infix
fix)
                   StateT AbstractEnv Identity (Arity -> COpDecl)
-> StateT AbstractEnv Identity Arity
-> StateT AbstractEnv Identity COpDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arity -> StateT AbstractEnv Identity Arity
forall (m :: * -> *) a. Monad m => a -> m a
return (Precedence -> Arity
forall a. Num a => Precedence -> a
fromInteger (Maybe Precedence -> Precedence
mkPrec Maybe Precedence
mprec))
  cvFixity :: Infix -> CFixity
cvFixity InfixL = CFixity
CInfixlOp
  cvFixity InfixR = CFixity
CInfixrOp
  cvFixity Infix  = CFixity
CInfixOp
trInfixDecl _ = [COpDecl] -> StateT AbstractEnv Identity [COpDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

trFuncDecl :: Bool -> Decl PredType -> GAC [CFuncDecl]
trFuncDecl :: Bool -> Decl PredType -> StateT AbstractEnv Identity [CFuncDecl]
trFuncDecl global :: Bool
global (FunctionDecl  _ pty :: PredType
pty f :: Ident
f eqs :: [Equation PredType]
eqs)
  =   (\f' :: QName
f' a :: Arity
a v :: CVisibility
v ty :: CQualTypeExpr
ty rs :: [CRule]
rs -> [QName
-> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl
CFunc QName
f' Arity
a CVisibility
v CQualTypeExpr
ty [CRule]
rs])
  (QName
 -> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Ident -> StateT AbstractEnv Identity QName
trFuncName Bool
global Ident
f StateT
  AbstractEnv
  Identity
  (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity Arity
-> StateT
     AbstractEnv
     Identity
     (CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arity -> StateT AbstractEnv Identity Arity
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Equation PredType -> Arity
forall a. Equation a -> Arity
eqnArity (Equation PredType -> Arity) -> Equation PredType -> Arity
forall a b. (a -> b) -> a -> b
$ [Equation PredType] -> Equation PredType
forall a. [a] -> a
head [Equation PredType]
eqs) StateT
  AbstractEnv
  Identity
  (CVisibility -> CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv Identity (CQualTypeExpr -> [CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility Ident
f
  StateT
  AbstractEnv Identity (CQualTypeExpr -> [CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity CQualTypeExpr
-> StateT AbstractEnv Identity ([CRule] -> [CFuncDecl])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> PredType -> StateT AbstractEnv Identity CQualTypeExpr
getQualType Ident
f PredType
pty StateT AbstractEnv Identity ([CRule] -> [CFuncDecl])
-> StateT AbstractEnv Identity [CRule]
-> StateT AbstractEnv Identity [CFuncDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Equation PredType -> StateT AbstractEnv Identity CRule)
-> [Equation PredType] -> StateT AbstractEnv Identity [CRule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation PredType -> StateT AbstractEnv Identity CRule
trEquation [Equation PredType]
eqs
trFuncDecl global :: Bool
global (ExternalDecl         _ vs :: [Var PredType]
vs)
  =   [Var PredType]
-> (Var PredType -> StateT AbstractEnv Identity CFuncDecl)
-> StateT AbstractEnv Identity [CFuncDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM [Var PredType]
vs ((Var PredType -> StateT AbstractEnv Identity CFuncDecl)
 -> StateT AbstractEnv Identity [CFuncDecl])
-> (Var PredType -> StateT AbstractEnv Identity CFuncDecl)
-> StateT AbstractEnv Identity [CFuncDecl]
forall a b. (a -> b) -> a -> b
$ \(Var pty :: PredType
pty f :: Ident
f) -> QName
-> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl
CFunc
  (QName
 -> Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity QName
-> StateT
     AbstractEnv
     Identity
     (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Ident -> StateT AbstractEnv Identity QName
trFuncName Bool
global Ident
f StateT
  AbstractEnv
  Identity
  (Arity -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity Arity
-> StateT
     AbstractEnv
     Identity
     (CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arity -> StateT AbstractEnv Identity Arity
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Arity
arrowArity (Type -> Arity) -> Type -> Arity
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty)
  StateT
  AbstractEnv
  Identity
  (CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity CVisibility
-> StateT
     AbstractEnv Identity (CQualTypeExpr -> [CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT AbstractEnv Identity CVisibility
getVisibility Ident
f StateT AbstractEnv Identity (CQualTypeExpr -> [CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity CQualTypeExpr
-> StateT AbstractEnv Identity ([CRule] -> CFuncDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> PredType -> StateT AbstractEnv Identity CQualTypeExpr
getQualType Ident
f PredType
pty StateT AbstractEnv Identity ([CRule] -> CFuncDecl)
-> StateT AbstractEnv Identity [CRule]
-> StateT AbstractEnv Identity CFuncDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [CRule] -> StateT AbstractEnv Identity [CRule]
forall (m :: * -> *) a. Monad m => a -> m a
return []
trFuncDecl _      _                           = [CFuncDecl] -> StateT AbstractEnv Identity [CFuncDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []

trFuncName :: Bool -> Ident -> GAC QName
trFuncName :: Bool -> Ident -> StateT AbstractEnv Identity QName
trFuncName global :: Bool
global = if Bool
global then Ident -> StateT AbstractEnv Identity QName
trGlobalIdent else Ident -> StateT AbstractEnv Identity QName
trLocalIdent

trEquation :: Equation PredType -> GAC CRule
trEquation :: Equation PredType -> StateT AbstractEnv Identity CRule
trEquation (Equation _ lhs :: Lhs PredType
lhs rhs :: Rhs PredType
rhs) = StateT AbstractEnv Identity CRule
-> StateT AbstractEnv Identity CRule
forall a. GAC a -> GAC a
inNestedScope
                                (StateT AbstractEnv Identity CRule
 -> StateT AbstractEnv Identity CRule)
-> StateT AbstractEnv Identity CRule
-> StateT AbstractEnv Identity CRule
forall a b. (a -> b) -> a -> b
$ [CPattern] -> CRhs -> CRule
CRule ([CPattern] -> CRhs -> CRule)
-> StateT AbstractEnv Identity [CPattern]
-> StateT AbstractEnv Identity (CRhs -> CRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lhs PredType -> StateT AbstractEnv Identity [CPattern]
forall a. Lhs a -> StateT AbstractEnv Identity [CPattern]
trLhs Lhs PredType
lhs StateT AbstractEnv Identity (CRhs -> CRule)
-> StateT AbstractEnv Identity CRhs
-> StateT AbstractEnv Identity CRule
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs PredType -> StateT AbstractEnv Identity CRhs
trRhs Rhs PredType
rhs

trLhs :: Lhs a -> GAC [CPattern]
trLhs :: Lhs a -> StateT AbstractEnv Identity [CPattern]
trLhs = (Pattern a -> StateT AbstractEnv Identity CPattern)
-> [Pattern a] -> StateT AbstractEnv Identity [CPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat ([Pattern a] -> StateT AbstractEnv Identity [CPattern])
-> (Lhs a -> [Pattern a])
-> Lhs a
-> StateT AbstractEnv Identity [CPattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, [Pattern a]) -> [Pattern a]
forall a b. (a, b) -> b
snd ((Ident, [Pattern a]) -> [Pattern a])
-> (Lhs a -> (Ident, [Pattern a])) -> Lhs a -> [Pattern a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lhs a -> (Ident, [Pattern a])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs

trRhs :: Rhs PredType -> GAC CRhs
trRhs :: Rhs PredType -> StateT AbstractEnv Identity CRhs
trRhs (SimpleRhs _ _ e :: Expression PredType
e ds :: [Decl PredType]
ds) = StateT AbstractEnv Identity CRhs
-> StateT AbstractEnv Identity CRhs
forall a. GAC a -> GAC a
inNestedScope (StateT AbstractEnv Identity CRhs
 -> StateT AbstractEnv Identity CRhs)
-> StateT AbstractEnv Identity CRhs
-> StateT AbstractEnv Identity CRhs
forall a b. (a -> b) -> a -> b
$ do
  (Decl PredType -> StateT AbstractEnv Identity ())
-> [Decl PredType] -> StateT AbstractEnv Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl PredType -> StateT AbstractEnv Identity ()
forall a. Decl a -> StateT AbstractEnv Identity ()
insertDeclLhs [Decl PredType]
ds
  CExpr -> [CLocalDecl] -> CRhs
CSimpleRhs (CExpr -> [CLocalDecl] -> CRhs)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity ([CLocalDecl] -> CRhs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e StateT AbstractEnv Identity ([CLocalDecl] -> CRhs)
-> StateT AbstractEnv Identity [CLocalDecl]
-> StateT AbstractEnv Identity CRhs
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Decl PredType -> StateT AbstractEnv Identity [CLocalDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CLocalDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> StateT AbstractEnv Identity [CLocalDecl]
trLocalDecl [Decl PredType]
ds
trRhs (GuardedRhs _ _ gs :: [CondExpr PredType]
gs ds :: [Decl PredType]
ds) = StateT AbstractEnv Identity CRhs
-> StateT AbstractEnv Identity CRhs
forall a. GAC a -> GAC a
inNestedScope (StateT AbstractEnv Identity CRhs
 -> StateT AbstractEnv Identity CRhs)
-> StateT AbstractEnv Identity CRhs
-> StateT AbstractEnv Identity CRhs
forall a b. (a -> b) -> a -> b
$ do
  (Decl PredType -> StateT AbstractEnv Identity ())
-> [Decl PredType] -> StateT AbstractEnv Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl PredType -> StateT AbstractEnv Identity ()
forall a. Decl a -> StateT AbstractEnv Identity ()
insertDeclLhs [Decl PredType]
ds
  [(CExpr, CExpr)] -> [CLocalDecl] -> CRhs
CGuardedRhs ([(CExpr, CExpr)] -> [CLocalDecl] -> CRhs)
-> StateT AbstractEnv Identity [(CExpr, CExpr)]
-> StateT AbstractEnv Identity ([CLocalDecl] -> CRhs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CondExpr PredType -> StateT AbstractEnv Identity (CExpr, CExpr))
-> [CondExpr PredType]
-> StateT AbstractEnv Identity [(CExpr, CExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CondExpr PredType -> StateT AbstractEnv Identity (CExpr, CExpr)
trCondExpr [CondExpr PredType]
gs StateT AbstractEnv Identity ([CLocalDecl] -> CRhs)
-> StateT AbstractEnv Identity [CLocalDecl]
-> StateT AbstractEnv Identity CRhs
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Decl PredType -> StateT AbstractEnv Identity [CLocalDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CLocalDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> StateT AbstractEnv Identity [CLocalDecl]
trLocalDecl [Decl PredType]
ds

trCondExpr :: CondExpr PredType -> GAC (CExpr, CExpr)
trCondExpr :: CondExpr PredType -> StateT AbstractEnv Identity (CExpr, CExpr)
trCondExpr (CondExpr _ g :: Expression PredType
g e :: Expression PredType
e) = (,) (CExpr -> CExpr -> (CExpr, CExpr))
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity (CExpr -> (CExpr, CExpr))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
g StateT AbstractEnv Identity (CExpr -> (CExpr, CExpr))
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity (CExpr, CExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e

trLocalDecls :: [Decl PredType] -> GAC [CLocalDecl]
trLocalDecls :: [Decl PredType] -> StateT AbstractEnv Identity [CLocalDecl]
trLocalDecls ds :: [Decl PredType]
ds = do
  (Decl PredType -> StateT AbstractEnv Identity ())
-> [Decl PredType] -> StateT AbstractEnv Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Decl PredType -> StateT AbstractEnv Identity ()
forall a. Decl a -> StateT AbstractEnv Identity ()
insertDeclLhs [Decl PredType]
ds
  (Decl PredType -> StateT AbstractEnv Identity [CLocalDecl])
-> [Decl PredType] -> StateT AbstractEnv Identity [CLocalDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> StateT AbstractEnv Identity [CLocalDecl]
trLocalDecl [Decl PredType]
ds

-- Insert all variables declared in local declarations
insertDeclLhs :: Decl a -> GAC ()
insertDeclLhs :: Decl a -> StateT AbstractEnv Identity ()
insertDeclLhs   (PatternDecl      _ p :: Pattern a
p _) = (Ident -> StateT AbstractEnv Identity CTVarIName)
-> [Ident] -> StateT AbstractEnv Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ident -> StateT AbstractEnv Identity CTVarIName
genVarIndex (Pattern a -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv Pattern a
p)
insertDeclLhs   (FreeDecl          _ vs :: [Var a]
vs) = (Ident -> StateT AbstractEnv Identity CTVarIName)
-> [Ident] -> StateT AbstractEnv Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Ident -> StateT AbstractEnv Identity CTVarIName
genVarIndex ((Var a -> Ident) -> [Var a] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map Var a -> Ident
forall a. Var a -> Ident
varIdent [Var a]
vs)
insertDeclLhs s :: Decl a
s@(TypeSig          _ _ _) = do
  Bool
uacy <- (AbstractEnv -> Bool) -> StateT AbstractEnv Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> Bool
untypedAcy
  Bool
-> StateT AbstractEnv Identity () -> StateT AbstractEnv Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
S.when Bool
uacy (Decl a -> StateT AbstractEnv Identity ()
forall a. Decl a -> StateT AbstractEnv Identity ()
insertSig Decl a
s)
insertDeclLhs _                          = () -> StateT AbstractEnv Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

trLocalDecl :: Decl PredType -> GAC [CLocalDecl]
trLocalDecl :: Decl PredType -> StateT AbstractEnv Identity [CLocalDecl]
trLocalDecl f :: Decl PredType
f@(FunctionDecl    _ _ _ _) = (CFuncDecl -> CLocalDecl) -> [CFuncDecl] -> [CLocalDecl]
forall a b. (a -> b) -> [a] -> [b]
map CFuncDecl -> CLocalDecl
CLocalFunc ([CFuncDecl] -> [CLocalDecl])
-> StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity [CLocalDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Decl PredType -> StateT AbstractEnv Identity [CFuncDecl]
trFuncDecl Bool
False Decl PredType
f
trLocalDecl f :: Decl PredType
f@(ExternalDecl        _ _) = (CFuncDecl -> CLocalDecl) -> [CFuncDecl] -> [CLocalDecl]
forall a b. (a -> b) -> [a] -> [b]
map CFuncDecl -> CLocalDecl
CLocalFunc ([CFuncDecl] -> [CLocalDecl])
-> StateT AbstractEnv Identity [CFuncDecl]
-> StateT AbstractEnv Identity [CLocalDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Decl PredType -> StateT AbstractEnv Identity [CFuncDecl]
trFuncDecl Bool
False Decl PredType
f
trLocalDecl (PatternDecl       _ p :: Pattern PredType
p rhs :: Rhs PredType
rhs) = (\p' :: CPattern
p' rhs' :: CRhs
rhs' -> [CPattern -> CRhs -> CLocalDecl
CLocalPat CPattern
p' CRhs
rhs'])
                                          (CPattern -> CRhs -> [CLocalDecl])
-> StateT AbstractEnv Identity CPattern
-> StateT AbstractEnv Identity (CRhs -> [CLocalDecl])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PredType -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat Pattern PredType
p StateT AbstractEnv Identity (CRhs -> [CLocalDecl])
-> StateT AbstractEnv Identity CRhs
-> StateT AbstractEnv Identity [CLocalDecl]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs PredType -> StateT AbstractEnv Identity CRhs
trRhs Rhs PredType
rhs
trLocalDecl (FreeDecl             _ vs :: [Var PredType]
vs) = (\vs' :: [CTVarIName]
vs' -> [[CTVarIName] -> CLocalDecl
CLocalVars [CTVarIName]
vs'])
                                          ([CTVarIName] -> [CLocalDecl])
-> StateT AbstractEnv Identity [CTVarIName]
-> StateT AbstractEnv Identity [CLocalDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ident -> StateT AbstractEnv Identity CTVarIName)
-> [Ident] -> StateT AbstractEnv Identity [CTVarIName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ident -> StateT AbstractEnv Identity CTVarIName
getVarIndex ((Var PredType -> Ident) -> [Var PredType] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map Var PredType -> Ident
forall a. Var a -> Ident
varIdent [Var PredType]
vs)
trLocalDecl _                           = [CLocalDecl] -> StateT AbstractEnv Identity [CLocalDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- can not occur (types etc.)

insertSig :: Decl a -> GAC ()
insertSig :: Decl a -> StateT AbstractEnv Identity ()
insertSig (TypeSig _ fs :: [Ident]
fs qty :: QualTypeExpr
qty) = do
  Map Ident QualTypeExpr
sigs <- (AbstractEnv -> Map Ident QualTypeExpr)
-> StateT AbstractEnv Identity (Map Ident QualTypeExpr)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> Map Ident QualTypeExpr
typeSigs
  let lsigs :: Map Ident QualTypeExpr
lsigs = [(Ident, QualTypeExpr)] -> Map Ident QualTypeExpr
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Ident
f, QualTypeExpr
qty) | Ident
f <- [Ident]
fs]
  (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ())
-> (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \env :: AbstractEnv
env -> AbstractEnv
env { typeSigs :: Map Ident QualTypeExpr
typeSigs = Map Ident QualTypeExpr
sigs Map Ident QualTypeExpr
-> Map Ident QualTypeExpr -> Map Ident QualTypeExpr
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Ident QualTypeExpr
lsigs }
insertSig _                 = () -> StateT AbstractEnv Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

trExpr :: Expression PredType -> GAC CExpr
trExpr :: Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Literal       _ _ l :: Literal
l) = CExpr -> StateT AbstractEnv Identity CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CLiteral -> CExpr
CLit (CLiteral -> CExpr) -> CLiteral -> CExpr
forall a b. (a -> b) -> a -> b
$ Literal -> CLiteral
cvLiteral Literal
l)
trExpr (Variable      _ _ v :: QualIdent
v)
  | QualIdent -> Bool
isQualified QualIdent
v = QName -> CExpr
CSymbol (QName -> CExpr)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
v
  | Bool
otherwise     = Ident -> GAC (Maybe CTVarIName)
lookupVarIndex (QualIdent -> Ident
unqualify QualIdent
v) GAC (Maybe CTVarIName)
-> (Maybe CTVarIName -> StateT AbstractEnv Identity CExpr)
-> StateT AbstractEnv Identity CExpr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \mvi :: Maybe CTVarIName
mvi -> case Maybe CTVarIName
mvi of
    Just vi :: CTVarIName
vi -> CExpr -> StateT AbstractEnv Identity CExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CTVarIName -> CExpr
CVar CTVarIName
vi)
    _       -> QName -> CExpr
CSymbol (QName -> CExpr)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
v
trExpr (Constructor   _ _ c :: QualIdent
c) = QName -> CExpr
CSymbol (QName -> CExpr)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
c
trExpr (Paren           _ e :: Expression PredType
e) = Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e
trExpr (Typed       _ e :: Expression PredType
e qty :: QualTypeExpr
qty) = CExpr -> CQualTypeExpr -> CExpr
CTyped (CExpr -> CQualTypeExpr -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity (CQualTypeExpr -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e StateT AbstractEnv Identity (CQualTypeExpr -> CExpr)
-> StateT AbstractEnv Identity CQualTypeExpr
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
trQualTypeExpr QualTypeExpr
qty
trExpr (Record     _ _ c :: QualIdent
c fs :: [Field (Expression PredType)]
fs) = QName -> [CField CExpr] -> CExpr
CRecConstr (QName -> [CField CExpr] -> CExpr)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity ([CField CExpr] -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
c
                                          StateT AbstractEnv Identity ([CField CExpr] -> CExpr)
-> StateT AbstractEnv Identity [CField CExpr]
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Field (Expression PredType)
 -> StateT AbstractEnv Identity (CField CExpr))
-> [Field (Expression PredType)]
-> StateT AbstractEnv Identity [CField CExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Field (Expression PredType)
-> StateT AbstractEnv Identity (CField CExpr)
forall a b. (a -> GAC b) -> Field a -> GAC (CField b)
trField Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr) [Field (Expression PredType)]
fs
trExpr (RecordUpdate _ e :: Expression PredType
e fs :: [Field (Expression PredType)]
fs) = CExpr -> [CField CExpr] -> CExpr
CRecUpdate (CExpr -> [CField CExpr] -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity ([CField CExpr] -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e
                                          StateT AbstractEnv Identity ([CField CExpr] -> CExpr)
-> StateT AbstractEnv Identity [CField CExpr]
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Field (Expression PredType)
 -> StateT AbstractEnv Identity (CField CExpr))
-> [Field (Expression PredType)]
-> StateT AbstractEnv Identity [CField CExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Field (Expression PredType)
-> StateT AbstractEnv Identity (CField CExpr)
forall a b. (a -> GAC b) -> Field a -> GAC (CField b)
trField Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr) [Field (Expression PredType)]
fs
trExpr (Tuple          _ es :: [Expression PredType]
es) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined (QualIdent -> Expression PredType)
-> QualIdent -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Arity -> QualIdent
qTupleId (Arity -> QualIdent) -> Arity -> QualIdent
forall a b. (a -> b) -> a -> b
$ [Expression PredType] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Expression PredType]
es) [Expression PredType]
es
trExpr (List         _ _ es :: [Expression PredType]
es) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ (Expression PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> [Expression PredType]
-> Expression PredType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Expression PredType -> Expression PredType -> Expression PredType)
-> (Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo
                   (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qConsId))
                 (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qNilId)
                 [Expression PredType]
es
trExpr (ListCompr    _ e :: Expression PredType
e ds :: [Statement PredType]
ds) = StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a. GAC a -> GAC a
inNestedScope (StateT AbstractEnv Identity CExpr
 -> StateT AbstractEnv Identity CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ (CExpr -> [CStatement] -> CExpr) -> [CStatement] -> CExpr -> CExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip CExpr -> [CStatement] -> CExpr
CListComp
                               ([CStatement] -> CExpr -> CExpr)
-> StateT AbstractEnv Identity [CStatement]
-> StateT AbstractEnv Identity (CExpr -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement PredType -> StateT AbstractEnv Identity CStatement)
-> [Statement PredType] -> StateT AbstractEnv Identity [CStatement]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Statement PredType -> StateT AbstractEnv Identity CStatement
trStatement [Statement PredType]
ds StateT AbstractEnv Identity (CExpr -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e
trExpr (EnumFrom              _ e :: Expression PredType
e) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qEnumFromId) [Expression PredType
e]
trExpr (EnumFromThen      _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qEnumFromThenId) [Expression PredType
e1, Expression PredType
e2]
trExpr (EnumFromTo        _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qEnumFromToId) [Expression PredType
e1, Expression PredType
e2]
trExpr (EnumFromThenTo _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 e3 :: Expression PredType
e3) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qEnumFromThenToId) [Expression PredType
e1, Expression PredType
e2, Expression PredType
e3]
trExpr (UnaryMinus            _ e :: Expression PredType
e) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qNegateId) [Expression PredType
e]
trExpr (Apply             _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) = CExpr -> CExpr -> CExpr
CApply (CExpr -> CExpr -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity (CExpr -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e1 StateT AbstractEnv Identity (CExpr -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e2
trExpr (InfixApply     _ e1 :: Expression PredType
e1 op :: InfixOp PredType
op e2 :: Expression PredType
e2) = Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (InfixOp PredType -> Expression PredType
forall a. InfixOp a -> Expression a
infixOp InfixOp PredType
op) [Expression PredType
e1, Expression PredType
e2]
trExpr (LeftSection        _ e :: Expression PredType
e op :: InfixOp PredType
op) = Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (InfixOp PredType -> Expression PredType
forall a. InfixOp a -> Expression a
infixOp InfixOp PredType
op) [Expression PredType
e]
trExpr (RightSection       _ op :: InfixOp PredType
op e :: Expression PredType
e) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qFlip) [InfixOp PredType -> Expression PredType
forall a. InfixOp a -> Expression a
infixOp InfixOp PredType
op, Expression PredType
e]
trExpr (Lambda             _ ps :: [Pattern PredType]
ps e :: Expression PredType
e) = StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a. GAC a -> GAC a
inNestedScope (StateT AbstractEnv Identity CExpr
 -> StateT AbstractEnv Identity CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$
                                     [CPattern] -> CExpr -> CExpr
CLambda ([CPattern] -> CExpr -> CExpr)
-> StateT AbstractEnv Identity [CPattern]
-> StateT AbstractEnv Identity (CExpr -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern PredType -> StateT AbstractEnv Identity CPattern)
-> [Pattern PredType] -> StateT AbstractEnv Identity [CPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern PredType -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat [Pattern PredType]
ps StateT AbstractEnv Identity (CExpr -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e
trExpr (Let              _ _ ds :: [Decl PredType]
ds e :: Expression PredType
e) = StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a. GAC a -> GAC a
inNestedScope (StateT AbstractEnv Identity CExpr
 -> StateT AbstractEnv Identity CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$
                                     [CLocalDecl] -> CExpr -> CExpr
CLetDecl ([CLocalDecl] -> CExpr -> CExpr)
-> StateT AbstractEnv Identity [CLocalDecl]
-> StateT AbstractEnv Identity (CExpr -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl PredType] -> StateT AbstractEnv Identity [CLocalDecl]
trLocalDecls [Decl PredType]
ds StateT AbstractEnv Identity (CExpr -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e
trExpr (Do               _ _ ss :: [Statement PredType]
ss e :: Expression PredType
e) = StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a. GAC a -> GAC a
inNestedScope (StateT AbstractEnv Identity CExpr
 -> StateT AbstractEnv Identity CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$
                                     (\ss' :: [CStatement]
ss' e' :: CExpr
e' -> [CStatement] -> CExpr
CDoExpr ([CStatement]
ss' [CStatement] -> [CStatement] -> [CStatement]
forall a. [a] -> [a] -> [a]
++ [CExpr -> CStatement
CSExpr CExpr
e']))
                                     ([CStatement] -> CExpr -> CExpr)
-> StateT AbstractEnv Identity [CStatement]
-> StateT AbstractEnv Identity (CExpr -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Statement PredType -> StateT AbstractEnv Identity CStatement)
-> [Statement PredType] -> StateT AbstractEnv Identity [CStatement]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Statement PredType -> StateT AbstractEnv Identity CStatement
trStatement [Statement PredType]
ss StateT AbstractEnv Identity (CExpr -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e
trExpr (IfThenElse     _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 e3 :: Expression PredType
e3) =
  Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr (Expression PredType -> StateT AbstractEnv Identity CExpr)
-> Expression PredType -> StateT AbstractEnv Identity CExpr
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
forall a. HasCallStack => a
undefined QualIdent
qIfThenElseId) [Expression PredType
e1, Expression PredType
e2, Expression PredType
e3]
trExpr (Case          _ _ ct :: CaseType
ct e :: Expression PredType
e bs :: [Alt PredType]
bs) = CCaseType -> CExpr -> [(CPattern, CRhs)] -> CExpr
CCase (CaseType -> CCaseType
cvCaseType CaseType
ct)
                                     (CExpr -> [(CPattern, CRhs)] -> CExpr)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity ([(CPattern, CRhs)] -> CExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e StateT AbstractEnv Identity ([(CPattern, CRhs)] -> CExpr)
-> StateT AbstractEnv Identity [(CPattern, CRhs)]
-> StateT AbstractEnv Identity CExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt PredType -> StateT AbstractEnv Identity (CPattern, CRhs))
-> [Alt PredType] -> StateT AbstractEnv Identity [(CPattern, CRhs)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt PredType -> StateT AbstractEnv Identity (CPattern, CRhs)
trAlt [Alt PredType]
bs

cvCaseType :: CaseType -> CCaseType
cvCaseType :: CaseType -> CCaseType
cvCaseType Flex  = CCaseType
CFlex
cvCaseType Rigid = CCaseType
CRigid

trStatement :: Statement PredType -> GAC CStatement
trStatement :: Statement PredType -> StateT AbstractEnv Identity CStatement
trStatement (StmtExpr _   e :: Expression PredType
e)  = CExpr -> CStatement
CSExpr     (CExpr -> CStatement)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity CStatement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e
trStatement (StmtDecl _ _ ds :: [Decl PredType]
ds) = [CLocalDecl] -> CStatement
CSLet      ([CLocalDecl] -> CStatement)
-> StateT AbstractEnv Identity [CLocalDecl]
-> StateT AbstractEnv Identity CStatement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl PredType] -> StateT AbstractEnv Identity [CLocalDecl]
trLocalDecls [Decl PredType]
ds
trStatement (StmtBind _ p :: Pattern PredType
p e :: Expression PredType
e)  = (CPattern -> CExpr -> CStatement)
-> CExpr -> CPattern -> CStatement
forall a b c. (a -> b -> c) -> b -> a -> c
flip CPattern -> CExpr -> CStatement
CSPat (CExpr -> CPattern -> CStatement)
-> StateT AbstractEnv Identity CExpr
-> StateT AbstractEnv Identity (CPattern -> CStatement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT AbstractEnv Identity CExpr
trExpr Expression PredType
e StateT AbstractEnv Identity (CPattern -> CStatement)
-> StateT AbstractEnv Identity CPattern
-> StateT AbstractEnv Identity CStatement
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern PredType -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat Pattern PredType
p

trAlt :: Alt PredType -> GAC (CPattern, CRhs)
trAlt :: Alt PredType -> StateT AbstractEnv Identity (CPattern, CRhs)
trAlt (Alt _ p :: Pattern PredType
p rhs :: Rhs PredType
rhs) = StateT AbstractEnv Identity (CPattern, CRhs)
-> StateT AbstractEnv Identity (CPattern, CRhs)
forall a. GAC a -> GAC a
inNestedScope (StateT AbstractEnv Identity (CPattern, CRhs)
 -> StateT AbstractEnv Identity (CPattern, CRhs))
-> StateT AbstractEnv Identity (CPattern, CRhs)
-> StateT AbstractEnv Identity (CPattern, CRhs)
forall a b. (a -> b) -> a -> b
$ (,) (CPattern -> CRhs -> (CPattern, CRhs))
-> StateT AbstractEnv Identity CPattern
-> StateT AbstractEnv Identity (CRhs -> (CPattern, CRhs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PredType -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat Pattern PredType
p StateT AbstractEnv Identity (CRhs -> (CPattern, CRhs))
-> StateT AbstractEnv Identity CRhs
-> StateT AbstractEnv Identity (CPattern, CRhs)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs PredType -> StateT AbstractEnv Identity CRhs
trRhs Rhs PredType
rhs

trPat :: Pattern a -> GAC CPattern
trPat :: Pattern a -> StateT AbstractEnv Identity CPattern
trPat (LiteralPattern         _ _ l :: Literal
l) = CPattern -> StateT AbstractEnv Identity CPattern
forall (m :: * -> *) a. Monad m => a -> m a
return (CLiteral -> CPattern
CPLit (CLiteral -> CPattern) -> CLiteral -> CPattern
forall a b. (a -> b) -> a -> b
$ Literal -> CLiteral
cvLiteral Literal
l)
trPat (VariablePattern        _ _ v :: Ident
v) = CTVarIName -> CPattern
CPVar (CTVarIName -> CPattern)
-> StateT AbstractEnv Identity CTVarIName
-> StateT AbstractEnv Identity CPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity CTVarIName
getVarIndex Ident
v
trPat (ConstructorPattern  _ _ c :: QualIdent
c ps :: [Pattern a]
ps) = QName -> [CPattern] -> CPattern
CPComb (QName -> [CPattern] -> CPattern)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity ([CPattern] -> CPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
c StateT AbstractEnv Identity ([CPattern] -> CPattern)
-> StateT AbstractEnv Identity [CPattern]
-> StateT AbstractEnv Identity CPattern
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern a -> StateT AbstractEnv Identity CPattern)
-> [Pattern a] -> StateT AbstractEnv Identity [CPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat [Pattern a]
ps
trPat (InfixPattern    _ a :: a
a p1 :: Pattern a
p1 op :: QualIdent
op p2 :: Pattern a
p2) =
  Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat (Pattern a -> StateT AbstractEnv Identity CPattern)
-> Pattern a -> StateT AbstractEnv Identity CPattern
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo a
a QualIdent
op [Pattern a
p1, Pattern a
p2]
trPat (ParenPattern             _ p :: Pattern a
p) = Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat Pattern a
p
trPat (RecordPattern       _ _ c :: QualIdent
c fs :: [Field (Pattern a)]
fs) = QName -> [CField CPattern] -> CPattern
CPRecord (QName -> [CField CPattern] -> CPattern)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity ([CField CPattern] -> CPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
c
                                              StateT AbstractEnv Identity ([CField CPattern] -> CPattern)
-> StateT AbstractEnv Identity [CField CPattern]
-> StateT AbstractEnv Identity CPattern
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Field (Pattern a)
 -> StateT AbstractEnv Identity (CField CPattern))
-> [Field (Pattern a)]
-> StateT AbstractEnv Identity [CField CPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Pattern a -> StateT AbstractEnv Identity CPattern)
-> Field (Pattern a)
-> StateT AbstractEnv Identity (CField CPattern)
forall a b. (a -> GAC b) -> Field a -> GAC (CField b)
trField Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat) [Field (Pattern a)]
fs
trPat (TuplePattern            _ ps :: [Pattern a]
ps) =
  Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat (Pattern a -> StateT AbstractEnv Identity CPattern)
-> Pattern a -> StateT AbstractEnv Identity CPattern
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo a
forall a. HasCallStack => a
undefined (Arity -> QualIdent
qTupleId (Arity -> QualIdent) -> Arity -> QualIdent
forall a b. (a -> b) -> a -> b
$ [Pattern a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Pattern a]
ps) [Pattern a]
ps
trPat (ListPattern           _ _ ps :: [Pattern a]
ps) = Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat (Pattern a -> StateT AbstractEnv Identity CPattern)
-> Pattern a -> StateT AbstractEnv Identity CPattern
forall a b. (a -> b) -> a -> b
$
  (Pattern a -> Pattern a -> Pattern a)
-> Pattern a -> [Pattern a] -> Pattern a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\x1 :: Pattern a
x1 x2 :: Pattern a
x2 -> SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo a
forall a. HasCallStack => a
undefined QualIdent
qConsId [Pattern a
x1, Pattern a
x2])
        (SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo a
forall a. HasCallStack => a
undefined QualIdent
qNilId [])
        [Pattern a]
ps
trPat (NegativePattern        _ a :: a
a l :: Literal
l) =
  Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat (Pattern a -> StateT AbstractEnv Identity CPattern)
-> Pattern a -> StateT AbstractEnv Identity CPattern
forall a b. (a -> b) -> a -> b
$ SpanInfo -> a -> Literal -> Pattern a
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo a
a (Literal -> Pattern a) -> Literal -> Pattern a
forall a b. (a -> b) -> a -> b
$ Literal -> Literal
negateLiteral Literal
l
trPat (AsPattern              _ v :: Ident
v p :: Pattern a
p) = CTVarIName -> CPattern -> CPattern
CPAs (CTVarIName -> CPattern -> CPattern)
-> StateT AbstractEnv Identity CTVarIName
-> StateT AbstractEnv Identity (CPattern -> CPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> StateT AbstractEnv Identity CTVarIName
getVarIndex Ident
vStateT AbstractEnv Identity (CPattern -> CPattern)
-> StateT AbstractEnv Identity CPattern
-> StateT AbstractEnv Identity CPattern
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat Pattern a
p
trPat (LazyPattern              _ p :: Pattern a
p) = CPattern -> CPattern
CPLazy (CPattern -> CPattern)
-> StateT AbstractEnv Identity CPattern
-> StateT AbstractEnv Identity CPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat Pattern a
p
trPat (FunctionPattern     _ _ f :: QualIdent
f ps :: [Pattern a]
ps) = QName -> [CPattern] -> CPattern
CPFuncComb (QName -> [CPattern] -> CPattern)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity ([CPattern] -> CPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
f StateT AbstractEnv Identity ([CPattern] -> CPattern)
-> StateT AbstractEnv Identity [CPattern]
-> StateT AbstractEnv Identity CPattern
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pattern a -> StateT AbstractEnv Identity CPattern)
-> [Pattern a] -> StateT AbstractEnv Identity [CPattern]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat [Pattern a]
ps
trPat (InfixFuncPattern _ a :: a
a p1 :: Pattern a
p1 f :: QualIdent
f p2 :: Pattern a
p2) =
  Pattern a -> StateT AbstractEnv Identity CPattern
forall a. Pattern a -> StateT AbstractEnv Identity CPattern
trPat (SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
NoSpanInfo a
a QualIdent
f [Pattern a
p1, Pattern a
p2])

trField :: (a -> GAC b) -> Field a -> GAC (CField b)
trField :: (a -> GAC b) -> Field a -> GAC (CField b)
trField act :: a -> GAC b
act (Field _ l :: QualIdent
l x :: a
x) = (,) (QName -> b -> CField b)
-> StateT AbstractEnv Identity QName
-> StateT AbstractEnv Identity (b -> CField b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT AbstractEnv Identity QName
trQual QualIdent
l StateT AbstractEnv Identity (b -> CField b)
-> GAC b -> GAC (CField b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> GAC b
act a
x

negateLiteral :: Literal -> Literal
negateLiteral :: Literal -> Literal
negateLiteral (Int    i :: Precedence
i) = Precedence -> Literal
Int   (-Precedence
i)
negateLiteral (Float  f :: Double
f) = Double -> Literal
Float (-Double
f)
negateLiteral _          = MName -> Literal
forall a. MName -> a
internalError "GenAbstractCurry.negateLiteral"

cvLiteral :: Literal -> CLiteral
cvLiteral :: Literal -> CLiteral
cvLiteral (Char   c :: Char
c) = Char -> CLiteral
CCharc   Char
c
cvLiteral (Int    i :: Precedence
i) = Precedence -> CLiteral
CIntc    Precedence
i
cvLiteral (Float  f :: Double
f) = Double -> CLiteral
CFloatc  Double
f
cvLiteral (String s :: MName
s) = MName -> CLiteral
CStringc MName
s

trQual :: QualIdent -> GAC QName
trQual :: QualIdent -> StateT AbstractEnv Identity QName
trQual qid :: QualIdent
qid
  | Ident
n Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident
unitId, Ident
listId, Ident
nilId, Ident
consId] = QName -> StateT AbstractEnv Identity QName
forall (m :: * -> *) a. Monad m => a -> m a
return ("Prelude", Ident -> MName
idName Ident
n)
  | Ident -> Bool
isTupleId Ident
n                              = QName -> StateT AbstractEnv Identity QName
forall (m :: * -> *) a. Monad m => a -> m a
return ("Prelude", Ident -> MName
idName Ident
n)
  | Bool
otherwise
  = QName -> StateT AbstractEnv Identity QName
forall (m :: * -> *) a. Monad m => a -> m a
return (MName -> (ModuleIdent -> MName) -> Maybe ModuleIdent -> MName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ModuleIdent -> MName
moduleName (QualIdent -> Maybe ModuleIdent
qidModule QualIdent
qid), Ident -> MName
idName Ident
n)
  where n :: Ident
n = QualIdent -> Ident
qidIdent QualIdent
qid

trGlobalIdent :: Ident -> GAC QName
trGlobalIdent :: Ident -> StateT AbstractEnv Identity QName
trGlobalIdent i :: Ident
i = (AbstractEnv -> ModuleIdent)
-> StateT AbstractEnv Identity ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> ModuleIdent
moduleId StateT AbstractEnv Identity ModuleIdent
-> (ModuleIdent -> StateT AbstractEnv Identity QName)
-> StateT AbstractEnv Identity QName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \m :: ModuleIdent
m -> QName -> StateT AbstractEnv Identity QName
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleIdent -> MName
moduleName ModuleIdent
m, Ident -> MName
idName Ident
i)

trLocalIdent :: Ident -> GAC QName
trLocalIdent :: Ident -> StateT AbstractEnv Identity QName
trLocalIdent i :: Ident
i = QName -> StateT AbstractEnv Identity QName
forall (m :: * -> *) a. Monad m => a -> m a
return ("", Ident -> MName
idName Ident
i)

qFlip :: QualIdent
qFlip :: QualIdent
qFlip = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (MName -> Ident
mkIdent "flip")

qNegateId :: QualIdent
qNegateId :: QualIdent
qNegateId = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (MName -> Ident
mkIdent "negate")

qIfThenElseId :: QualIdent
qIfThenElseId :: QualIdent
qIfThenElseId = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (MName -> Ident
mkIdent "ifThenElse")

prelUntyped :: QualIdent
prelUntyped :: QualIdent
prelUntyped = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ MName -> Ident
mkIdent "untyped"

-------------------------------------------------------------------------------
-- This part defines an environment containing all necessary information
-- for generating the AbstractCurry representation of a CurrySyntax term.

-- |Data type for representing an AbstractCurry generator environment
data AbstractEnv = AbstractEnv
  { AbstractEnv -> ModuleIdent
moduleId   :: ModuleIdent                -- ^name of the module
  , AbstractEnv -> ValueEnv
typeEnv    :: ValueEnv                   -- ^known values
  , AbstractEnv -> Set Ident
tyExports  :: Set.Set Ident              -- ^exported type symbols
  , AbstractEnv -> Set Ident
valExports :: Set.Set Ident              -- ^exported value symbols
  , AbstractEnv -> Arity
varIndex   :: Int                        -- ^counter for variable indices
  , AbstractEnv -> Arity
tvarIndex  :: Int                        -- ^counter for type variable indices
  , AbstractEnv -> NestEnv Arity
varEnv     :: NestEnv Int                -- ^stack of variable tables
  , AbstractEnv -> NestEnv Arity
tvarEnv    :: NestEnv Int                -- ^stack of type variable tables
  , AbstractEnv -> Bool
untypedAcy :: Bool                       -- ^flag to indicate whether untyped
                                             --  AbstractCurry is generated
  , AbstractEnv -> Map Ident QualTypeExpr
typeSigs   :: Map.Map Ident QualTypeExpr -- ^map of user defined type signatures
  } deriving Arity -> AbstractEnv -> ShowS
[AbstractEnv] -> ShowS
AbstractEnv -> MName
(Arity -> AbstractEnv -> ShowS)
-> (AbstractEnv -> MName)
-> ([AbstractEnv] -> ShowS)
-> Show AbstractEnv
forall a.
(Arity -> a -> ShowS) -> (a -> MName) -> ([a] -> ShowS) -> Show a
showList :: [AbstractEnv] -> ShowS
$cshowList :: [AbstractEnv] -> ShowS
show :: AbstractEnv -> MName
$cshow :: AbstractEnv -> MName
showsPrec :: Arity -> AbstractEnv -> ShowS
$cshowsPrec :: Arity -> AbstractEnv -> ShowS
Show

-- |Initialize the AbstractCurry generator environment
abstractEnv :: Bool -> CompilerEnv -> Module a -> AbstractEnv
abstractEnv :: Bool -> CompilerEnv -> Module a -> AbstractEnv
abstractEnv uacy :: Bool
uacy env :: CompilerEnv
env (Module _ _ _ mid :: ModuleIdent
mid es :: Maybe ExportSpec
es _ ds :: [Decl a]
ds) = AbstractEnv :: ModuleIdent
-> ValueEnv
-> Set Ident
-> Set Ident
-> Arity
-> Arity
-> NestEnv Arity
-> NestEnv Arity
-> Bool
-> Map Ident QualTypeExpr
-> AbstractEnv
AbstractEnv
  { moduleId :: ModuleIdent
moduleId   = ModuleIdent
mid
  , typeEnv :: ValueEnv
typeEnv    = CompilerEnv -> ValueEnv
valueEnv CompilerEnv
env
  , tyExports :: Set Ident
tyExports  = (Export -> Set Ident -> Set Ident)
-> Set Ident -> [Export] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Export -> Set Ident -> Set Ident
buildTypeExports  ModuleIdent
mid) Set Ident
forall a. Set a
Set.empty [Export]
es'
  , valExports :: Set Ident
valExports = (Export -> Set Ident -> Set Ident)
-> Set Ident -> [Export] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Export -> Set Ident -> Set Ident
buildValueExports ModuleIdent
mid) Set Ident
forall a. Set a
Set.empty [Export]
es'
  , varIndex :: Arity
varIndex   = 0
  , tvarIndex :: Arity
tvarIndex  = 0
  , varEnv :: NestEnv Arity
varEnv     = TopEnv Arity -> NestEnv Arity
forall a. TopEnv a -> NestEnv a
globalEnv TopEnv Arity
forall a. TopEnv a
emptyTopEnv
  , tvarEnv :: NestEnv Arity
tvarEnv    = TopEnv Arity -> NestEnv Arity
forall a. TopEnv a -> NestEnv a
globalEnv TopEnv Arity
forall a. TopEnv a
emptyTopEnv
  , untypedAcy :: Bool
untypedAcy = Bool
uacy
  , typeSigs :: Map Ident QualTypeExpr
typeSigs   = if Bool
uacy
                  then [(Ident, QualTypeExpr)] -> Map Ident QualTypeExpr
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Ident, QualTypeExpr)] -> Map Ident QualTypeExpr)
-> [(Ident, QualTypeExpr)] -> Map Ident QualTypeExpr
forall a b. (a -> b) -> a -> b
$ [Decl a] -> [(Ident, QualTypeExpr)]
forall a. [Decl a] -> [(Ident, QualTypeExpr)]
signatures [Decl a]
ds
                  else Map Ident QualTypeExpr
forall k a. Map k a
Map.empty
  }
  where es' :: [Export]
es' = case Maybe ExportSpec
es of
          Just (Exporting _ e :: [Export]
e) -> [Export]
e
          _                    -> MName -> [Export]
forall a. MName -> a
internalError "GenAbstractCurry.abstractEnv"

-- Builds a table containing all exported identifiers from a module.
buildTypeExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident
buildTypeExports :: ModuleIdent -> Export -> Set Ident -> Set Ident
buildTypeExports mid :: ModuleIdent
mid (ExportTypeWith _ tc :: QualIdent
tc _)
  | ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
tc = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert (QualIdent -> Ident
unqualify QualIdent
tc)
buildTypeExports _   _  = Set Ident -> Set Ident
forall a. a -> a
id

-- Builds a table containing all exported identifiers from a module.
buildValueExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident
buildValueExports :: ModuleIdent -> Export -> Set Ident -> Set Ident
buildValueExports mid :: ModuleIdent
mid (Export             _ q :: QualIdent
q)
  | ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
q  = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert (QualIdent -> Ident
unqualify QualIdent
q)
buildValueExports mid :: ModuleIdent
mid (ExportTypeWith _ tc :: QualIdent
tc cs :: [Ident]
cs)
  | ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
tc = (Set Ident -> [Ident] -> Set Ident)
-> [Ident] -> Set Ident -> Set Ident
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> Set Ident -> Set Ident)
-> Set Ident -> [Ident] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert) [Ident]
cs
buildValueExports _   _  = Set Ident -> Set Ident
forall a. a -> a
id

-- Looks up the unique index for the variable 'ident' in the
-- variable table of the current scope.
lookupVarIndex :: Ident -> GAC (Maybe CVarIName)
lookupVarIndex :: Ident -> GAC (Maybe CTVarIName)
lookupVarIndex i :: Ident
i = (AbstractEnv -> Maybe CTVarIName) -> GAC (Maybe CTVarIName)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((AbstractEnv -> Maybe CTVarIName) -> GAC (Maybe CTVarIName))
-> (AbstractEnv -> Maybe CTVarIName) -> GAC (Maybe CTVarIName)
forall a b. (a -> b) -> a -> b
$ \env :: AbstractEnv
env -> case Ident -> NestEnv Arity -> [Arity]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
i (NestEnv Arity -> [Arity]) -> NestEnv Arity -> [Arity]
forall a b. (a -> b) -> a -> b
$ AbstractEnv -> NestEnv Arity
varEnv AbstractEnv
env of
  [v :: Arity
v] -> CTVarIName -> Maybe CTVarIName
forall a. a -> Maybe a
Just (Arity
v, Ident -> MName
idName Ident
i)
  _   -> Maybe CTVarIName
forall a. Maybe a
Nothing

getVarIndex :: Ident -> GAC CVarIName
getVarIndex :: Ident -> StateT AbstractEnv Identity CTVarIName
getVarIndex i :: Ident
i = StateT AbstractEnv Identity AbstractEnv
forall s (m :: * -> *). MonadState s m => m s
S.get StateT AbstractEnv Identity AbstractEnv
-> (AbstractEnv -> StateT AbstractEnv Identity CTVarIName)
-> StateT AbstractEnv Identity CTVarIName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \env :: AbstractEnv
env -> case Ident -> NestEnv Arity -> [Arity]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
i (NestEnv Arity -> [Arity]) -> NestEnv Arity -> [Arity]
forall a b. (a -> b) -> a -> b
$ AbstractEnv -> NestEnv Arity
varEnv AbstractEnv
env of
  [v :: Arity
v] -> CTVarIName -> StateT AbstractEnv Identity CTVarIName
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity
v, Ident -> MName
idName Ident
i)
  _   -> Ident -> StateT AbstractEnv Identity CTVarIName
genVarIndex Ident
i

-- Generates an unique index for the  variable 'ident' and inserts it
-- into the  variable table of the current scope.
genVarIndex :: Ident -> GAC CVarIName
genVarIndex :: Ident -> StateT AbstractEnv Identity CTVarIName
genVarIndex i :: Ident
i = do
  AbstractEnv
env <- StateT AbstractEnv Identity AbstractEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  let idx :: Arity
idx = AbstractEnv -> Arity
varIndex AbstractEnv
env
  AbstractEnv -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (AbstractEnv -> StateT AbstractEnv Identity ())
-> AbstractEnv -> StateT AbstractEnv Identity ()
forall a b. (a -> b) -> a -> b
$ AbstractEnv
env { varIndex :: Arity
varIndex = Arity
idx Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ 1, varEnv :: NestEnv Arity
varEnv = Ident -> Arity -> NestEnv Arity -> NestEnv Arity
forall a. Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv Ident
i Arity
idx (AbstractEnv -> NestEnv Arity
varEnv AbstractEnv
env) }
  CTVarIName -> StateT AbstractEnv Identity CTVarIName
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity
idx, Ident -> MName
idName Ident
i)

-- Looks up the unique index for the type variable 'ident' in the type
-- variable table of the current scope.
getTVarIndex :: Ident -> GAC CTVarIName
getTVarIndex :: Ident -> StateT AbstractEnv Identity CTVarIName
getTVarIndex i :: Ident
i = StateT AbstractEnv Identity AbstractEnv
forall s (m :: * -> *). MonadState s m => m s
S.get StateT AbstractEnv Identity AbstractEnv
-> (AbstractEnv -> StateT AbstractEnv Identity CTVarIName)
-> StateT AbstractEnv Identity CTVarIName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \env :: AbstractEnv
env -> case Ident -> NestEnv Arity -> [Arity]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
i (NestEnv Arity -> [Arity]) -> NestEnv Arity -> [Arity]
forall a b. (a -> b) -> a -> b
$ AbstractEnv -> NestEnv Arity
tvarEnv AbstractEnv
env of
  [v :: Arity
v] -> CTVarIName -> StateT AbstractEnv Identity CTVarIName
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity
v, Ident -> MName
idName Ident
i)
  _   -> Ident -> StateT AbstractEnv Identity CTVarIName
genTVarIndex Ident
i

-- Generates an unique index for the type variable 'ident' and inserts it
-- into the type variable table of the current scope.
genTVarIndex :: Ident -> GAC CTVarIName
genTVarIndex :: Ident -> StateT AbstractEnv Identity CTVarIName
genTVarIndex i :: Ident
i = do
  AbstractEnv
env <- StateT AbstractEnv Identity AbstractEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  let idx :: Arity
idx = AbstractEnv -> Arity
tvarIndex AbstractEnv
env
  AbstractEnv -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (AbstractEnv -> StateT AbstractEnv Identity ())
-> AbstractEnv -> StateT AbstractEnv Identity ()
forall a b. (a -> b) -> a -> b
$ AbstractEnv
env { tvarIndex :: Arity
tvarIndex = Arity
idx Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ 1, tvarEnv :: NestEnv Arity
tvarEnv = Ident -> Arity -> NestEnv Arity -> NestEnv Arity
forall a. Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv Ident
i Arity
idx (AbstractEnv -> NestEnv Arity
tvarEnv AbstractEnv
env) }
  CTVarIName -> StateT AbstractEnv Identity CTVarIName
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity
idx, Ident -> MName
idName Ident
i)

withLocalEnv :: GAC a -> GAC a
withLocalEnv :: GAC a -> GAC a
withLocalEnv act :: GAC a
act = do
  AbstractEnv
old <- StateT AbstractEnv Identity AbstractEnv
forall s (m :: * -> *). MonadState s m => m s
S.get
  a
res <- GAC a
act
  AbstractEnv -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put AbstractEnv
old
  a -> GAC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

inNestedScope :: GAC a -> GAC a
inNestedScope :: GAC a -> GAC a
inNestedScope act :: GAC a
act = do
  (vo :: NestEnv Arity
vo, to :: NestEnv Arity
to) <- (AbstractEnv -> (NestEnv Arity, NestEnv Arity))
-> StateT AbstractEnv Identity (NestEnv Arity, NestEnv Arity)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((AbstractEnv -> (NestEnv Arity, NestEnv Arity))
 -> StateT AbstractEnv Identity (NestEnv Arity, NestEnv Arity))
-> (AbstractEnv -> (NestEnv Arity, NestEnv Arity))
-> StateT AbstractEnv Identity (NestEnv Arity, NestEnv Arity)
forall a b. (a -> b) -> a -> b
$ \e :: AbstractEnv
e -> (AbstractEnv -> NestEnv Arity
varEnv AbstractEnv
e, AbstractEnv -> NestEnv Arity
tvarEnv AbstractEnv
e)
  (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ())
-> (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \e :: AbstractEnv
e -> AbstractEnv
e { varEnv :: NestEnv Arity
varEnv = NestEnv Arity -> NestEnv Arity
forall a. NestEnv a -> NestEnv a
nestEnv (NestEnv Arity -> NestEnv Arity) -> NestEnv Arity -> NestEnv Arity
forall a b. (a -> b) -> a -> b
$ NestEnv Arity
vo, tvarEnv :: NestEnv Arity
tvarEnv = TopEnv Arity -> NestEnv Arity
forall a. TopEnv a -> NestEnv a
globalEnv TopEnv Arity
forall a. TopEnv a
emptyTopEnv }
  a
res <- GAC a
act
  (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ())
-> (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \e :: AbstractEnv
e -> AbstractEnv
e { varEnv :: NestEnv Arity
varEnv = NestEnv Arity
vo, tvarEnv :: NestEnv Arity
tvarEnv = NestEnv Arity
to }
  a -> GAC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

inNestedTScope :: GAC a -> GAC a
inNestedTScope :: GAC a -> GAC a
inNestedTScope act :: GAC a
act = do
  (vo :: NestEnv Arity
vo, to :: NestEnv Arity
to) <- (AbstractEnv -> (NestEnv Arity, NestEnv Arity))
-> StateT AbstractEnv Identity (NestEnv Arity, NestEnv Arity)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((AbstractEnv -> (NestEnv Arity, NestEnv Arity))
 -> StateT AbstractEnv Identity (NestEnv Arity, NestEnv Arity))
-> (AbstractEnv -> (NestEnv Arity, NestEnv Arity))
-> StateT AbstractEnv Identity (NestEnv Arity, NestEnv Arity)
forall a b. (a -> b) -> a -> b
$ \e :: AbstractEnv
e -> (AbstractEnv -> NestEnv Arity
varEnv AbstractEnv
e, AbstractEnv -> NestEnv Arity
tvarEnv AbstractEnv
e)
  (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ())
-> (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \e :: AbstractEnv
e -> AbstractEnv
e { varEnv :: NestEnv Arity
varEnv = TopEnv Arity -> NestEnv Arity
forall a. TopEnv a -> NestEnv a
globalEnv TopEnv Arity
forall a. TopEnv a
emptyTopEnv, tvarEnv :: NestEnv Arity
tvarEnv = NestEnv Arity -> NestEnv Arity
forall a. NestEnv a -> NestEnv a
nestEnv (NestEnv Arity -> NestEnv Arity) -> NestEnv Arity -> NestEnv Arity
forall a b. (a -> b) -> a -> b
$ NestEnv Arity
to }
  a
res <- GAC a
act
  (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ())
-> (AbstractEnv -> AbstractEnv) -> StateT AbstractEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \e :: AbstractEnv
e -> AbstractEnv
e { varEnv :: NestEnv Arity
varEnv = NestEnv Arity
vo, tvarEnv :: NestEnv Arity
tvarEnv = NestEnv Arity
to }
  a -> GAC a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

getQualType :: Ident -> PredType -> GAC CQualTypeExpr
getQualType :: Ident -> PredType -> StateT AbstractEnv Identity CQualTypeExpr
getQualType f :: Ident
f pty :: PredType
pty = do
  Bool
uacy <- (AbstractEnv -> Bool) -> StateT AbstractEnv Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> Bool
untypedAcy
  Map Ident QualTypeExpr
sigs <- (AbstractEnv -> Map Ident QualTypeExpr)
-> StateT AbstractEnv Identity (Map Ident QualTypeExpr)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> Map Ident QualTypeExpr
typeSigs
  QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
trQualTypeExpr (QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr)
-> QualTypeExpr -> StateT AbstractEnv Identity CQualTypeExpr
forall a b. (a -> b) -> a -> b
$ case Bool
uacy of
    True  -> QualTypeExpr -> Maybe QualTypeExpr -> QualTypeExpr
forall a. a -> Maybe a -> a
Maybe.fromMaybe (SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo [] (TypeExpr -> QualTypeExpr) -> TypeExpr -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$
                               SpanInfo -> QualIdent -> TypeExpr
ConstructorType SpanInfo
NoSpanInfo QualIdent
prelUntyped)
                             (Ident -> Map Ident QualTypeExpr -> Maybe QualTypeExpr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
f Map Ident QualTypeExpr
sigs)
    False -> [Ident] -> PredType -> QualTypeExpr
fromPredType [Ident]
identSupply PredType
pty

getQualType' :: QualIdent -> GAC QualTypeExpr
getQualType' :: QualIdent -> StateT AbstractEnv Identity QualTypeExpr
getQualType' f :: QualIdent
f = do
  ModuleIdent
m     <- (AbstractEnv -> ModuleIdent)
-> StateT AbstractEnv Identity ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> ModuleIdent
moduleId
  ValueEnv
tyEnv <- (AbstractEnv -> ValueEnv) -> StateT AbstractEnv Identity ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets AbstractEnv -> ValueEnv
typeEnv
  QualTypeExpr -> StateT AbstractEnv Identity QualTypeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (QualTypeExpr -> StateT AbstractEnv Identity QualTypeExpr)
-> QualTypeExpr -> StateT AbstractEnv Identity QualTypeExpr
forall a b. (a -> b) -> a -> b
$ case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
f ValueEnv
tyEnv of
    [Value _ _ _ (ForAll _ pty :: PredType
pty)] -> [Ident] -> PredType -> QualTypeExpr
fromPredType [Ident]
identSupply PredType
pty
    _                          -> case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
f) ValueEnv
tyEnv of
      [Value _ _ _ (ForAll _ pty :: PredType
pty)] -> [Ident] -> PredType -> QualTypeExpr
fromPredType [Ident]
identSupply PredType
pty
      _                          ->
        MName -> QualTypeExpr
forall a. MName -> a
internalError (MName -> QualTypeExpr) -> MName -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$ "GenAbstractCurry.getQualType': " MName -> ShowS
forall a. [a] -> [a] -> [a]
++ QualIdent -> MName
forall a. Show a => a -> MName
show QualIdent
f

getTypeVisibility :: Ident -> GAC CVisibility
getTypeVisibility :: Ident -> StateT AbstractEnv Identity CVisibility
getTypeVisibility i :: Ident
i = (AbstractEnv -> CVisibility)
-> StateT AbstractEnv Identity CVisibility
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((AbstractEnv -> CVisibility)
 -> StateT AbstractEnv Identity CVisibility)
-> (AbstractEnv -> CVisibility)
-> StateT AbstractEnv Identity CVisibility
forall a b. (a -> b) -> a -> b
$ \env :: AbstractEnv
env ->
  if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Ident
i (AbstractEnv -> Set Ident
tyExports AbstractEnv
env) then CVisibility
Public else CVisibility
Private

getVisibility :: Ident -> GAC CVisibility
getVisibility :: Ident -> StateT AbstractEnv Identity CVisibility
getVisibility i :: Ident
i = (AbstractEnv -> CVisibility)
-> StateT AbstractEnv Identity CVisibility
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((AbstractEnv -> CVisibility)
 -> StateT AbstractEnv Identity CVisibility)
-> (AbstractEnv -> CVisibility)
-> StateT AbstractEnv Identity CVisibility
forall a b. (a -> b) -> a -> b
$ \env :: AbstractEnv
env ->
  if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Ident
i (AbstractEnv -> Set Ident
valExports AbstractEnv
env) then CVisibility
Public else CVisibility
Private

signatures :: [Decl a] -> [(Ident, QualTypeExpr)]
signatures :: [Decl a] -> [(Ident, QualTypeExpr)]
signatures ds :: [Decl a]
ds = [(Ident
f, QualTypeExpr
qty) | TypeSig _ fs :: [Ident]
fs qty :: QualTypeExpr
qty <- [Decl a]
ds, Ident
f <- [Ident]
fs]