GenAbstractCurry.hs 19.1 KB
Newer Older
1 2 3
{- |
    Module      :  $Header$
    Description :  Generation of AbstractCurry program terms
4 5
    Copyright   :  (c) 2005       , Martin Engelke
                       2011 - 2015, Björn Peemöller
6
                              2015, Jan Tikovsky
7 8 9 10 11 12 13 14
    License     :  OtherLicense

    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.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
15
-}
16
{-# LANGUAGE CPP #-}
17
module Generators.GenAbstractCurry (genAbstractCurry) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
18

19 20 21
#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative          ((<$>), (<*>))
#endif
22 23 24 25 26 27 28
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 (fromMaybe)
import qualified Data.Set            as Set   (Set, empty, insert, member)
import qualified Data.Traversable    as T     (forM)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
29 30 31

import Curry.AbstractCurry
import Curry.Base.Ident
32
import Curry.Syntax
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
33

Björn Peemöller 's avatar
Björn Peemöller committed
34
import Base.CurryTypes (fromType)
Björn Peemöller 's avatar
Björn Peemöller committed
35
import Base.Expr       (bv)
36 37 38
import Base.Messages   (internalError)
import Base.NestEnv
import Base.Types      (TypeScheme (..))
Björn Peemöller 's avatar
Björn Peemöller committed
39

40 41
import Env.Value       (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
import Env.OpPrec      (mkPrec)
Björn Peemöller 's avatar
Björn Peemöller committed
42

43 44
import CompilerEnv

45 46
type GAC a = S.State AbstractEnv a

47
-- ---------------------------------------------------------------------------
Björn Peemöller 's avatar
Björn Peemöller committed
48
-- Interface
49
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
50

Björn Peemöller 's avatar
Björn Peemöller committed
51
-- |Generate an AbstractCurry program term from the syntax tree
52 53 54 55
--  when uacy flag is set untype AbstractCurry is generated
genAbstractCurry :: Bool -> CompilerEnv -> Module -> CurryProg
genAbstractCurry uacy env mdl
  = S.evalState (trModule mdl) (abstractEnv uacy env mdl)
56

57 58 59
-- ---------------------------------------------------------------------------
-- Conversion from Curry to AbstractCurry
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
60

61 62 63 64 65 66 67
trModule :: Module -> GAC CurryProg
trModule (Module _ mid _ is ds) = do
  CurryProg mid' is' <$> ts' <*> fs' <*> os'
  where
  mid'  = moduleName mid
  is'   = map cvImportDecl is
  ts'   = concat <$> mapM (withLocalEnv . trTypeDecl ) ds
68
  fs'   = concat <$> mapM (withLocalEnv . trFuncDecl True) ds
69 70 71 72 73 74 75
  os'   = concat <$> mapM (withLocalEnv . trInfixDecl) ds

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

trTypeDecl :: Decl -> GAC [CTypeDecl]
trTypeDecl (DataDecl    _ t vs cs) = (\t' v vs' cs' -> [CType t' v vs' cs'])
76
  <$> trGlobalIdent t <*> getTypeVisibility t
77 78
  <*> mapM genTVarIndex vs <*> mapM trConsDecl cs
trTypeDecl (TypeDecl    _ t vs ty) = (\t' v vs' ty' -> [CTypeSyn t' v vs' ty'])
79
  <$> trGlobalIdent t <*> getTypeVisibility t
80
  <*> mapM genTVarIndex vs <*> trTypeExpr ty
81
trTypeDecl (NewtypeDecl _ t vs nc) = (\t' v vs' nc' -> [CNewType t' v vs' nc'])
82
  <$> trGlobalIdent t <*> getTypeVisibility t
83
  <*> mapM genTVarIndex vs <*> trNewConsDecl nc
84 85 86 87
trTypeDecl _                       = return []

trConsDecl :: ConstrDecl -> GAC CConsDecl
trConsDecl (ConstrDecl      _ _ c tys) = CCons
88
  <$> trGlobalIdent c <*> getVisibility c <*> mapM trTypeExpr tys
