GenFlatCurry.hs 35.5 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
-- ---------------------------------------------------------------------------
Björn Peemöller 's avatar
Björn Peemöller committed
10
module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
11

12
13
import Control.Applicative
import           Control.Monad       (filterM, mplus)
14
import           Control.Monad.State (State, evalState, gets, modify)
Björn Peemöller 's avatar
Björn Peemöller committed
15
16
import           Data.List           (mapAccumL, nub)
import qualified Data.Map as Map     (Map, empty, insert, lookup, fromList, toList)
17
import           Data.Maybe          (catMaybes, fromMaybe, isJust)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
18

19
import           Curry.Base.Ident
20
import           Curry.ExtendedFlat.Type
21
import qualified Curry.Syntax as CS
Björn Peemöller 's avatar
Björn Peemöller committed
22

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

Björn Peemöller 's avatar
Björn Peemöller committed
30
import Env.Interface
31
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
Björn Peemöller 's avatar
Björn Peemöller committed
32
33
34
35
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)

import qualified IL as IL
import qualified ModuleSummary
36
import Transformations (transType)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
37
38
39
40

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

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

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

52
53
54
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
55
  | otherwise    = p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
56

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

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

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
84
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
85
86
87
88
89
90
91

-- 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
92
93
data FlatEnv = FlatEnv
  { moduleIdE     :: ModuleIdent
Björn Peemöller 's avatar
Björn Peemöller committed
94
  , interfaceEnvE :: InterfaceEnv
Björn Peemöller 's avatar
Björn Peemöller committed
95
96
97
98
99
  , typeEnvE      :: ValueEnv     -- types of defined values
  , tConsEnvE     :: TCEnv
  , publicEnvE    :: Map.Map Ident IdentExport
  , fixitiesE     :: [CS.IDecl]
  , typeSynonymsE :: [CS.IDecl]
100
  , importsE      :: [CS.IImportDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
101
102
103
104
105
106
107
108
  , exportsE      :: [CS.Export]
  , interfaceE    :: [CS.IDecl]
  , varIndexE     :: Int
  , varIdsE       :: ScopeEnv Ident VarIndex
  , genInterfaceE :: Bool
  , localTypes    :: Map.Map QualIdent IL.Type
  , constrTypes   :: Map.Map QualIdent IL.Type
  }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
109

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

-- Runs a 'FlatState' action and returns the result
116
117
118
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
119
120
  where
  env0 = FlatEnv
Björn Peemöller 's avatar
Björn Peemöller committed
121
    { moduleIdE     = ModuleSummary.moduleId modSum
Björn Peemöller 's avatar
Björn Peemöller committed
122
123
124
    , interfaceEnvE = mEnv
    , typeEnvE      = tyEnv
    , tConsEnvE     = tcEnv
Björn Peemöller 's avatar
Björn Peemöller committed
125
126
127
128
129
130
131
    , 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
132
    , varIndexE     = 0
133
    , varIdsE       = SE.new
Björn Peemöller 's avatar
Björn Peemöller committed
134
135
    , genInterfaceE = genIntf
    , localTypes    = Map.empty
136
    , constrTypes   = Map.fromList $ getConstrTypes tcEnv tyEnv
Björn Peemöller 's avatar
Björn Peemöller committed
137
    }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
138

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

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

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
  recrds  <- genRecordTypes
  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
  return $ Prog (moduleName mid) is (itypes ++ recrds ++ types ++ datas ++ newtys)
                          (ifuncs ++ funcs) (iops ++ ops)
Björn Peemöller 's avatar
Björn Peemöller committed
182
  where extractMid (CS.IImportDecl _ mid1) = mid1
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
183

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

187
188
189
190
191
192
193
194
195
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 []
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211

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 [ty])
  | qualName t == "Identity" = trType ty -- TODO: documentation
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

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

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
239
  arity <- getArity    f
240
241
242
  genFuncCall qname arity []
trExpr (IL.Constructor c _) = do
  qname <- trQualIdent c
243
  arity <- getArity    c
244
245
  genConsCall qname arity []
trExpr (IL.Apply     e1 e2) = trApply e1 e2
246
trExpr (IL.Case   r t e bs) = Case r (cvEval t) <$> trExpr e <*> mapM trAlt bs
247
248
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
249
  idx <- newVarIndex v
