GenFlatCurry.hs 30.3 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
2 3 4 5 6 7 8
--
-- GenFlatCurry - Generates FlatCurry program terms and FlatCurry interfaces
--                (type 'FlatCurry.Prog')
--
-- November 2005,
-- Martin Engelke (men@informatik.uni-kiel.de)
--
Björn Peemöller 's avatar
Björn Peemöller committed
9
-- ---------------------------------------------------------------------------
10
{-# LANGUAGE CPP #-}
Björn Peemöller 's avatar
Björn Peemöller committed
11
module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
12

13 14 15
#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative ((<$>), (<*>))
#endif
16
import           Control.Monad       (filterM, mplus)
17
import           Control.Monad.State (State, evalState, gets, modify)
Björn Peemöller 's avatar
Björn Peemöller committed
18 19
import           Data.List           (mapAccumL, nub)
import qualified Data.Map as Map     (Map, empty, insert, lookup, fromList, toList)
20
import           Data.Maybe          (fromMaybe, isJust)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
21

22
import           Curry.Base.Ident
23
import           Curry.ExtendedFlat.Type
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
24 25
import qualified Curry.Syntax as CS

26
import Base.CurryTypes
27
import Base.Messages (internalError)
Björn Peemöller 's avatar
Björn Peemöller committed
28
import Base.ScopeEnv (ScopeEnv)
29
import qualified Base.ScopeEnv as SE (new, insert, lookup, beginScope, endScope)
Björn Peemöller 's avatar
Björn Peemöller committed
30
import Base.TopEnv (topEnvMap)
Björn Peemöller 's avatar
Björn Peemöller committed
31
import Base.Types
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
32

Björn Peemöller 's avatar
Björn Peemöller committed
33
import Env.Interface
34
import Env.TypeConstructor (TCEnv, TypeInfo (..))
Björn Peemöller 's avatar
Björn Peemöller committed
35 36 37 38
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)

import qualified IL as IL
import qualified ModuleSummary
39
import Transformations (transType)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
40 41 42 43

-------------------------------------------------------------------------------

-- transforms intermediate language code (IL) to FlatCurry code
44 45 46
genFlatCurry :: ModuleSummary.ModuleSummary -> InterfaceEnv
             -> ValueEnv -> TCEnv -> IL.Module -> Prog
genFlatCurry modSum mEnv tyEnv tcEnv mdl = patchPrelude $
47
  run modSum mEnv tyEnv tcEnv False (trModule mdl)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
48

Björn Peemöller 's avatar
Björn Peemöller committed
49
-- transforms intermediate language code (IL) to FlatCurry interfaces
50 51 52
genFlatInterface :: ModuleSummary.ModuleSummary -> InterfaceEnv
                 -> ValueEnv -> TCEnv -> IL.Module -> Prog
genFlatInterface modSum mEnv tyEnv tcEnv mdl = patchPrelude $
53
  run modSum mEnv tyEnv tcEnv True (trInterface mdl)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
54

55 56 57
patchPrelude :: Prog -> Prog
patchPrelude p@(Prog n _ types funcs ops)
  | n == prelude = Prog n [] (preludeTypes ++ types) funcs ops
Björn Peemöller 's avatar
Björn Peemöller committed
58
  | otherwise    = p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
59

60 61
preludeTypes :: [TypeDecl]
preludeTypes =
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
62 63
  [ Type unit Public [] [(Cons unit 0 Public [])]
  , Type nil Public [0]
Björn Peemöller 's avatar
Björn Peemöller committed
64 65
    [ Cons nil  0 Public []
    , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
66
    ]
67
  ] ++ map mkTupleType [2 .. maxTupleArity]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
68 69
  where unit = mkPreludeQName "()"
        nil  = mkPreludeQName "[]"
Björn Peemöller 's avatar
Björn Peemöller committed
70
        cons = mkPreludeQName ":"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
71

72 73
mkTupleType :: Int -> TypeDecl
mkTupleType arity = Type tuple Public [0 .. arity - 1]
Björn Peemöller 's avatar
Björn Peemöller committed
74 75
  [Cons tuple arity Public (map TVar [0 .. arity - 1])]
  where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
76 77 78 79 80 81 82 83 84 85 86

mkPreludeQName :: String -> QName
mkPreludeQName n = mkQName (prelude, n)

prelude :: String
prelude = "Prelude"

-- |Maximal arity of tuples
maxTupleArity :: Int
maxTupleArity = 15

Björn Peemöller 's avatar
Björn Peemöller committed
87
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
88 89 90 91 92 93 94

-- The environment 'FlatEnv' is embedded in the monadic representation
-- 'FlatState' which allows the usage of 'do' expressions.
type FlatState a = State FlatEnv a