89 90
trConsDecl (ConOpDecl p vs ty1 op ty2) = trConsDecl $
  ConstrDecl p vs op [ty1, ty2]
91
trConsDecl (RecordDecl       _ _ c fs) = CRecord
92
  <$> trGlobalIdent c <*> getVisibility c <*> (concat <$> mapM trFieldDecl fs)
93 94 95

trFieldDecl :: FieldDecl -> GAC [CFieldDecl]
trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l ->
96
  CField <$> trGlobalIdent l <*> getVisibility l <*> trTypeExpr ty
97

98
trNewConsDecl :: NewConstrDecl -> GAC CConsDecl
99
trNewConsDecl (NewConstrDecl _ _ nc      ty) = CCons
100
  <$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)
101
trNewConsDecl (NewRecordDecl p _ nc (l, ty)) = CRecord
102
  <$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty)
103 104 105 106 107 108

trTypeExpr :: TypeExpr -> GAC CTypeExpr
trTypeExpr (ConstructorType  q ts) = CTCons <$> trQual q
                                            <*> mapM trTypeExpr ts
trTypeExpr (VariableType        v) = CTVar  <$> getTVarIndex v
trTypeExpr (TupleType         tys) = trTypeExpr $ case tys of
109 110 111
   []   -> ConstructorType qUnitId []
   [ty] -> ty
   _    -> ConstructorType (qTupleId $ length tys) tys
112 113 114
trTypeExpr (ListType           ty) = trTypeExpr $ ConstructorType qListId [ty]
trTypeExpr (ArrowType     ty1 ty2) = CFuncType   <$> trTypeExpr ty1
                                                 <*> trTypeExpr ty2
115
trTypeExpr (ParenType          ty) = trTypeExpr ty
116

117 118
trInfixDecl :: Decl -> GAC [COpDecl]
trInfixDecl (InfixDecl _ fix mprec ops) = mapM trInfix (reverse ops)
119
  where
120 121
  trInfix op = COp <$> trGlobalIdent op <*> return (cvFixity fix)
                   <*> return (fromInteger (mkPrec mprec))
122 123 124 125 126
  cvFixity InfixL = CInfixlOp
  cvFixity InfixR = CInfixrOp
  cvFixity Infix  = CInfixOp
trInfixDecl _ = return []

127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
trFuncDecl :: Bool -> Decl -> GAC [CFuncDecl]
trFuncDecl global (FunctionDecl   _ f eqs)
  =   (\f' a v ty rs -> [CFunc f' a v ty rs])
  <$> trFuncName global f <*> getArity f <*> getVisibility f
  <*> getType f  <*> mapM trEquation eqs
trFuncDecl global (ForeignDecl  _ _ _ f _)
  =   (\f' a v ty rs -> [CFunc f' a v ty rs])
  <$> trFuncName global f <*> getArity f <*> getVisibility f
  <*> getType f  <*> return []
trFuncDecl global (ExternalDecl      _ fs) = T.forM fs $ \f -> CFunc
  <$> trFuncName global f <*> getArity f <*> getVisibility f
  <*> getType f <*> return []
trFuncDecl _      _                        = return []

trFuncName :: Bool -> Ident -> GAC QName
trFuncName global = if global then trGlobalIdent else trLocalIdent
143 144

trEquation :: Equation -> GAC CRule
145 146
trEquation (Equation _ lhs rhs) = inNestedScope
                                $ CRule <$> trLhs lhs <*> trRhs rhs
147 148 149 150

trLhs :: Lhs -> GAC [CPattern]
trLhs = mapM trPat . snd . flatLhs

151
trRhs :: Rhs -> GAC CRhs
152 153
trRhs (SimpleRhs _ e ds) = inNestedScope $ do
  mapM_ insertDeclLhs ds
154
  CSimpleRhs <$> trExpr e <*> (concat <$> mapM trLocalDecl ds)
155 156
trRhs (GuardedRhs gs ds) = inNestedScope $ do
  mapM_ insertDeclLhs ds