250
  e'  <- trExpr e
Björn Peemöller 's avatar
Björn Peemöller committed
251
252
  return $ case e' of
    Free is e'' -> Free (idx : is) e''
253
254
255
256
    _           -> Free (idx : []) e'
trExpr (IL.Let (IL.Binding v b) e) = inNewScope $ do
  v' <- newVarIndex v
  b' <- trExpr b
257
  e' <- trExpr e
258
259
260
261
262
263
264
265
266
  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'
267
trExpr (IL.Typed e ty) = Typed <$> trExpr e <*> trType ty
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
268

269
270
271
272
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
273

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

277
278
279
280
281
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
282

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

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

289
290
291
292
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
293
  return $ Func qname a Public texpr (Rule [] (Var $ mkIdx 0))
294
trIFuncDecl _ = internalError "GenFlatCurry: no function interface"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
295

296
297
trITypeDecl :: CS.IDecl -> FlatState TypeDecl
trITypeDecl (CS.IDataDecl _ t vs cs) = do
298
  let mid = fromMaybe (internalError "GenFlatCurry: no module name") (qidModule t)
Björn Peemöller 's avatar
Björn Peemöller committed
299
300
      is  = [0 .. length vs - 1]
  cdecls <- mapM (visitConstrIDecl mid $ zip vs is) $ catMaybes cs
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])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
318

319
320
321
trIOpDecl :: CS.IDecl -> FlatState OpDecl
trIOpDecl (CS.IInfixDecl _ fixi prec op) = do
  op' <- trQualIdent op
322
  return $ Op op' (genFixity fixi) prec
323
trIOpDecl _ = internalError "GenFlatCurry.trIOpDecl: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
324
325
326

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

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

338
-- This variant of trQualIdent does not look up the type of the identifier,
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
339
340
-- 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)
341
342
343
trTypeIdent :: QualIdent -> FlatState QName
trTypeIdent qid = do
  mid <- getModuleIdent
344
  let (mmod, ident) = (qidModule qid, qidIdent qid)
Björn Peemöller 's avatar
Björn Peemöller committed
345
      modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
346
            = moduleName preludeMIdent
Björn Peemöller 's avatar
Björn Peemöller committed
347
            | otherwise
348
            = maybe (moduleName mid) moduleName mmod