-- Data type for representing an environment which contains information needed
-- for generating FlatCurry code.
Björn Peemöller 's avatar
Björn Peemöller committed
95 96
data FlatEnv = FlatEnv
  { moduleIdE     :: ModuleIdent
Björn Peemöller 's avatar
Björn Peemöller committed
97
  , interfaceEnvE :: InterfaceEnv
Björn Peemöller 's avatar
Björn Peemöller committed
98 99 100 101 102
  , typeEnvE      :: ValueEnv     -- types of defined values
  , tConsEnvE     :: TCEnv
  , publicEnvE    :: Map.Map Ident IdentExport
  , fixitiesE     :: [CS.IDecl]
  , typeSynonymsE :: [CS.IDecl]
103
  , importsE      :: [CS.IImportDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
104 105 106 107 108 109
  , exportsE      :: [CS.Export]
  , interfaceE    :: [CS.IDecl]
  , varIndexE     :: Int
  , varIdsE       :: ScopeEnv Ident VarIndex
  , genInterfaceE :: Bool
  , localTypes    :: Map.Map QualIdent IL.Type
110
  , consTypes     :: Map.Map QualIdent IL.Type
Björn Peemöller 's avatar
Björn Peemöller committed
111
  }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
112

113
data IdentExport
Björn Peemöller 's avatar
Björn Peemöller committed
114 115 116
  = NotConstr     -- function, type-constructor
  | OnlyConstr    -- constructor
  | NotOnlyConstr -- constructor, function, type-constructor
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
117 118

-- Runs a 'FlatState' action and returns the result
119 120 121
run :: ModuleSummary.ModuleSummary -> InterfaceEnv -> ValueEnv -> TCEnv
    -> Bool -> FlatState a -> a
run modSum mEnv tyEnv tcEnv genIntf f = evalState f env0
Björn Peemöller 's avatar
Björn Peemöller committed
122 123
  where
  env0 = FlatEnv
Björn Peemöller 's avatar
Björn Peemöller committed
124
    { moduleIdE     = ModuleSummary.moduleId modSum
Björn Peemöller 's avatar
Björn Peemöller committed
125 126 127
    , interfaceEnvE = mEnv
    , typeEnvE      = tyEnv
    , tConsEnvE     = tcEnv
Björn Peemöller 's avatar
Björn Peemöller committed
128 129 130 131 132 133 134
    , publicEnvE    = genPubEnv (ModuleSummary.moduleId  modSum)
                                (ModuleSummary.interface modSum)
    , fixitiesE     = ModuleSummary.infixDecls   modSum
    , typeSynonymsE = ModuleSummary.typeSynonyms modSum
    , importsE      = ModuleSummary.imports      modSum
    , exportsE      = ModuleSummary.exports      modSum
    , interfaceE    = ModuleSummary.interface    modSum
Björn Peemöller 's avatar
Björn Peemöller committed
135
    , varIndexE     = 0
136
    , varIdsE       = SE.new
Björn Peemöller 's avatar
Björn Peemöller committed
137 138
    , genInterfaceE = genIntf
    , localTypes    = Map.empty
139
    , consTypes     = Map.fromList $ getConstrTypes tcEnv
Björn Peemöller 's avatar
Björn Peemöller committed
140
    }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
141

142 143
getConstrTypes :: TCEnv -> [(QualIdent, IL.Type)]
getConstrTypes tcEnv =
144
  [ mkConstrType tqid conid argtys argc
Björn Peemöller 's avatar
Björn Peemöller committed
145
  | (_, (_, DataType tqid argc dts):_) <- Map.toList $ topEnvMap tcEnv
146
  , (DataConstr conid _ argtys) <- dts
Björn Peemöller 's avatar
Björn Peemöller committed
147
  ]
148
  where
149
  mkConstrType tqid conid argtypes targnum = (conname, contype)
Björn Peemöller 's avatar
Björn Peemöller committed
150
    where
151
    conname    = QualIdent (qidModule tqid) conid
152
    resty = IL.TypeConstructor tqid (map IL.TypeVariable [0 .. targnum - 1])
153
    contype    = foldr IL.TypeArrow resty $ map ttrans argtypes
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
154

155
trModule :: IL.Module -> FlatState Prog
156
trModule (IL.Module mid imps ds) = do
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
157
  -- insert local decls into localDecls
158 159 160 161 162
  modify $ \ s -> s { localTypes = Map.fromList [ (qn, t) | IL.FunctionDecl qn _ t _ <- ds ] }
  is      <- (\is -> map moduleName $ nub $ imps ++ map extractMid is) <$> imports
  types   <- genTypeSynonyms
  tyds    <- concat <$> mapM trTypeDecl ds
  funcs   <- concat <$> mapM trFuncDecl ds
Björn Peemöller 's avatar
Björn Peemöller committed
163
  ops     <- genOpDecls
164
  return $ Prog (moduleName mid) is (types ++ tyds) funcs ops
Björn Peemöller 's avatar
Björn Peemöller committed
165
  where extractMid (CS.IImportDecl _ mid1) = mid1
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
166

167 168 169 170 171 172 173 174 175 176 177 178 179 180
trInterface :: IL.Module -> FlatState Prog
trInterface (IL.Module mid imps decls) = do
  -- insert local decls into localDecls
  modify $ \ s -> s { localTypes = Map.fromList [ (qn, t) | IL.FunctionDecl qn _ t _ <- decls ] }
  is      <- (\is -> map moduleName $ nub $ imps ++ map extractMid is) <$> imports
  expimps <- getExportedImports
  itypes  <- mapM trITypeDecl (filter isTypeIDecl expimps)
  types   <- genTypeSynonyms
  datas   <- filterM isPublicDataDecl    decls >>= concatMapM trTypeDecl
  newtys  <- filterM isPublicNewtypeDecl decls >>= concatMapM trTypeDecl
  ifuncs  <- mapM trIFuncDecl (filter isFuncIDecl expimps)
  funcs   <- filterM isPublicFuncDecl    decls >>= concatMapM trFuncDecl
  iops    <- mapM trIOpDecl (filter isOpIDecl expimps)
  ops     <- genOpDecls
181
  return $ Prog (moduleName mid) is (itypes ++ types ++ datas ++ newtys)
182
                          (ifuncs ++ funcs) (iops ++ ops)
Björn Peemöller 's avatar
Björn Peemöller committed
183
  where extractMid (CS.IImportDecl _ mid1) = mid1
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
184

185 186
concatMapM :: (Functor m, Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM act xs = concat <$> mapM act xs
187

188 189 190 191 192 193 194 195 196
trTypeDecl :: IL.Decl -> FlatState [TypeDecl]
trTypeDecl (IL.DataDecl qid arity cs) = ((:[]) <$>) $
  Type  <$> trTypeIdent qid
        <*> getVisibility False qid <*> return [0 .. arity - 1]
        <*> (concat <$> mapM trConstrDecl cs)
trTypeDecl (IL.NewtypeDecl qid arity (IL.ConstrDecl _ ty)) = ((:[]) <$>) $
  TypeSyn <$> trTypeIdent qid <*> getVisibility False qid
          <*> return [0 .. arity - 1] <*> trType ty
trTypeDecl _ = return []
197 198 199 200 201 202 203 204 205 206 207 208 209 210

trConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]
trConstrDecl (IL.ConstrDecl qid tys) = do
  qid' <- trQualIdent qid
  vis  <- getVisibility True qid
  tys' <- mapM trType tys
  let flatCons = Cons qid' (length tys) vis tys'
  whenFlatCurry (return [flatCons]) (return [flatCons | vis == Public]) -- TODO: whenFlatCurry

trType :: IL.Type -> FlatState TypeExpr
trType (IL.TypeConstructor t tys) = TCons <$> trTypeIdent t <*> mapM trType tys
trType (IL.TypeVariable      idx) = return $ TVar $ abs idx
trType (IL.TypeArrow     ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2

211
trFuncDecl :: IL.Decl -> FlatState [FuncDecl]
212 213 214
trFuncDecl (IL.FunctionDecl qid vs ty e) = do
  qname <- trQualIdent qid
  arity <- getArity qid
215
  texpr <- trType ty
Björn Peemöller 's avatar
Björn Peemöller committed
216
  whenFlatCurry
217 218
    (do vis   <- getVisibility False qid
        is    <- mapM newVarIndex vs
219
        expr  <- trExpr e
Björn Peemöller 's avatar
Björn Peemöller committed
220
        clearVarIndices
221
        return [Func qname arity vis texpr (Rule is expr)]
Björn Peemöller 's avatar
Björn Peemöller committed
222
    )
223
    (return [Func qname arity Public texpr (Rule [] (Var $ mkIdx 0))])
224 225 226 227
trFuncDecl (IL.ExternalDecl qid _ extname ty) = do
  texpr <- trType ty
  qname <- trQualIdent qid
  arity <- getArity qid
228
  vis   <- getVisibility False qid
229
  xname <- trExternal extname
230 231
  return [Func qname arity vis texpr (External xname)]
trFuncDecl _ = return []
232 233 234 235 236 237

trExpr :: IL.Expression -> FlatState Expr
trExpr (IL.Literal       l) = Lit <$> trLiteral l
trExpr (IL.Variable      v) = Var <$> lookupVarIndex v
trExpr (IL.Function    f _) = do
  qname <- trQualIdent f
238
  arity <- getArity    f
239 240 241
  genFuncCall qname arity []
trExpr (IL.Constructor c _) = do
  qname <- trQualIdent c
242
  arity <- getArity    c
243 244
  genConsCall qname arity []
trExpr (IL.Apply     e1 e2) = trApply e1 e2
245
trExpr (IL.Case   r t e bs) = Case r (cvEval t) <$> trExpr e <*> mapM trAlt bs
246 247
trExpr (IL.Or        e1 e2) = Or <$> trExpr e1 <*> trExpr e2
trExpr (IL.Exist       v e) = do
Björn Peemöller 's avatar
Björn Peemöller committed
248
  idx <- newVarIndex v
249
  e'  <- trExpr e
Björn Peemöller 's avatar
Björn Peemöller committed
250 251
  return $ case e' of
    Free is e'' -> Free (idx : is) e''
252 253 254 255
    _           -> Free (idx : []) e'
trExpr (IL.Let (IL.Binding v b) e) = inNewScope $ do
  v' <- newVarIndex v
  b' <- trExpr b
256
  e' <- trExpr e
257 258 259 260 261 262 263 264 265
  return $ case e' of -- TODO bjp(2011-09-21): maybe remove again, ask @MH
    Let bs e'' -> Let ((v', b'):bs) e''
    _          -> Let ((v', b'):[]) e'
trExpr (IL.Letrec   bs e) = inNewScope $ do
  let (vs, es) = unzip [ (v, b) | IL.Binding v b <- bs]
  vs' <- mapM newVarIndex vs
  es' <- mapM trExpr es
  e'  <- trExpr e
  return $ Let (zip vs' es') e'
266
trExpr (IL.Typed e ty) = Typed <$> trExpr e <*> trType ty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
267

268 269 270 271
trLiteral :: IL.Literal -> FlatState Literal
trLiteral (IL.Char  rs c) = return $ Charc  rs c
trLiteral (IL.Int   rs i) = return $ Intc   rs i
trLiteral (IL.Float rs f) = return $ Floatc rs f
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
272

273 274
trAlt :: IL.Alt -> FlatState BranchExpr
trAlt (IL.Alt p e) = Branch <$> trPat p <*> trExpr e
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
275

276 277 278 279 280
trPat :: IL.ConstrTerm -> FlatState Pattern
trPat (IL.LiteralPattern        l) = LPattern <$> trLiteral l
trPat (IL.ConstructorPattern c vs) = Pattern  <$> trQualIdent c
                                              <*> mapM newVarIndex vs
trPat (IL.VariablePattern       _) = internalError "GenFlatCurry.trPat"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
281

282 283 284
cvEval :: IL.Eval -> CaseType
cvEval IL.Rigid = Rigid
cvEval IL.Flex  = Flex
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
285 286 287

-------------------------------------------------------------------------------

288 289 290 291
trIFuncDecl :: CS.IDecl -> FlatState FuncDecl
trIFuncDecl (CS.IFunctionDecl _ f a ty) = do
  texpr <- trType $ snd $ cs2ilType [] ty
  qname <- trQualIdent f
Björn Peemöller 's avatar
Björn Peemöller committed
292
  return $ Func qname a Public texpr (Rule [] (Var $ mkIdx 0))
293
trIFuncDecl _ = internalError "GenFlatCurry: no function interface"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
294

295
trITypeDecl :: CS.IDecl -> FlatState TypeDecl
296
trITypeDecl (CS.IDataDecl _ t vs cs hs) = do
297
  let mid = fromMaybe (internalError "GenFlatCurry: no module name") (qidModule t)
Björn Peemöller 's avatar
Björn Peemöller committed
298
      is  = [0 .. length vs - 1]
299 300
  cdecls <- mapM (visitConstrIDecl mid $ zip vs is)
                 [c | c <- cs, CS.constrId c `notElem` hs]
301
  qname  <- trTypeIdent t
Björn Peemöller 's avatar
Björn Peemöller committed
302
  return $ Type qname Public is cdecls
303
trITypeDecl (CS.ITypeDecl _ t vs ty) = do
Björn Peemöller 's avatar
Björn Peemöller committed
304
  let is = [0 .. length vs - 1]
305 306
  ty'   <- trType $ snd $ cs2ilType (zip vs is) ty
  qname <- trTypeIdent t
Björn Peemöller 's avatar
Björn Peemöller committed
307
  return $ TypeSyn qname Public is ty'
308
trITypeDecl _ = internalError "GenFlatCurry: no type interface"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
309 310

visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl
Björn Peemöller 's avatar
Björn Peemöller committed
311 312
                 -> FlatState ConsDecl
visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs) = do
313 314
  texprs <- mapM (trType . (snd . cs2ilType tis)) typeexprs
  qname  <- trQualIdent (qualifyWith mid ident)
Björn Peemöller 's avatar
Björn Peemöller committed
315
  return (Cons qname (length typeexprs) Public texprs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
316
visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
Björn Peemöller 's avatar
Björn Peemöller committed
317
  = visitConstrIDecl mid tis (CS.ConstrDecl pos ids ident [type1,type2])
318
visitConstrIDecl mid tis (CS.RecordDecl _ _ ident fs) = do
319 320
  texprs <- mapM (trType . (snd . cs2ilType tis)) tys
  qname  <- trQualIdent (qualifyWith mid ident)
321 322
  return (Cons qname (length tys) Public texprs)
  where tys = [ty | CS.FieldDecl _ ls ty <- fs, _ <- ls]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
323

324 325 326
trIOpDecl :: CS.IDecl -> FlatState OpDecl
trIOpDecl (CS.IInfixDecl _ fixi prec op) = do
  op' <- trQualIdent op
327
  return $ Op op' (genFixity fixi) prec
328
trIOpDecl _ = internalError "GenFlatCurry.trIOpDecl: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
329 330 331

-------------------------------------------------------------------------------

332 333 334
trQualIdent :: QualIdent -> FlatState QName
trQualIdent qid = do
  mid <- getModuleIdent
335
  let (mmod, ident) = (qidModule qid, qidIdent qid)
Björn Peemöller 's avatar
Björn Peemöller committed
336
      modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
337
            = moduleName preludeMIdent
Björn Peemöller 's avatar
Björn Peemöller committed
338
            | otherwise
339
            = maybe (moduleName mid) moduleName mmod
340
  ftype <- lookupIdType qid
341
  return (QName Nothing ftype modid $ idName ident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
342

343
-- This variant of trQualIdent does not look up the type of the identifier,
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
344 345
-- which is wise when the identifier is bound to a type, because looking up
-- the type of a type via lookupIdType will get stuck in an endless loop. (hsi)
346 347 348
trTypeIdent :: QualIdent -> FlatState QName
trTypeIdent qid = do
  mid <- getModuleIdent
349
  let (mmod, ident) = (qidModule qid, qidIdent qid)
Björn Peemöller 's avatar
Björn Peemöller committed
350
      modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
351
            = moduleName preludeMIdent
Björn Peemöller 's avatar
Björn Peemöller committed
352
            | otherwise
353
            = maybe (moduleName mid) moduleName mmod
354
  return (QName Nothing Nothing modid $ idName ident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
355

356 357
trExternal :: String -> FlatState String
trExternal extname
358
  = getModuleIdent >>= \mid -> return (moduleName mid ++ "." ++ extname)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
359 360

getVisibility :: Bool -> QualIdent -> FlatState Visibility
361 362
getVisibility isConstr qid = do
  public <- isPublic isConstr qid
Björn Peemöller 's avatar
Björn Peemöller committed
363
  return $ if public then Public else Private
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
364 365

getExportedImports :: FlatState [CS.IDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
366
getExportedImports = do
367
  mid  <- getModuleIdent
Björn Peemöller 's avatar
Björn Peemöller committed
368 369
  exps <- exports
  genExportedIDecls $ Map.toList $ getExpImports mid Map.empty exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
370 371

getExpImports :: ModuleIdent -> Map.Map ModuleIdent [CS.Export] -> [CS.Export]
372
              -> Map.Map ModuleIdent [CS.Export]
Björn Peemöller 's avatar
Björn Peemöller committed
373
getExpImports _      expenv [] = expenv
374
getExpImports mident expenv ((CS.Export qid):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
375
  = getExpImports mident
376
    (bindExpImport mident qid (CS.Export qid) expenv)
Björn Peemöller 's avatar
Björn Peemöller committed
377
    exps
378
getExpImports mident expenv ((CS.ExportTypeWith qid idents):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
379
  = getExpImports mident
380
    (bindExpImport mident qid (CS.ExportTypeWith qid idents) expenv)
Björn Peemöller 's avatar
Björn Peemöller committed
381
    exps
382
getExpImports mident expenv ((CS.ExportTypeAll qid):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
383
  = getExpImports mident
384
    (bindExpImport mident qid (CS.ExportTypeAll qid) expenv)
Björn Peemöller 's avatar
Björn Peemöller committed
385
    exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
386
getExpImports mident expenv ((CS.ExportModule mident'):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
387
  = getExpImports mident (Map.insert mident' [] expenv) exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
388 389

bindExpImport :: ModuleIdent -> QualIdent -> CS.Export
390 391 392 393
              -> Map.Map ModuleIdent [CS.Export]
              -> Map.Map ModuleIdent [CS.Export]
bindExpImport mident qid export expenv
  | isJust (localIdent mident qid)
Björn Peemöller 's avatar
Björn Peemöller committed
394 395
  = expenv
  | otherwise
396
  = let (Just modid) = qidModule qid
Björn Peemöller 's avatar
Björn Peemöller committed
397 398 399
    in  maybe (Map.insert modid [export] expenv)
              (\es -> Map.insert modid (export:es) expenv)
              (Map.lookup modid expenv)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
400 401 402 403 404 405

genExportedIDecls :: [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]
genExportedIDecls mes = genExpIDecls [] mes

genExpIDecls :: [CS.IDecl] -> [(ModuleIdent,[CS.Export])] -> FlatState [CS.IDecl]
genExpIDecls idecls [] = return idecls
Björn Peemöller 's avatar
Björn Peemöller committed
406 407 408 409
genExpIDecls idecls ((mid,exps):mes) = do
  intf_ <- lookupModuleIntf mid
  let idecls' = maybe idecls (p_genExpIDecls mid idecls exps) intf_
  genExpIDecls idecls' mes
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
410
 where
Björn Peemöller 's avatar
Björn Peemöller committed
411 412 413 414
  p_genExpIDecls mid1 idecls1 exps1 (CS.Interface _ _ ds)
    | null exps1 = (map (qualifyIDecl mid1) ds) ++ idecls1
    | otherwise = filter (isExportedIDecl exps1) (map (qualifyIDecl mid1) ds)
                  ++ idecls1
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
415 416

isExportedIDecl :: [CS.Export] -> CS.IDecl -> Bool
417 418
isExportedIDecl exprts (CS.IInfixDecl _ _ _ qid)
  = isExportedQualIdent qid exprts
419
isExportedIDecl exprts (CS.IDataDecl _ qid _ _ _)
420 421 422 423 424
  = isExportedQualIdent qid exprts
isExportedIDecl exprts (CS.ITypeDecl _ qid _ _)
  = isExportedQualIdent qid exprts
isExportedIDecl exprts (CS.IFunctionDecl _ qid _ _)
  = isExportedQualIdent qid exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
425 426 427 428
isExportedIDecl _ _ = False

isExportedQualIdent :: QualIdent -> [CS.Export] -> Bool
isExportedQualIdent _ [] = False
429 430 431 432 433 434 435 436
isExportedQualIdent qid ((CS.Export qid'):exps)
  = qid == qid' || isExportedQualIdent qid exps
isExportedQualIdent qid ((CS.ExportTypeWith qid' _):exps)
  = qid == qid' || isExportedQualIdent qid exps
isExportedQualIdent qid ((CS.ExportTypeAll qid'):exps)
  = qid == qid' || isExportedQualIdent qid exps
isExportedQualIdent qid ((CS.ExportModule _):exps)
  = isExportedQualIdent qid exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
437 438

qualifyIDecl :: ModuleIdent -> CS.IDecl -> CS.IDecl
439 440
qualifyIDecl mid (CS.IInfixDecl   pos fixi prec qid)
  = CS.IInfixDecl pos fixi prec (qualQualify mid qid)
441
qualifyIDecl mid (CS.IDataDecl    pos qid vs cs hs)
442
  = CS.IDataDecl pos (qualQualify mid qid) vs
443 444 445
    (map (qualifyIConstrDecl mid) cs) hs
qualifyIDecl mid (CS.INewtypeDecl  pos qid vs nc hs)
  = CS.INewtypeDecl pos (qualQualify mid qid) vs nc hs
446 447 448 449
qualifyIDecl mid (CS.ITypeDecl     pos qid vs ty)
  = CS.ITypeDecl pos (qualQualify mid qid) vs ty
qualifyIDecl mid (CS.IFunctionDecl pos qid arity ty)
  = CS.IFunctionDecl pos (qualQualify mid qid) arity (qualifyCSType mid ty)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
450 451
qualifyIDecl _ idecl = idecl

452 453 454 455 456
qualifyIConstrDecl :: ModuleIdent -> CS.ConstrDecl -> CS.ConstrDecl
qualifyIConstrDecl mid (CS.ConstrDecl pos vs cid tys)
  = CS.ConstrDecl pos vs cid (map (qualifyCSType mid) tys)
qualifyIConstrDecl mid (CS.ConOpDecl pos vs ty1 op ty2)
  = CS.ConOpDecl pos vs (qualifyCSType mid ty1) op (qualifyCSType mid ty2)
457 458 459 460 461
qualifyIConstrDecl mid (CS.RecordDecl pos vs cid fs)
  = CS.RecordDecl pos vs cid (map (qualifyFieldDecl mid) fs)

qualifyFieldDecl :: ModuleIdent -> CS.FieldDecl -> CS.FieldDecl
qualifyFieldDecl m (CS.FieldDecl p l ty) = CS.FieldDecl p l (qualifyCSType m ty)
462 463 464 465

qualifyCSType :: ModuleIdent -> CS.TypeExpr -> CS.TypeExpr
qualifyCSType mid = fromType . toQualType mid []

466 467
trApply :: IL.Expression -> IL.Expression -> FlatState Expr
trApply e1 e2 = genFlatApplic [e2] e1
Björn Peemöller 's avatar
Björn Peemöller committed
468
  where
469 470 471 472 473 474 475 476 477 478
  genFlatApplic es e = case e of
    (IL.Apply     ea eb) -> genFlatApplic (eb:es) ea
    (IL.Function    f _) -> do
      qname <- trQualIdent f
      arity <- getArity f
      genFuncCall qname arity es
    (IL.Constructor c _) -> do
      qname <- trQualIdent c
      arity <- getArity c
      genConsCall qname arity es
Björn Peemöller 's avatar
Björn Peemöller committed
479
    _ -> do
480
      expr <- trExpr e
481
      genApplicComb expr es
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
482 483

genFuncCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
484 485 486 487 488 489 490 491
genFuncCall qname arity es
  | cnt <  arity = genComb qname es (FuncPartCall (arity - cnt))
  | cnt == arity = genComb qname es FuncCall
  | otherwise    = do
    let (es1, es2) = splitAt arity es
    funccall <- genComb qname es1 FuncCall
    genApplicComb funccall es2
 where cnt = length es
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
492 493

genConsCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
494 495 496 497 498 499 500 501
genConsCall qname arity es
  | cnt <  arity = genComb qname es (ConsPartCall (arity - cnt))
  | cnt == arity = genComb qname es ConsCall
  | otherwise    = do
    let (es1, es2) = splitAt arity es
    conscall <- genComb qname es1 ConsCall
    genApplicComb conscall es2
 where cnt = length es
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
502 503

genComb :: QName -> [IL.Expression] -> CombType -> FlatState Expr
504
genComb qid es ct = Comb ct qid <$> mapM trExpr es
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
505 506

genApplicComb :: Expr -> [IL.Expression] -> FlatState Expr
507 508
genApplicComb e []      = return e
genApplicComb e (e1:es) = do
509 510
  expr1 <- trExpr e1
  qname <- trQualIdent qidApply
511
  genApplicComb (Comb FuncCall qname [e, expr1]) es
Björn Peemöller 's avatar
Björn Peemöller committed
512 513
  where
  qidApply = qualifyWith preludeMIdent (mkIdent "apply")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
514 515 516 517 518

genOpDecls :: FlatState [OpDecl]
genOpDecls = fixities >>= mapM genOpDecl

genOpDecl :: CS.IDecl -> FlatState OpDecl
519
genOpDecl (CS.IInfixDecl _ fix prec qid) = do
520
  qname <- trQualIdent qid
521
  return $ Op qname (genFixity fix) prec
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
522 523
genOpDecl _ = internalError "GenFlatCurry: no infix interface"

Björn Peemöller 's avatar
Björn Peemöller committed
524 525 526 527
genFixity :: CS.Infix -> Fixity
genFixity CS.InfixL = InfixlOp
genFixity CS.InfixR = InfixrOp
genFixity CS.Infix  = InfixOp
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
528

529
-- The intermediate language (IL) does not represent type synonyms.
530
-- For this reason an interface representation of all type synonyms is generated
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
531 532 533 534 535 536
-- from the abstract syntax representation of the Curry program.
-- The function 'typeSynonyms' returns this list of type synonyms.
genTypeSynonyms ::  FlatState [TypeDecl]
genTypeSynonyms = typeSynonyms >>= mapM genTypeSynonym

genTypeSynonym :: CS.IDecl -> FlatState TypeDecl
537
genTypeSynonym (CS.ITypeDecl _ qid tvs ty) = do
538
  qname <- trTypeIdent qid
539
  vis   <- getVisibility False qid
540
  let vs = [0 .. length tvs - 1]
541
  ty'   <- trType $ snd $ cs2ilType (zip tvs vs) ty
542
  return $ TypeSyn qname vis vs ty'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
543 544
genTypeSynonym _ = internalError "GenFlatCurry: no type synonym interface"

Björn Peemöller 's avatar
Björn Peemöller committed
545
cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> ([(Ident,Int)], IL.Type)
546
cs2ilType ids (CS.ConstructorType qid typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
547
  = let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs
548
    in  (ids', IL.TypeConstructor qid ilTypeexprs)
549 550 551 552
cs2ilType ids (CS.VariableType ident) = case lookup ident ids of
  Just i  -> (ids, IL.TypeVariable i)
  Nothing -> let nid = 1 + case ids of { [] -> 0; (_, j):_ -> j }
             in  ((ident, nid):ids, IL.TypeVariable nid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
553
cs2ilType ids (CS.ArrowType type1 type2)
Björn Peemöller 's avatar
Björn Peemöller committed
554 555 556
  = let (ids',  ilType1) = cs2ilType ids type1
        (ids'', ilType2) = cs2ilType ids' type2
    in  (ids'', IL.TypeArrow ilType1 ilType2)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
557
cs2ilType ids (CS.ListType typeexpr)
Björn Peemöller 's avatar
Björn Peemöller committed
558 559
  = let (ids', ilTypeexpr) = cs2ilType ids typeexpr
    in  (ids', IL.TypeConstructor (qualify listId) [ilTypeexpr])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
560
cs2ilType ids (CS.TupleType typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
561 562 563 564 565 566
  = case typeexprs of
    []  -> (ids, IL.TypeConstructor qUnitId [])
    [t] -> cs2ilType ids t
    _   -> let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs
               tuplen = length ilTypeexprs
           in  (ids', IL.TypeConstructor (qTupleId tuplen) ilTypeexprs)
567
cs2ilType ids (CS.ParenType ty) = cs2ilType ids ty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
568 569

isPublicDataDecl :: IL.Decl -> FlatState Bool
570
isPublicDataDecl (IL.DataDecl qid _ _) = isPublic False qid
571 572 573 574 575 576
isPublicDataDecl _                     = return False

isPublicNewtypeDecl :: IL.Decl -> FlatState Bool
isPublicNewtypeDecl (IL.NewtypeDecl qid _ _) = isPublic False qid
isPublicNewtypeDecl _                        = return False

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
577
isPublicFuncDecl :: IL.Decl -> FlatState Bool
578 579
isPublicFuncDecl (IL.FunctionDecl qid _ _ _) = isPublic False qid
isPublicFuncDecl (IL.ExternalDecl qid _ _ _) = isPublic False qid
580
isPublicFuncDecl _                           = return False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
581 582

isTypeIDecl :: CS.IDecl -> Bool
583 584 585
isTypeIDecl (CS.IDataDecl _ _ _ _ _) = True
isTypeIDecl (CS.ITypeDecl   _ _ _ _) = True
isTypeIDecl _                        = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
586 587 588 589 590 591 592 593 594

isFuncIDecl :: CS.IDecl -> Bool
isFuncIDecl (CS.IFunctionDecl _ _ _ _) = True
isFuncIDecl _                          = False

isOpIDecl :: CS.IDecl -> Bool
isOpIDecl (CS.IInfixDecl _ _ _ _) = True
isOpIDecl _                       = False

595 596
getModuleIdent :: FlatState ModuleIdent
getModuleIdent = gets moduleIdE
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
597 598 599 600

exports :: FlatState [CS.Export]
exports = gets exportsE

601
imports :: FlatState [CS.IImportDecl]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
602 603 604 605 606 607 608 609 610
imports = gets importsE

fixities :: FlatState [CS.IDecl]
fixities = gets fixitiesE

typeSynonyms :: FlatState [CS.IDecl]
typeSynonyms = gets typeSynonymsE

isPublic :: Bool -> QualIdent -> FlatState Bool
Björn Peemöller 's avatar
Björn Peemöller committed
611 612
isPublic isConstr qid = gets $ \ s -> maybe False isP
  (Map.lookup (unqualify qid) $ publicEnvE s)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
613
  where
Björn Peemöller 's avatar
Björn Peemöller committed
614 615 616
  isP NotConstr     = not isConstr
  isP OnlyConstr    = isConstr
  isP NotOnlyConstr = True
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
617

618 619
lookupModuleIntf :: ModuleIdent -> FlatState (Maybe CS.Interface)
lookupModuleIntf mid = gets (Map.lookup mid . interfaceEnvE)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
620

621 622
getArity :: QualIdent -> FlatState Int
getArity qid = gets (lookupA . typeEnvE)
623
  where
Björn Peemöller 's avatar
Björn Peemöller committed
624
  lookupA tyEnv = case qualLookupValue qid tyEnv of
625 626 627 628 629 630 631 632 633 634
    [DataConstructor  _ a _ _] -> a
    [NewtypeConstructor _ _ _] -> 1
    [Value              _ a _] -> a
    [Label              _ _ _] -> 1
    _                          -> case lookupValue (unqualify qid) tyEnv of
      [DataConstructor  _ a _ _] -> a
      [NewtypeConstructor _ _ _] -> 1
      [Value              _ a _] -> a
      [Label              _ _ _] -> 1
      _                          -> internalError $ "GenFlatCurry.getArity: " ++ show qid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
635

636 637 638 639 640 641 642
ttrans :: Type -> IL.Type
ttrans (TypeVariable          v) = IL.TypeVariable v
ttrans (TypeConstructor    i ts) = IL.TypeConstructor i (map ttrans ts)
ttrans (TypeArrow           f x) = IL.TypeArrow (ttrans f) (ttrans x)
ttrans (TypeConstrained    [] v) = IL.TypeVariable v
ttrans (TypeConstrained (v:_) _) = ttrans v
ttrans (TypeSkolem            k) = internalError $
643
  "Generators.GenFlatCurry.ttrans: skolem type " ++ show k
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
644 645 646 647 648 649

-- Constructor (:) receives special treatment throughout the
-- whole implementation. We won't depart from that for mere
-- aesthetic reasons. (hsi)
lookupIdType :: QualIdent -> FlatState (Maybe TypeExpr)
lookupIdType (QualIdent Nothing (Ident _ "[]" _))
Björn Peemöller 's avatar
Björn Peemöller committed
650 651
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
652
lookupIdType (QualIdent Nothing (Ident _ ":" _))
Björn Peemöller 's avatar
Björn Peemöller committed
653 654
  = return (Just (FuncType (TVar 0) (FuncType (l0) (l0))))
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
655
lookupIdType (QualIdent Nothing (Ident _ "()" _))
Björn Peemöller 's avatar
Björn Peemöller committed
656 657
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "()")) []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
658
lookupIdType (QualIdent Nothing (Ident _ t@('(':',':r) _))
Björn Peemöller 's avatar
Björn Peemöller committed
659 660 661 662 663
  = return $ Just funtype
  where tupArity   = length r + 1
        argTypes   = map TVar [1 .. tupArity]
        contype    = TCons (mkQName ("Prelude", t)) argTypes
        funtype    = foldr FuncType contype argTypes
664 665 666
lookupIdType qid = do
  aEnv <- gets typeEnvE
  lt <- gets localTypes
667
  ct <- gets consTypes
668
  case Map.lookup qid lt `mplus` Map.lookup qid ct of
669
    Just t  -> Just <$> trType t  -- local name or constructor
670
    Nothing -> case [ t | Value _ _ (ForAll _ t) <- qualLookupValue qid aEnv ] of
671
      t : _ -> Just <$> trType (transType t)  -- imported name
672
      []    -> case qidModule qid of
673
        Nothing -> return Nothing  -- no known type
674
        Just _ -> lookupIdType qid {qidModule = Nothing}
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
675 676 677

-- Generates a new index for a variable
newVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
678
newVarIndex ident = do
679
  idx <- (+1) <$> gets varIndexE
Björn Peemöller 's avatar
Björn Peemöller committed
680 681
  ty  <- getTypeOf ident
  let vid = VarIndex ty idx
682
  modify $ \ s -> s { varIndexE = idx, varIdsE = SE.insert ident vid (varIdsE s) }
Björn Peemöller 's avatar
Björn Peemöller committed
683
  return vid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
684

685 686 687 688 689
getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
getTypeOf ident = do
  valEnv <- gets typeEnvE
  case lookupValue ident valEnv of
    Value _ _ (ForAll _ t) : _ -> do
690
      t1 <- trType (ttrans t)
691
      return (Just t1)
692
    DataConstructor _ _ _ (ForAllExist _ _ t) : _ -> do
693
      t1 <- trType (ttrans t)
694
      return (Just t1)
695
    _ -> return Nothing
696

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
697
lookupVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
698
lookupVarIndex ident = do
699 700
  index_ <- gets (SE.lookup ident . varIdsE)
  maybe (internalError $ "GenFlatCurry: missing index for \"" ++ show ident ++ "\"") return index_
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
701 702

clearVarIndices :: FlatState ()
703
clearVarIndices = modify $ \ s -> s { varIndexE = 0, varIdsE = SE.new }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
704

Björn Peemöller 's avatar
Björn Peemöller committed
705 706
inNewScope :: FlatState a -> FlatState a
inNewScope act = do
707
  modify $ \ s -> s { varIdsE = SE.beginScope $ varIdsE s }
Björn Peemöller 's avatar
Björn Peemöller committed
708
  res <- act
709
  modify $ \ s -> s { varIdsE = SE.endScope $ varIdsE s }
Björn Peemöller 's avatar
Björn Peemöller committed
710
  return res
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
711 712 713

whenFlatCurry :: FlatState a -> FlatState a -> FlatState a
whenFlatCurry genFlat genIntf
714
  = gets genInterfaceE >>= (\intf -> if intf then genIntf else genFlat)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
715 716 717 718 719 720 721 722 723 724 725 726

-------------------------------------------------------------------------------

-- Generates an evironment containing all public identifiers from the module
-- Note: Currently the record functions (selection and update) for all public
-- record labels are inserted into the environment, though they are not
-- explicitly declared in the export specifications.
genPubEnv :: ModuleIdent -> [CS.IDecl] -> Map.Map Ident IdentExport
genPubEnv mid idecls = foldl (bindEnvIDecl mid) Map.empty idecls

bindIdentExport :: Ident -> Bool -> Map.Map Ident IdentExport -> Map.Map Ident IdentExport
bindIdentExport ident isConstr env =
Björn Peemöller 's avatar
Björn Peemöller committed
727 728 729
  maybe (Map.insert ident (if isConstr then OnlyConstr else NotConstr) env)
        (\ ie -> Map.insert ident (updateIdentExport ie isConstr) env)
        (Map.lookup ident env)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
730
  where
Björn Peemöller 's avatar
Björn Peemöller committed
731 732 733 734 735
  updateIdentExport OnlyConstr    True   = OnlyConstr
  updateIdentExport OnlyConstr    False  = NotOnlyConstr
  updateIdentExport NotConstr     True   = NotOnlyConstr
  updateIdentExport NotConstr     False  = NotConstr
  updateIdentExport NotOnlyConstr _      = NotOnlyConstr
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
736 737

bindEnvIDecl :: ModuleIdent -> Map.Map Ident IdentExport -> CS.IDecl -> Map.Map Ident IdentExport
738
bindEnvIDecl mid env (CS.IDataDecl _ qid _ cdecls hs)
Björn Peemöller 's avatar
Björn Peemöller committed
739
  = maybe env
740 741
    (\ident -> let env'  = bindIdentExport ident False env
                   env'' = foldl bindEnvConstrDecl env'
742
                     [c | c <- cdecls, CS.constrId c `notElem` hs]
743
               in foldl bindEnvLabel env'' [l | l <- labels, l `notElem` hs])
Björn Peemöller 's avatar
Björn Peemöller committed
744
    (localIdent mid qid)
745
  where
746
    labels = nub $ concatMap CS.recordLabels cdecls
747
bindEnvIDecl mid env (CS.INewtypeDecl _ qid _ ncdecl hs)
Björn Peemöller 's avatar
Björn Peemöller committed
748
  = maybe env
749
    (\ident -> let env'  = bindIdentExport ident False env
750 751 752 753
                   env'' = if ncId `notElem` hs
                              then bindEnvNewConstrDecl env' ncdecl
                              else env'
               in foldl bindEnvLabel env'' [l | l <- labels, l `notElem` hs])
Björn Peemöller 's avatar
Björn Peemöller committed
754
    (localIdent mid qid)
755
  where
756 757 758
    ncId   = CS.nconstrId ncdecl
    labels = CS.nrecordLabels ncdecl
bindEnvIDecl mid env (CS.ITypeDecl _ qid _ _)
759
  = maybe env (\ident -> bindIdentExport ident False env) (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
760
bindEnvIDecl mid env (CS.IFunctionDecl _ qid _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
761
  = maybe env (\ident -> bindIdentExport ident False env) (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
762 763 764
bindEnvIDecl _ env _ = env

bindEnvConstrDecl :: Map.Map Ident IdentExport -> CS.ConstrDecl -> Map.Map Ident IdentExport
Björn Peemöller 's avatar
Björn Peemöller committed
765
bindEnvConstrDecl env (CS.ConstrDecl  _ _ ident _) = bindIdentExport ident True env
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
766
bindEnvConstrDecl env (CS.ConOpDecl _ _ _ ident _) = bindIdentExport ident True env
767 768 769 770
bindEnvConstrDecl env (CS.RecordDecl  _ _ ident _) = bindIdentExport ident True env

bindEnvLabel :: Map.Map Ident IdentExport -> Ident -> Map.Map Ident IdentExport
bindEnvLabel env l = bindIdentExport l False env
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
771 772 773

bindEnvNewConstrDecl :: Map.Map Ident IdentExport -> CS.NewConstrDecl -> Map.Map Ident IdentExport
bindEnvNewConstrDecl env (CS.NewConstrDecl _ _ ident _) = bindIdentExport ident False env
774
bindEnvNewConstrDecl env (CS.NewRecordDecl _ _ ident _) = bindIdentExport ident False env