157
  CGuardedRhs <$> mapM trCondExpr gs <*> (concat <$> mapM trLocalDecl ds)
158 159 160 161 162 163 164 165 166

trCondExpr :: CondExpr -> GAC (CExpr, CExpr)
trCondExpr (CondExpr _ g e) = (,) <$> trExpr g <*> trExpr e

trLocalDecls :: [Decl] -> GAC [CLocalDecl]
trLocalDecls ds = do
  mapM_ insertDeclLhs ds
  concat <$> mapM trLocalDecl ds

167
-- Insert all variables declared in local declarations
168
insertDeclLhs :: Decl -> GAC ()
169 170 171 172 173 174
insertDeclLhs   (PatternDecl      _ p _) = mapM_ genVarIndex (bv p)
insertDeclLhs   (FreeDecl          _ vs) = mapM_ genVarIndex vs
insertDeclLhs s@(TypeSig          _ _ _) = do
  uacy <- S.gets untypedAcy
  S.when uacy (insertSig s)
insertDeclLhs _                          = return ()
175 176

trLocalDecl :: Decl -> GAC [CLocalDecl]
177 178 179
trLocalDecl f@(FunctionDecl     _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ForeignDecl  _ _ _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ExternalDecl       _ _) = map CLocalFunc <$> trFuncDecl False f
180 181 182 183
trLocalDecl (PatternDecl      _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs'])
                                         <$> trPat p <*> trRhs rhs
trLocalDecl (FreeDecl            _ vs) = (\vs' -> [CLocalVars vs'])
                                         <$> mapM getVarIndex vs
184 185
trLocalDecl _                          = return [] -- can not occur (types etc.)

186 187 188 189 190 191 192
insertSig :: Decl -> GAC ()
insertSig (TypeSig _ fs ty) = do
  sigs <- S.gets typeSigs
  let lsigs = Map.fromList [(f, ty) | f <- fs]
  S.modify $ \env -> env { typeSigs = sigs `Map.union` lsigs }
insertSig _                 = return ()

193
trExpr :: Expression -> GAC CExpr
194 195
trExpr (Literal         l) = return (CLit $ cvLiteral l)
trExpr (Variable        v)
196
  | isQualified v = CSymbol <$> trQual v
197
  | otherwise     = lookupVarIndex (unqualify v) >>= \mvi -> case mvi of
198
    Just vi -> return (CVar vi)
199
    _       -> CSymbol <$> trQual v
200 201 202 203 204 205 206 207
trExpr (Constructor     c) = CSymbol <$> trQual c
trExpr (Paren           e) = trExpr e
trExpr (Typed        e ty) = CTyped <$> trExpr e <*> trTypeExpr ty
trExpr (Record       c fs) = CRecConstr <$> trQual c
                                        <*> mapM (trField trExpr) fs
trExpr (RecordUpdate e fs) = CRecUpdate <$> trExpr e
                                        <*> mapM (trField trExpr) fs
trExpr (Tuple        _ es) = trExpr $ case es of
208 209
  []  -> Variable qUnitId
  [x] -> x
210
  _   -> foldl Apply (Variable $ qTupleId $ length es) es
211
trExpr (List         _ es) = trExpr $
212
  foldr (Apply . Apply (Constructor qConsId)) (Constructor qNilId) es
213
trExpr (ListCompr  _ e ds) = inNestedScope $ flip CListComp
214 215 216 217 218 219 220 221 222 223 224 225
                            <$> mapM trStatement ds <*> trExpr e
trExpr (EnumFrom              e) = trExpr
                                 $ apply (Variable qEnumFromId      ) [e]
trExpr (EnumFromThen      e1 e2) = trExpr
                                 $ apply (Variable qEnumFromThenId  ) [e1,e2]
trExpr (EnumFromTo        e1 e2) = trExpr
                                 $ apply (Variable qEnumFromToId    ) [e1,e2]
trExpr (EnumFromThenTo e1 e2 e3) = trExpr
                                 $ apply (Variable qEnumFromThenToId) [e1,e2,e3]