349
  return (QName Nothing Nothing modid $ idName ident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
350

351
352
trExternal :: String -> FlatState String
trExternal extname
353
  = getModuleIdent >>= \mid -> return (moduleName mid ++ "." ++ extname)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
354
355

getVisibility :: Bool -> QualIdent -> FlatState Visibility
356
357
getVisibility isConstr qid = do
  public <- isPublic isConstr qid
Björn Peemöller 's avatar
Björn Peemöller committed
358
  return $ if public then Public else Private
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
359
360

getExportedImports :: FlatState [CS.IDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
361
getExportedImports = do
362
  mid  <- getModuleIdent
Björn Peemöller 's avatar
Björn Peemöller committed
363
364
  exps <- exports
  genExportedIDecls $ Map.toList $ getExpImports mid Map.empty exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
365
366

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

bindExpImport :: ModuleIdent -> QualIdent -> CS.Export
385
386
387
388
              -> 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
389
390
  = expenv
  | otherwise
391
  = let (Just modid) = qidModule qid
Björn Peemöller 's avatar
Björn Peemöller committed
392
393
394
    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
395
396
397
398
399
400

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
401
402
403
404
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
405
 where
Björn Peemöller 's avatar
Björn Peemöller committed
406
407
408
409
  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
410
411

isExportedIDecl :: [CS.Export] -> CS.IDecl -> Bool
412
413
414
415
416
417
418
419
isExportedIDecl exprts (CS.IInfixDecl _ _ _ qid)
  = isExportedQualIdent qid exprts
isExportedIDecl exprts (CS.IDataDecl _ qid _ _)
  = 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
420
421
422
423
isExportedIDecl _ _ = False

isExportedQualIdent :: QualIdent -> [CS.Export] -> Bool
isExportedQualIdent _ [] = False
424
425
426
427
428
429
430
431
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
432
433

qualifyIDecl :: ModuleIdent -> CS.IDecl -> CS.IDecl
434
435
436
437
438
439
440
441
442
443
444
qualifyIDecl mid (CS.IInfixDecl   pos fixi prec qid)
  = CS.IInfixDecl pos fixi prec (qualQualify mid qid)
qualifyIDecl mid (CS.IDataDecl    pos qid vs cs)
  = CS.IDataDecl pos (qualQualify mid qid) vs
  $ map (fmap (qualifyIConstrDecl mid)) cs
qualifyIDecl mid (CS.INewtypeDecl  pos qid vs nc)
  = CS.INewtypeDecl pos (qualQualify mid qid) vs nc
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
445
446
qualifyIDecl _ idecl = idecl

447
448
449
450
451
452
453
454
455
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)

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

456
457
trApply :: IL.Expression -> IL.Expression -> FlatState Expr
trApply e1 e2 = genFlatApplic [e2] e1
Björn Peemöller 's avatar
Björn Peemöller committed
458
  where
459
460
461
462
463
464
465
466
467
468
  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
469
    _ -> do
470
      expr <- trExpr e
471
      genApplicComb expr es
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
472
473

genFuncCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
474
475
476
477
478
479
480
481
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
482
483

genConsCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
484
485
486
487
488
489
490
491
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
492
493

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

genApplicComb :: Expr -> [IL.Expression] -> FlatState Expr
497
498
genApplicComb e []      = return e
genApplicComb e (e1:es) = do
499
500
  expr1 <- trExpr e1
  qname <- trQualIdent qidApply
501
  genApplicComb (Comb FuncCall qname [e, expr1]) es
Björn Peemöller 's avatar
Björn Peemöller committed
502
503
  where
  qidApply = qualifyWith preludeMIdent (mkIdent "apply")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
504
505
506
507
508

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

genOpDecl :: CS.IDecl -> FlatState OpDecl
509
genOpDecl (CS.IInfixDecl _ fix prec qid) = do
510
  qname <- trQualIdent qid
511
  return $ Op qname (genFixity fix) prec
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
512
513
genOpDecl _ = internalError "GenFlatCurry: no infix interface"

Björn Peemöller 's avatar
Björn Peemöller committed
514
515
516
517
genFixity :: CS.Infix -> Fixity
genFixity CS.InfixL = InfixlOp
genFixity CS.InfixR = InfixrOp
genFixity CS.Infix  = InfixOp
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
518
519
520

-- The intermediate language (IL) does not represent type synonyms
-- (and also no record declarations). For this reason an interface
Björn Peemöller 's avatar
Björn Peemöller committed
521
-- representation of all type synonyms is generated (see "ModuleSummary")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
522
523
524
525
526
527
-- 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
528
genTypeSynonym (CS.ITypeDecl _ qid tvs ty) = do
529
  qname <- trTypeIdent qid
530
  vis   <- getVisibility False qid
531
532
533
  let is = [0 .. (length tvs) - 1]
  ty'   <- elimRecordTypes ty >>= trType . snd . cs2ilType (zip tvs is)
  return $ TypeSyn qname vis is ty'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
genTypeSynonym _ = internalError "GenFlatCurry: no type synonym interface"

-- In order to provide an interface for record declarations, 'genRecordTypes'
-- generates dummy data declarations representing records together
-- with their typed labels. For the record declaration
--
--      type Rec = {l_1 :: t_1,..., l_n :: t_n}
--
-- the following data declaration will be generated:
--
--      data Rec' = l_1' t_1 | ... | l_n' :: t_n
--
-- Rec' and l_i' are unique idenfifiers which encode the original names
-- Rec and l_i.
-- When reading an interface file containing such declarations, it is
-- now possible to reconstruct the original record declaration. Since
-- usual FlatCurry code is used, these declaration should not have any
-- effects on the behaviour of the Curry program. But to ensure correctness,
-- these dummies should be generated for the interface file as well as for
-- the corresponding FlatCurry file.
genRecordTypes :: FlatState [TypeDecl]
genRecordTypes = records >>= mapM genRecordType

genRecordType :: CS.IDecl -> FlatState TypeDecl
558
genRecordType (CS.ITypeDecl _ qid params (CS.RecordType fs)) = do
Björn Peemöller 's avatar
Björn Peemöller committed
559
560
  let is = [0 .. (length params) - 1]
      (mid, ident) = (qidModule qid, qidIdent qid)
561
  qname <- trQualIdent ((maybe qualify qualifyWith mid) (recordExtId ident))
Björn Peemöller 's avatar
Björn Peemöller committed
562
563
  labels <- mapM (genRecordLabel mid (zip params is)) fs
  return (Type qname Public is labels)
564
genRecordType _ = internalError "GenFlatCurry.genRecordType: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
565

Björn Peemöller 's avatar
Björn Peemöller committed
566
567
568
genRecordLabel :: Maybe ModuleIdent -> [(Ident, Int)] -> ([Ident], CS.TypeExpr)
               -> FlatState ConsDecl
genRecordLabel modid vis ([ident],ty) = do
569
  ty'   <- elimRecordTypes ty
570
571
  texpr <- trType (snd (cs2ilType vis ty'))
  qname <- trQualIdent ((maybe qualify qualifyWith modid)
Björn Peemöller 's avatar
Björn Peemöller committed
572
573
                            (labelExtId ident))
  return (Cons qname 1 Public [texpr])
574
genRecordLabel _ _ _ = internalError "GenFlatCurry.genRecordLabel: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
575
576
577
578
579
580
581
582

-- FlatCurry provides no possibility of representing record types like
-- {l_1::t_1, l_2::t_2, ..., l_n::t_n}. So they have to be transformed to
-- to the corresponding type constructors which are defined in the record
-- declarations.
-- Unlike data declarations or function type annotations, type synonyms and
-- record declarations are not generated from the intermediate language.
-- So the transformation has only to be performed in these cases.
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
elimRecordTypes :: CS.TypeExpr -> FlatState CS.TypeExpr
elimRecordTypes (CS.ConstructorType c tys) = CS.ConstructorType c <$> mapM elimRecordTypes tys
elimRecordTypes v@(CS.VariableType      _) = return v
elimRecordTypes (CS.TupleType         tys) = CS.TupleType <$> mapM elimRecordTypes tys
elimRecordTypes (CS.ListType           ty) = CS.ListType  <$> elimRecordTypes ty
elimRecordTypes (CS.ArrowType     ty1 ty2) = CS.ArrowType <$> elimRecordTypes ty1 <*> elimRecordTypes ty2
elimRecordTypes (CS.RecordType        fss) = do
  tyEnv <- gets typeEnvE
  tcEnv <- gets tConsEnvE
  case lookupValue (fst (head fs)) tyEnv of
    [Label _ record _] -> case (qualLookupTC record tcEnv) of
      [AliasType _ n (TypeRecord fs')] ->
          let ms = foldl (matchTypeVars fs) Map.empty fs'
              types = mapM (\i -> maybe
                                  (return $ CS.VariableType (mkIdent ("#tvar" ++ show i)))
                                  elimRecordTypes
                                  (Map.lookup i ms))
                           [0 .. n-1]
          in  CS.ConstructorType record <$> types
      _ -> internalError "GenFlatCurry.elimRecordTypes: no record type"
    _ -> internalError "GenFlatCurry.elimRecordTypes: no label"
  where fs = flattenRecordTypeFields fss
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
605
606

matchTypeVars :: [(Ident,CS.TypeExpr)] -> Map.Map Int CS.TypeExpr
607
              -> (Ident, Type) -> Map.Map Int CS.TypeExpr
Björn Peemöller 's avatar
Björn Peemöller committed
608
matchTypeVars fs ms (l,ty) = maybe ms (match ms ty) (lookup l fs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
609
610
611
612
613
614
615
616
617
618
  where
  match ms1 (TypeVariable i) typeexpr = Map.insert i typeexpr ms1
  match ms1 (TypeConstructor _ tys) (CS.ConstructorType _ typeexprs)
     = matchList ms1 tys typeexprs
  match ms1 (TypeConstructor _ tys) (CS.ListType typeexpr)
     = matchList ms1 tys [typeexpr]
  match ms1 (TypeConstructor _ tys) (CS.TupleType typeexprs)
     = matchList ms1 tys typeexprs
  match ms1 (TypeArrow ty1 ty2) (CS.ArrowType typeexpr1 typeexpr2)
     = matchList ms1 [ty1,ty2] [typeexpr1,typeexpr2]
619
  match ms1 (TypeRecord fs') (CS.RecordType fss)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
620
621
622
     = foldl (matchTypeVars (flattenRecordTypeFields fss)) ms1 fs'
  match _ ty1 typeexpr
     = internalError ("GenFlatCurry.matchTypeVars: "
Björn Peemöller 's avatar
Björn Peemöller committed
623
                      ++ show ty1 ++ "\n" ++ show typeexpr)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
624
625
626
627

  matchList ms1 tys
     = foldl (\ms' (ty',typeexpr) -> match ms' ty' typeexpr) ms1 . zip tys

Björn Peemöller 's avatar
Björn Peemöller committed
628
flattenRecordTypeFields :: [([Ident], CS.TypeExpr)] -> [(Ident, CS.TypeExpr)]
629
flattenRecordTypeFields fss = [ (l, ty) | (ls, ty) <- fss, l <- ls]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
630

Björn Peemöller 's avatar
Björn Peemöller committed
631
cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> ([(Ident,Int)], IL.Type)
632
cs2ilType ids (CS.ConstructorType qid typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
633
  = let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs
634
    in  (ids', IL.TypeConstructor qid ilTypeexprs)
635
636
637
638
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
639
cs2ilType ids (CS.ArrowType type1 type2)
Björn Peemöller 's avatar
Björn Peemöller committed
640
641
642
  = let (ids',  ilType1) = cs2ilType ids type1
        (ids'', ilType2) = cs2ilType ids' type2
    in  (ids'', IL.TypeArrow ilType1 ilType2)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
643
cs2ilType ids (CS.ListType typeexpr)
Björn Peemöller 's avatar
Björn Peemöller committed
644
645
  = let (ids', ilTypeexpr) = cs2ilType ids typeexpr
    in  (ids', IL.TypeConstructor (qualify listId) [ilTypeexpr])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
646
cs2ilType ids (CS.TupleType typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
647
648
649
650
651
652
653
  = 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)
cs2ilType _ typeexpr = internalError $ "GenFlatCurry.cs2ilType: " ++ show typeexpr
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
654
655

isPublicDataDecl :: IL.Decl -> FlatState Bool
656
isPublicDataDecl (IL.DataDecl qid _ _) = isPublic False qid
657
658
659
660
661
662
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
663
isPublicFuncDecl :: IL.Decl -> FlatState Bool
664
665
isPublicFuncDecl (IL.FunctionDecl qid _ _ _) = isPublic False qid
isPublicFuncDecl (IL.ExternalDecl qid _ _ _) = isPublic False qid
666
isPublicFuncDecl _                           = return False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
667
668
669
670
671
672
673

isTypeIDecl :: CS.IDecl -> Bool
isTypeIDecl (CS.IDataDecl _ _ _ _) = True
isTypeIDecl (CS.ITypeDecl _ _ _ _) = True
isTypeIDecl _                      = False

isRecordIDecl :: CS.IDecl -> Bool
674
675
isRecordIDecl (CS.ITypeDecl _ _ _ (CS.RecordType (_:_))) = True
isRecordIDecl _                                          = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
676
677
678
679
680
681
682
683
684

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

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

685
686
getModuleIdent :: FlatState ModuleIdent
getModuleIdent = gets moduleIdE
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
687
688
689
690

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

691
imports :: FlatState [CS.IImportDecl]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
692
693
694
695
696
697
698
699
700
701
702
703
imports = gets importsE

records :: FlatState [CS.IDecl]
records = gets (filter isRecordIDecl . interfaceE)

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
704
705
isPublic isConstr qid = gets $ \ s -> maybe False isP
  (Map.lookup (unqualify qid) $ publicEnvE s)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
706
  where
Björn Peemöller 's avatar
Björn Peemöller committed
707
708
709
  isP NotConstr     = not isConstr
  isP OnlyConstr    = isConstr
  isP NotOnlyConstr = True
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
710

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

714
715
getArity :: QualIdent -> FlatState Int
getArity qid = gets (lookupA . typeEnvE)
716
  where
Björn Peemöller 's avatar
Björn Peemöller committed
717
  lookupA tyEnv = case qualLookupValue qid tyEnv of
718
719
720
721
722
723
724
725
    [DataConstructor  _ a _] -> a
    [NewtypeConstructor _ _] -> 1
    [Value            _ a _] -> a
    _                        -> case lookupValue (unqualify qid) tyEnv of
      [DataConstructor  _ a _] -> a
      [NewtypeConstructor _ _] -> 1
      [Value            _ a _] -> a
      _                        -> internalError $ "GenFlatCurry.getArity: " ++ show qid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
726

727
728
729
730
731
732
733
734
ttrans :: TCEnv -> ValueEnv -> Type -> IL.Type
ttrans _     _     (TypeVariable          v) = IL.TypeVariable v
ttrans tcEnv tyEnv (TypeConstructor    i ts) = IL.TypeConstructor i (map (ttrans tcEnv tyEnv) ts)
ttrans tcEnv tyEnv (TypeArrow           f x) = IL.TypeArrow (ttrans tcEnv tyEnv f) (ttrans tcEnv tyEnv x)
ttrans _     _     (TypeConstrained    [] v) = IL.TypeVariable v
ttrans tcEnv tyEnv (TypeConstrained (v:_) _) = ttrans tcEnv tyEnv v
ttrans _     _     (TypeSkolem            k) = internalError $
  "Generators.GenFlatCurry.ttrans: skolem type " ++ show k
735
ttrans _     _     (TypeRecord           []) = internalError $
736
  "Generators.GenFlatCurry.ttrans: empty type record"
737
ttrans tcEnv tyEnv (TypeRecord   ((l, _):_)) = case lookupValue l tyEnv of
738
  [Label _ rec _ ] -> case qualLookupTC rec tcEnv of
739
    [AliasType _ n (TypeRecord _)] ->
740
741
742
      IL.TypeConstructor rec (map IL.TypeVariable [0 .. n - 1])
    _ -> internalError $ "Generators.GenFlatCurry.ttrans: unknown record type " ++ show rec
  _ -> internalError $ "Generators.GenFlatCurry.ttrans: ambigous record label " ++ show l
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
743
744
745
746
747
748

-- 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
749
750
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
751
lookupIdType (QualIdent Nothing (Ident _ ":" _))
Björn Peemöller 's avatar
Björn Peemöller committed
752
753
  = return (Just (FuncType (TVar 0) (FuncType (l0) (l0))))
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
754
lookupIdType (QualIdent Nothing (Ident _ "()" _))
Björn Peemöller 's avatar
Björn Peemöller committed
755
756
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "()")) []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
757
lookupIdType (QualIdent Nothing (Ident _ t@('(':',':r) _))
Björn Peemöller 's avatar
Björn Peemöller committed
758
759
760
761
762
  = return $ Just funtype
  where tupArity   = length r + 1
        argTypes   = map TVar [1 .. tupArity]
        contype    = TCons (mkQName ("Prelude", t)) argTypes
        funtype    = foldr FuncType contype argTypes
763
764
765
766
lookupIdType qid = do
  aEnv <- gets typeEnvE
  lt <- gets localTypes
  ct <- gets constrTypes
767
  m  <- getModuleIdent
768
769
  tyEnv <- gets typeEnvE
  tcEnv <- gets tConsEnvE
770
  case Map.lookup qid lt `mplus` Map.lookup qid ct of
771
    Just t  -> Just <$> trType t  -- local name or constructor
772
    Nothing -> case [ t | Value _ _ (ForAll _ t) <- qualLookupValue qid aEnv ] of
773
      t : _ -> Just <$> trType (transType m tyEnv tcEnv t)  -- imported name
774
      []    -> case qidModule qid of
775
        Nothing -> return Nothing  -- no known type
776
        Just _ -> lookupIdType qid {qidModule = Nothing}
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
777
778
779

-- Generates a new index for a variable
newVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
780
newVarIndex ident = do
781
  idx <- (+1) <$> gets varIndexE
Björn Peemöller 's avatar
Björn Peemöller committed
782
783
  ty  <- getTypeOf ident
  let vid = VarIndex ty idx
784
  modify $ \ s -> s { varIndexE = idx, varIdsE = SE.insert ident vid (varIdsE s) }
Björn Peemöller 's avatar
Björn Peemöller committed
785
  return vid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
786

787
788
789
790
791
792
getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
getTypeOf ident = do
  valEnv <- gets typeEnvE
  tcEnv  <- gets tConsEnvE
  case lookupValue ident valEnv of
    Value _ _ (ForAll _ t) : _ -> do
793
794
      t1 <- trType (ttrans tcEnv valEnv t)
      return (Just t1)
795
    DataConstructor _ _ (ForAllExist _ _ t) : _ -> do
796
797
      t1 <- trType (ttrans tcEnv valEnv t)
      return (Just t1)
798
    _ -> return Nothing
799

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
800
lookupVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
801
lookupVarIndex ident = do
802
803
  index_ <- gets (SE.lookup ident . varIdsE)
  maybe (internalError $ "GenFlatCurry: missing index for \"" ++ show ident ++ "\"") return index_
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
804
805

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

Björn Peemöller 's avatar
Björn Peemöller committed
808
809
inNewScope :: FlatState a -> FlatState a
inNewScope act = do
810
  modify $ \ s -> s { varIdsE = SE.beginScope $ varIdsE s }
Björn Peemöller 's avatar
Björn Peemöller committed
811
  res <- act
812
  modify $ \ s -> s { varIdsE = SE.endScope $ varIdsE s }
Björn Peemöller 's avatar
Björn Peemöller committed
813
  return res
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
814
815
816

whenFlatCurry :: FlatState a -> FlatState a -> FlatState a
whenFlatCurry genFlat genIntf
817
  = gets genInterfaceE >>= (\intf -> if intf then genIntf else genFlat)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
818
819
820
821
822
823
824
825
826
827
828
829

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

-- 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
830
831
832
  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
833
  where
Björn Peemöller 's avatar
Björn Peemöller committed
834
835
836
837
838
  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
839
840
841

bindEnvIDecl :: ModuleIdent -> Map.Map Ident IdentExport -> CS.IDecl -> Map.Map Ident IdentExport
bindEnvIDecl mid env (CS.IDataDecl _ qid _ mcdecls)
Björn Peemöller 's avatar
Björn Peemöller committed
842
843
844
845
  = maybe env
    (\ident -> foldl bindEnvConstrDecl (bindIdentExport ident False env)
            (catMaybes mcdecls))
    (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
846
bindEnvIDecl mid env (CS.INewtypeDecl _ qid _ ncdecl)
Björn Peemöller 's avatar
Björn Peemöller committed
847
848
849
  = maybe env
    (\ident -> bindEnvNewConstrDecl (bindIdentExport ident False env) ncdecl)
    (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
850
bindEnvIDecl mid env (CS.ITypeDecl _ qid _ texpr)
Björn Peemöller 's avatar
Björn Peemöller committed
851
  = maybe env (\ident -> bindEnvITypeDecl env ident texpr) (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
852
bindEnvIDecl mid env (CS.IFunctionDecl _ qid _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
853
  = maybe env (\ident -> bindIdentExport ident False env) (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
854
855
856
bindEnvIDecl _ env _ = env

bindEnvITypeDecl :: Map.Map Ident IdentExport -> Ident -> CS.TypeExpr
Björn Peemöller 's avatar
Björn Peemöller committed
857
                 -> Map.Map Ident IdentExport
858
bindEnvITypeDecl env ident (CS.RecordType fs)
Björn Peemöller 's avatar
Björn Peemöller committed
859
860
  = bindIdentExport ident False (foldl (bindEnvRecordLabel ident) env fs)
bindEnvITypeDecl env ident _ = bindIdentExport ident False env
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
861
862

bindEnvConstrDecl :: Map.Map Ident IdentExport -> CS.ConstrDecl -> Map.Map Ident IdentExport
Björn Peemöller 's avatar
Björn Peemöller committed
863
bindEnvConstrDecl env (CS.ConstrDecl  _ _ ident _) = bindIdentExport ident True env
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
864
865
866
867
868
869
870
bindEnvConstrDecl env (CS.ConOpDecl _ _ _ ident _) = bindIdentExport ident True env

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

bindEnvRecordLabel :: Ident -> Map.Map Ident IdentExport -> ([Ident],CS.TypeExpr) -> Map.Map Ident IdentExport
bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo
Björn Peemöller 's avatar
Björn Peemöller committed
871
  where expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)
872
bindEnvRecordLabel _ _ _ = internalError "GenFlatCurry.bindEnvRecordLabel: no pattern match"