trExpr (UnaryMinus          _ e) = trExpr $ apply (Variable qNegateId) [e]
trExpr (Apply             e1 e2) = CApply <$> trExpr e1 <*> trExpr e2
trExpr (InfixApply     e1 op e2) = trExpr $ apply (opToExpr op) [e1, e2]
226 227 228
trExpr (LeftSection        e op) = trExpr $ apply (opToExpr op) [e]
trExpr (RightSection       op e) = trExpr
                                 $ apply (Variable qFlip) [opToExpr op, e]
229 230 231 232 233 234 235 236 237
trExpr (Lambda           _ ps e) = inNestedScope $
                                   CLambda <$> mapM trPat ps <*> trExpr e
trExpr (Let                ds e) = inNestedScope $
                                   CLetDecl <$> trLocalDecls ds <*> trExpr e
trExpr (Do                 ss e) = inNestedScope $
                                   (\ss' e' -> CDoExpr (ss' ++ [CSExpr e']))
                                   <$> mapM trStatement ss <*> trExpr e
trExpr (IfThenElse   _ e1 e2 e3) = trExpr
                                 $ apply (Variable qIfThenElseId) [e1,e2,e3]
238 239
trExpr (Case          _ ct e bs) = CCase (cvCaseType ct)
                                   <$> trExpr e <*> mapM trAlt bs
240

241 242 243 244
cvCaseType :: CaseType -> CCaseType
cvCaseType Flex  = CFlex
cvCaseType Rigid = CRigid

245 246 247 248 249 250 251 252
apply :: Expression -> [Expression] -> Expression
apply = foldl Apply

trStatement :: Statement -> GAC CStatement
trStatement (StmtExpr   _ e) = CSExpr     <$> trExpr e
trStatement (StmtDecl    ds) = CSLet      <$> trLocalDecls ds
trStatement (StmtBind _ p e) = flip CSPat <$> trExpr e <*> trPat p

253 254
trAlt :: Alt -> GAC (CPattern, CRhs)
trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs
255 256

trPat :: Pattern -> GAC CPattern
257
trPat (LiteralPattern         l) = return (CPLit $ cvLiteral l)
258 259 260 261
trPat (VariablePattern        v) = CPVar <$> getVarIndex v
trPat (ConstructorPattern  c ps) = CPComb <$> trQual c <*> mapM trPat ps
trPat (InfixPattern    p1 op p2) = trPat $ ConstructorPattern op [p1, p2]
trPat (ParenPattern           p) = trPat p
262 263
trPat (RecordPattern       c fs) = CPRecord <$> trQual c
                                            <*> mapM (trField trPat) fs
264
trPat (TuplePattern        _ ps) = trPat $ case ps of
265 266
  []   -> ConstructorPattern qUnitId []
  [ty] -> ty
267 268
  _    -> ConstructorPattern (qTupleId $ length ps) ps
trPat (ListPattern         _ ps) = trPat $
269
  foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2])
270
        (ConstructorPattern qNilId [])
271
        ps
272
trPat (NegativePattern      _ l) = trPat $ LiteralPattern $ negateLiteral l
273
trPat (AsPattern            v p) = CPAs <$> getVarIndex v<*> trPat p
274 275 276 277 278
trPat (LazyPattern          _ p) = CPLazy <$> trPat p
trPat (FunctionPattern     f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps
trPat (InfixFuncPattern p1 f p2) = trPat (FunctionPattern f [p1, p2])

trField :: (a -> GAC b) -> Field a -> GAC (CField b)
279
trField act (Field _ l x) = (,) <$> trQual l <*> act x
280

281 282 283 284 285
negateLiteral :: Literal -> Literal
negateLiteral (Int    v i) = Int   v  (-i)
negateLiteral (Float p' f) = Float p' (-f)
negateLiteral _            = internalError "GenAbstractCurry.negateLiteral"

286
cvLiteral :: Literal -> CLiteral
287 288 289 290
cvLiteral (Char   _ c) = CCharc   c
cvLiteral (Int    _ i) = CIntc    i
cvLiteral (Float  _ f) = CFloatc  f
cvLiteral (String _ s) = CStringc s
291 292

trQual :: QualIdent -> GAC QName
293 294 295 296 297 298 299 300 301
trQual qid
  | n `elem` [unitId, listId, nilId, consId] = return ("Prelude", idName n)
  | isTupleId n                              = return ("Prelude", idName n)
  | otherwise
  = return (maybe "" moduleName (qidModule qid), idName n)
  where n = qidIdent qid

trGlobalIdent :: Ident -> GAC QName
trGlobalIdent i = S.gets moduleId >>= \m -> return (moduleName m, idName i)
302 303

trLocalIdent :: Ident -> GAC QName
304
trLocalIdent i = return ("", idName i)
305

306 307 308 309
-- Converts an infix operator to an expression
opToExpr :: InfixOp -> Expression
opToExpr (InfixOp    op) = Variable    op
opToExpr (InfixConstr c) = Constructor c
310

311 312 313
qFlip :: QualIdent
qFlip = qualifyWith preludeMIdent (mkIdent "flip")

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
314
qEnumFromId :: QualIdent
315
qEnumFromId = qualifyWith preludeMIdent (mkIdent "enumFrom")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
316 317

qEnumFromThenId :: QualIdent
318
qEnumFromThenId = qualifyWith preludeMIdent (mkIdent "enumFromThen")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
319 320

qEnumFromToId :: QualIdent
321
qEnumFromToId = qualifyWith preludeMIdent (mkIdent "enumFromTo")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
322 323 324 325 326

qEnumFromThenToId :: QualIdent
qEnumFromThenToId = qualifyWith preludeMIdent (mkIdent "enumFromThenTo")

qNegateId :: QualIdent
327
qNegateId = qualifyWith preludeMIdent (mkIdent "negate")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
328 329

qIfThenElseId :: QualIdent
330
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
331

332 333 334
prelUntyped :: QualIdent
prelUntyped = qualifyWith preludeMIdent $ mkIdent "untyped"

335 336 337 338 339 340
-------------------------------------------------------------------------------
-- 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
341 342
  { moduleId   :: ModuleIdent            -- ^name of the module
  , typeEnv    :: ValueEnv               -- ^known values
343 344
  , tyExports  :: Set.Set Ident          -- ^exported type symbols
  , valExports :: Set.Set Ident          -- ^exported value symbols
345 346 347 348 349 350 351
  , varIndex   :: Int                    -- ^counter for variable indices
  , tvarIndex  :: Int                    -- ^counter for type variable indices
  , varEnv     :: NestEnv Int            -- ^stack of variable tables
  , tvarEnv    :: TopEnv Int             -- ^stack of type variable tables
  , untypedAcy :: Bool                   -- ^flag to indicate whether untyped
                                         --  AbstractCurry is generated
  , typeSigs   :: Map.Map Ident TypeExpr -- ^map of user defined type signatures
352 353 354
  } deriving Show

-- |Initialize the AbstractCurry generator environment
355 356 357 358
abstractEnv :: Bool -> CompilerEnv -> Module -> AbstractEnv
abstractEnv uacy env (Module _ mid es _ ds) = AbstractEnv
  { moduleId   = mid
  , typeEnv    = valueEnv env
359 360
  , tyExports  = foldr (buildTypeExports  mid) Set.empty es'
  , valExports = foldr (buildValueExports mid) Set.empty es'
361 362 363 364 365
  , varIndex   = 0
  , tvarIndex  = 0
  , varEnv     = globalEnv emptyTopEnv
  , tvarEnv    = emptyTopEnv
  , untypedAcy = uacy
366 367 368
  , typeSigs   = if uacy
                  then Map.fromList [ (f, ty) | TypeSig _ fs ty <- ds, f <- fs]
                  else Map.empty
369 370 371 372 373 374
  }
  where es' = case es of
          Just (Exporting _ e) -> e
          _                    -> internalError "GenAbstractCurry.abstractEnv"

-- Builds a table containing all exported identifiers from a module.
375 376 377 378 379 380 381 382
buildTypeExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident
buildTypeExports mid (ExportTypeWith tc _)
  | isLocalIdent mid tc = Set.insert (unqualify tc)
buildTypeExports _   _  = id

-- Builds a table containing all exported identifiers from a module.
buildValueExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident
buildValueExports mid (Export             q)
383
  | isLocalIdent mid q  = Set.insert (unqualify q)
384 385 386
buildValueExports mid (ExportTypeWith tc cs)
  | isLocalIdent mid tc = flip (foldr Set.insert) cs
buildValueExports _   _  = id
387 388 389 390 391 392 393

-- Looks up the unique index for the variable 'ident' in the
-- variable table of the current scope.
lookupVarIndex :: Ident -> GAC (Maybe CVarIName)
lookupVarIndex i = S.gets $ \env -> case lookupNestEnv i $ varEnv env of
  [v] -> Just (v, idName i)
  _   -> Nothing
394

395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421
getVarIndex :: Ident -> GAC CVarIName
getVarIndex i = S.get >>= \env -> case lookupNestEnv i $ varEnv env of
  [v] -> return (v, idName i)
  _   -> genVarIndex 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 i = do
  env <- S.get
  let idx = varIndex env
  S.put $ env { varIndex = idx + 1, varEnv = bindNestEnv i idx (varEnv env) }
  return (idx, idName 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 i = S.get >>= \env -> case lookupTopEnv i $ tvarEnv env of
  [v] -> return (v, idName i)
  _   -> genTVarIndex 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 i = do
  env <- S.get
  let idx = tvarIndex env
422
  S.put $ env {tvarIndex = idx + 1, tvarEnv = bindTopEnv i idx (tvarEnv env)}
423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
  return (idx, idName i)

withLocalEnv :: GAC a -> GAC a
withLocalEnv act = do
  old <- S.get
  res <- act
  S.put old
  return res

inNestedScope :: GAC a -> GAC a
inNestedScope act = do
  (vo, to) <- S.gets $ \e -> (varEnv e, tvarEnv e)
  S.modify $ \e -> e { varEnv = nestEnv $ vo, tvarEnv = emptyTopEnv }
  res <- act
  S.modify $ \e -> e { varEnv = vo, tvarEnv = to }
  return res

getArity :: Ident -> GAC Int
getArity f = do
  m     <- S.gets moduleId
  tyEnv <- S.gets typeEnv
  return $ case lookupValue f tyEnv of
    [Value _ a _] -> a
    _             -> case qualLookupValue (qualifyWith m f) tyEnv of
      [Value _ a _] -> a
      _             -> internalError $ "GenAbstractCurry.getArity: " ++ show f

450 451
getType :: Ident -> GAC CTypeExpr
getType f = S.gets untypedAcy >>= getType' f >>= trTypeExpr
452 453 454 455 456 457

getType' :: Ident -> Bool -> GAC TypeExpr
getType' f True  = do
  sigs <- S.gets typeSigs
  return $ Maybe.fromMaybe (ConstructorType prelUntyped []) (Map.lookup f sigs)
getType' f False = do
458 459 460 461 462 463 464 465 466
  m     <- S.gets moduleId
  tyEnv <- S.gets typeEnv
  return $ case lookupValue f tyEnv of
    [Value _ _ (ForAll _ ty)] -> fromType ty
    _                         -> case qualLookupValue (qualifyWith m f) tyEnv of
      [Value _ _ (ForAll _ ty)] -> fromType ty
      _                         -> internalError $ "GenAbstractCurry.getType: "
                                                  ++ show f

467
getTypeVisibility :: Ident -> GAC CVisibility
468
getTypeVisibility i = S.gets $ \env ->
469 470
  if Set.member i (tyExports env) then Public else Private

471
getVisibility :: Ident -> GAC CVisibility
472
getVisibility i = S.gets $ \env ->
473
  if Set.member i (valExports env) then Public else Private