GenFlatCurry.hs 42 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
-- Haskell libraries
Björn Peemöller 's avatar
Björn Peemöller committed
13 14 15 16 17
import           Control.Monad       (filterM, liftM, liftM2, liftM3, mplus, when)
import           Control.Monad.State (State, runState, gets, modify)
import           Data.List           (mapAccumL, nub)
import qualified Data.Map as Map     (Map, empty, insert, lookup, fromList, toList)
import           Data.Maybe          (catMaybes, fromJust, fromMaybe, isJust)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
18

19
-- curry-base
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
20
import Curry.Base.Ident as Id
Björn Peemöller 's avatar
Björn Peemöller committed
21 22 23
import Curry.Base.Message
import Curry.Base.Pretty

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
24 25 26
import Curry.ExtendedFlat.Type
import qualified Curry.Syntax as CS

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

Björn Peemöller 's avatar
Björn Peemöller committed
36
 -- environments
Björn Peemöller 's avatar
Björn Peemöller committed
37
import Env.Interface
38
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
39
import Env.OpPrec (mkPrec)
Björn Peemöller 's avatar
Björn Peemöller committed
40 41 42
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)

-- other
43
import CompilerOpts (Options (..), WarnOpts (..), WarnFlag (..))
Björn Peemöller 's avatar
Björn Peemöller committed
44 45
import qualified IL as IL
import qualified ModuleSummary
46
import Transformations (transType)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
47 48 49 50 51 52 53

trace' :: String -> a -> a
trace' _ x = x

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

-- transforms intermediate language code (IL) to FlatCurry code
54 55
genFlatCurry :: Options -> ModuleSummary.ModuleSummary -> InterfaceEnv
             -> ValueEnv -> TCEnv -> IL.Module -> (Prog, [Message])
56
genFlatCurry opts modSum mEnv tyEnv tcEnv mdl = (prog', messages)
57
  where
58
  (prog, messages) = run opts modSum mEnv tyEnv tcEnv False (visitModule mdl)
59
  prog' = patchPrelude prog -- eraseTypes $ adjustTypeInfo $
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
60

Björn Peemöller 's avatar
Björn Peemöller committed
61
-- transforms intermediate language code (IL) to FlatCurry interfaces
62
genFlatInterface :: Options -> ModuleSummary.ModuleSummary -> InterfaceEnv
Björn Peemöller 's avatar
Björn Peemöller committed
63 64
                 -> ValueEnv -> TCEnv -> IL.Module -> (Prog, [Message])
genFlatInterface opts modSum mEnv tyEnv tcEnv mdl = (intf' , messages)
65
  where
Björn Peemöller 's avatar
Björn Peemöller committed
66
  (intf, messages) = run opts modSum mEnv tyEnv tcEnv True (visitModule mdl)
67
  intf'            = patchPrelude intf
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
68

69 70 71
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
72
  | otherwise    = p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
73

74 75
preludeTypes :: [TypeDecl]
preludeTypes =
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
76 77
  [ Type unit Public [] [(Cons unit 0 Public [])]
  , Type nil Public [0]
Björn Peemöller 's avatar
Björn Peemöller committed
78 79
    [ Cons nil  0 Public []
    , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
80
    ]
81
  ] ++ map mkTupleType [2 .. maxTupleArity]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
82 83
  where unit = mkPreludeQName "()"
        nil  = mkPreludeQName "[]"
Björn Peemöller 's avatar
Björn Peemöller committed
84
        cons = mkPreludeQName ":"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
85

86 87
mkTupleType :: Int -> TypeDecl
mkTupleType arity = Type tuple Public [0 .. arity - 1]
Björn Peemöller 's avatar
Björn Peemöller committed
88 89
  [Cons tuple arity Public (map TVar [0 .. arity - 1])]
  where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
90 91 92 93 94 95 96 97 98 99 100

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
101
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
102 103 104 105 106 107 108

-- 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
109 110 111 112
data FlatEnv = FlatEnv
  { moduleIdE     :: ModuleIdent
  , functionIdE   :: (QualIdent, [(Ident, IL.Type)])
  , compilerOptsE :: Options
Björn Peemöller 's avatar
Björn Peemöller committed
113
  , interfaceEnvE :: InterfaceEnv
Björn Peemöller 's avatar
Björn Peemöller committed
114 115 116 117 118
  , typeEnvE      :: ValueEnv     -- types of defined values
  , tConsEnvE     :: TCEnv
  , publicEnvE    :: Map.Map Ident IdentExport
  , fixitiesE     :: [CS.IDecl]
  , typeSynonymsE :: [CS.IDecl]
119
  , importsE      :: [CS.IImportDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
120 121 122 123 124
  , exportsE      :: [CS.Export]
  , interfaceE    :: [CS.IDecl]
  , varIndexE     :: Int
  , varIdsE       :: ScopeEnv Ident VarIndex
  , tvarIndexE    :: Int
125
  , messagesE     :: [Message]
Björn Peemöller 's avatar
Björn Peemöller committed
126 127 128 129
  , genInterfaceE :: Bool
  , localTypes    :: Map.Map QualIdent IL.Type
  , constrTypes   :: Map.Map QualIdent IL.Type
  }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
130

131
data IdentExport
Björn Peemöller 's avatar
Björn Peemöller committed
132 133 134
  = NotConstr     -- function, type-constructor
  | OnlyConstr    -- constructor
  | NotOnlyConstr -- constructor, function, type-constructor
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
135 136

-- Runs a 'FlatState' action and returns the result
137
run :: Options -> ModuleSummary.ModuleSummary -> InterfaceEnv -> ValueEnv -> TCEnv
138
    -> Bool -> FlatState a -> (a, [Message])
Björn Peemöller 's avatar
Björn Peemöller committed
139
run opts modSum mEnv tyEnv tcEnv genIntf f = (result, reverse $ messagesE env)
Björn Peemöller 's avatar
Björn Peemöller committed
140 141 142
  where
  (result, env) = runState f env0
  env0 = FlatEnv
Björn Peemöller 's avatar
Björn Peemöller committed
143
    { moduleIdE     = ModuleSummary.moduleId modSum
Björn Peemöller 's avatar
Björn Peemöller committed
144 145 146 147 148
    , functionIdE   = (qualify (mkIdent ""), [])
    , compilerOptsE = opts
    , interfaceEnvE = mEnv
    , typeEnvE      = tyEnv
    , tConsEnvE     = tcEnv
Björn Peemöller 's avatar
Björn Peemöller committed
149 150 151 152 153 154 155
    , 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
156 157 158 159 160 161
    , varIndexE     = 0
    , varIdsE       = ScopeEnv.new
    , tvarIndexE    = 0
    , messagesE     = []
    , genInterfaceE = genIntf
    , localTypes    = Map.empty
162
    , constrTypes   = Map.fromList $ getConstrTypes tcEnv tyEnv
Björn Peemöller 's avatar
Björn Peemöller committed
163
    }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
164

165 166
getConstrTypes :: TCEnv -> ValueEnv -> [(QualIdent, IL.Type)]
getConstrTypes tcEnv tyEnv =
167
  [ mkConstrType tqid conid argtys argc
Björn Peemöller 's avatar
Björn Peemöller committed
168 169 170
  | (_, (_, DataType tqid argc dts):_) <- Map.toList $ topEnvMap tcEnv
  , Just (DataConstr conid _ argtys) <- dts
  ]
171
  where
172
  mkConstrType tqid conid argtypes targnum = (conname, contype)
Björn Peemöller 's avatar
Björn Peemöller committed
173
    where
174
    conname    = QualIdent (qidModule tqid) conid
Björn Peemöller 's avatar
Björn Peemöller committed
175
    resulttype = IL.TypeConstructor tqid (map IL.TypeVariable [0 .. targnum - 1])
176
    contype    = foldr IL.TypeArrow resulttype $ map (ttrans tcEnv tyEnv) argtypes
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
177 178 179 180 181 182

--
visitModule :: IL.Module -> FlatState Prog
visitModule (IL.Module mid imps decls) = do
  -- insert local decls into localDecls
  let ts = [ (qn, t) | IL.FunctionDecl qn _ t _ <- decls ]
Björn Peemöller 's avatar
Björn Peemöller committed
183 184
  modify $ \ s -> s { localTypes = Map.fromList ts }
  ops     <- genOpDecls
185
  whenFlatCurry
Björn Peemöller 's avatar
Björn Peemöller committed
186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212
    ( do
      datas   <- mapM visitDataDecl (filter isDataDecl decls)
      types   <- genTypeSynonyms
      recrds  <- genRecordTypes
      funcs   <- mapM visitFuncDecl (filter isFuncDecl decls)
      modid   <- visitModuleIdent mid
      imps'   <- imports
      is      <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
      return $ Prog modid is (recrds ++ types ++ datas) funcs ops
    )
    ( do
      ds      <- filterM isPublicDataDecl decls
      datas   <- mapM visitDataDecl ds
      types   <- genTypeSynonyms
      recrds  <- genRecordTypes
      fs      <- filterM isPublicFuncDecl decls
      funcs   <- mapM visitFuncDecl fs
      expimps <- getExportedImports
      itypes  <- mapM visitTypeIDecl (filter isTypeIDecl expimps)
      ifuncs  <- mapM visitFuncIDecl (filter isFuncIDecl expimps)
      iops    <- mapM visitOpIDecl (filter isOpIDecl expimps)
      modid   <- visitModuleIdent mid
      imps'   <- imports
      is      <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
      return $ Prog modid is (itypes ++ recrds ++ types ++ datas) (ifuncs ++ funcs) (iops ++ ops)
    )
  where extractMid (CS.IImportDecl _ mid1) = mid1
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
213 214 215

--
visitDataDecl :: IL.Decl -> FlatState TypeDecl
216
visitDataDecl (IL.DataDecl qident arity constrs) = do
Björn Peemöller 's avatar
Björn Peemöller committed
217 218 219 220
  cdecls <- mapM visitConstrDecl constrs
  qname  <- visitQualTypeIdent qident
  vis    <- getVisibility False qident
  return $ Type qname vis [0 .. arity - 1] (concat cdecls)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
221 222 223 224
visitDataDecl _ = internalError "GenFlatCurry: no data declaration"

--
visitConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]
225
visitConstrDecl (IL.ConstrDecl qident types) = do
Björn Peemöller 's avatar
Björn Peemöller committed
226 227 228 229 230 231 232
  texprs  <- mapM visitType types
  qname   <- visitQualIdent qident
  vis     <- getVisibility True qident
  genFint <- genInterface
  return $ if genFint && vis == Private
    then []
    else [Cons qname (length types) vis texprs]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
233 234 235

--
visitType :: IL.Type -> FlatState TypeExpr
236
visitType (IL.TypeConstructor qid tys) = do
Björn Peemöller 's avatar
Björn Peemöller committed
237 238 239 240 241 242
  tys' <- mapM visitType tys
  qn   <- visitQualTypeIdent qid
  return $ if qualName qid == "Identity"
    then head tys'
    else TCons qn tys'
visitType (IL.TypeVariable        idx) = return $ TVar $ abs idx
243 244
visitType (IL.TypeArrow       ty1 ty2) = liftM2 FuncType
                                         (visitType ty1) (visitType ty2)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
245 246 247

--
visitFuncDecl :: IL.Decl -> FlatState FuncDecl
Björn Peemöller 's avatar
Björn Peemöller committed
248 249 250 251
visitFuncDecl (IL.FunctionDecl qident params typeexpr expression) = do
  let argtypes = splitoffArgTypes typeexpr params
  setFunctionId (qident, argtypes)
  qname <- visitQualIdent qident
252
  arity <- fromMaybe (length params) `liftM` lookupIdArity qident
Björn Peemöller 's avatar
Björn Peemöller committed
253 254 255 256 257 258
  whenFlatCurry
    (do is    <- mapM newVarIndex params
        texpr <- visitType typeexpr
        expr  <- visitExpression expression
        vis   <- getVisibility False qident
        clearVarIndices
259
        return (Func qname arity vis texpr (Rule is expr))
Björn Peemöller 's avatar
Björn Peemöller committed
260 261 262
    )
    (do texpr <- visitType typeexpr
        clearVarIndices
263
        return (Func qname arity Public texpr (Rule [] (Var $ mkIdx 0)))
Björn Peemöller 's avatar
Björn Peemöller committed
264 265 266 267 268
    )
visitFuncDecl (IL.ExternalDecl qident _ extname typeexpr) = do
  setFunctionId (qident, [])
  texpr <- visitType typeexpr
  qname <- visitQualIdent qident
269
  arity <- fromMaybe (typeArity typeexpr) `liftM` lookupIdArity qident
Björn Peemöller 's avatar
Björn Peemöller committed
270 271
  vis   <- getVisibility False qident
  xname <- visitExternalName extname
272
  return $ Func qname arity vis texpr (External xname)
Björn Peemöller 's avatar
Björn Peemöller committed
273 274 275 276
visitFuncDecl (IL.NewtypeDecl _ _ _) = do
  mid <- moduleId
  internalError $ "\"" ++ Id.moduleName mid
    ++ "\": newtype declarations are not supported"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
277 278 279 280
visitFuncDecl _ = internalError "GenFlatCurry: no function declaration"

--
visitExpression :: IL.Expression -> FlatState Expr
Björn Peemöller 's avatar
Björn Peemöller committed
281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321
visitExpression (IL.Literal       l) = Lit `liftM` visitLiteral l
visitExpression (IL.Variable      v) = Var `liftM` lookupVarIndex v
visitExpression (IL.Function    f _) = do
  arity_ <- lookupIdArity f
  qname <- visitQualIdent f
  case arity_ of
    Nothing -> internalError $ funcArity qname
    Just a  -> genFuncCall qname a []
visitExpression (IL.Constructor c _) = do
  arity_ <- lookupIdArity c
  qname <- visitQualIdent c
  case arity_ of
    Nothing -> internalError $ consArity qname
    Just a  -> genConsCall qname a []
visitExpression (IL.Apply     e1 e2) = genFlatApplication e1 e2
visitExpression (IL.Case  r ea e bs) =
  liftM3 (Case r) (visitEval ea) (visitExpression e) (mapM visitAlt bs)
visitExpression (IL.Or        e1 e2) = do
  e1' <- visitExpression e1
  e2' <- visitExpression e2
  checkOverlapping e1' e2'
  return $ Or e1' e2'
visitExpression (IL.Exist       v e) = do
  idx <- newVarIndex v
  e'  <- visitExpression e
  return $ case e' of
    Free is e'' -> Free (idx : is) e''
    _           -> Free [idx] e'
visitExpression (IL.Let        bd e) = inNewScope $ do
  _ <- newVarIndex $ bindingIdent bd
  bind <- visitBinding bd
  e' <- visitExpression e
  return $ case e' of -- TODO bjp(2011-09-21): maybe remove again
    (Let binds e'') -> Let (bind:binds) e''
    _               -> Let [bind] e'
  -- is it correct that there is no endScope? (hsi): bjp: Just added, but no reasoning about
visitExpression (IL.Letrec    bds e) = inNewScope $ do
  mapM_ (newVarIndex . bindingIdent) bds
  bds' <- mapM visitBinding bds
  e' <- visitExpression e
  return $ Let bds' e'
322 323
visitExpression (IL.Typed e ty) = liftM2 Typed (visitExpression e)
                                               (visitType ty)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
324 325 326

--
visitLiteral :: IL.Literal -> FlatState Literal
Björn Peemöller 's avatar
Björn Peemöller committed
327 328 329
visitLiteral (IL.Char  rs c) = return $ Charc  rs c
visitLiteral (IL.Int   rs i) = return $ Intc   rs i
visitLiteral (IL.Float rs f) = return $ Floatc rs f
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
330 331 332

--
visitAlt :: IL.Alt -> FlatState BranchExpr
Björn Peemöller 's avatar
Björn Peemöller committed
333
visitAlt (IL.Alt p e) = liftM2 Branch (visitConstrTerm p) (visitExpression e)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
334 335 336

--
visitConstrTerm :: IL.ConstrTerm -> FlatState Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
337 338 339 340 341 342
visitConstrTerm (IL.LiteralPattern        l) = LPattern `liftM` visitLiteral l
visitConstrTerm (IL.ConstructorPattern c vs) =
  liftM2 (flip Pattern) (mapM newVarIndex vs) (visitQualIdent c) -- TODO: is this flip needed?
visitConstrTerm (IL.VariablePattern       _) = do
  mid <- moduleId
  internalError $ "\"" ++ Id.moduleName mid ++ "\": variable patterns are not supported"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
343 344 345 346 347 348 349 350

--
visitEval :: IL.Eval -> FlatState CaseType
visitEval IL.Rigid = return Rigid
visitEval IL.Flex  = return Flex

--
visitBinding :: IL.Binding -> FlatState (VarIndex, Expr)
Björn Peemöller 's avatar
Björn Peemöller committed
351
visitBinding (IL.Binding v e) = liftM2 (,) (lookupVarIndex v) (visitExpression e)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
352 353 354 355 356

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

--
visitFuncIDecl :: CS.IDecl -> FlatState FuncDecl
Björn Peemöller 's avatar
Björn Peemöller committed
357 358 359 360
visitFuncIDecl (CS.IFunctionDecl _ f a ty) = do
  texpr <- visitType $ snd $ cs2ilType [] ty
  qname <- visitQualIdent f
  return $ Func qname a Public texpr (Rule [] (Var $ mkIdx 0))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
361 362 363 364
visitFuncIDecl _ = internalError "GenFlatCurry: no function interface"

--
visitTypeIDecl :: CS.IDecl -> FlatState TypeDecl
Björn Peemöller 's avatar
Björn Peemöller committed
365
visitTypeIDecl (CS.IDataDecl _ t vs cs) = do
366
  let mid = fromMaybe (internalError "GenFlatCurry: no module name") (qidModule t)
Björn Peemöller 's avatar
Björn Peemöller committed
367 368 369 370 371 372 373 374 375
      is  = [0 .. length vs - 1]
  cdecls <- mapM (visitConstrIDecl mid $ zip vs is) $ catMaybes cs
  qname  <- visitQualTypeIdent t
  return $ Type qname Public is cdecls
visitTypeIDecl (CS.ITypeDecl _ t vs ty) = do
  let is = [0 .. length vs - 1]
  ty'   <- visitType $ snd $ cs2ilType (zip vs is) ty
  qname <- visitQualTypeIdent t
  return $ TypeSyn qname Public is ty'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
376 377 378 379
visitTypeIDecl _ = internalError "GenFlatCurry: no type interface"

--
visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl
Björn Peemöller 's avatar
Björn Peemöller committed
380 381 382 383 384
                 -> FlatState ConsDecl
visitConstrIDecl mid tis (CS.ConstrDecl _ _ ident typeexprs) = do
  texprs <- mapM (visitType . (snd . cs2ilType tis)) typeexprs
  qname  <- visitQualIdent (qualifyWith mid ident)
  return (Cons qname (length typeexprs) Public texprs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
385
visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
Björn Peemöller 's avatar
Björn Peemöller committed
386
  = visitConstrIDecl mid tis (CS.ConstrDecl pos ids ident [type1,type2])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
387 388 389

--
visitOpIDecl :: CS.IDecl -> FlatState OpDecl
390
visitOpIDecl (CS.IInfixDecl _ fixi mprec op) = do
Björn Peemöller 's avatar
Björn Peemöller committed
391
  op' <- visitQualIdent op
392
  return $ Op op' (genFixity fixi) (mkPrec mprec)
393
visitOpIDecl _ = internalError "GenFlatCurry.visitOpIDecl: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
394 395 396 397 398 399 400 401 402

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

--
visitModuleIdent :: ModuleIdent -> FlatState String
visitModuleIdent = return . Id.moduleName

--
visitQualIdent :: QualIdent -> FlatState QName
Björn Peemöller 's avatar
Björn Peemöller committed
403 404
visitQualIdent qident = do
  mid <- moduleId
405
  let (mmod, ident) = (qidModule qident, qidIdent qident)
Björn Peemöller 's avatar
Björn Peemöller committed
406 407 408 409 410
      modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
            = Id.moduleName preludeMIdent
            | otherwise
            = maybe (Id.moduleName mid) Id.moduleName mmod
  ftype <- lookupIdType qident
411
  return (QName Nothing ftype modid $ idName ident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
412 413 414 415 416

-- This variant of visitQualIdent does not look up the type of the identifier,
-- 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)
visitQualTypeIdent :: QualIdent -> FlatState QName
Björn Peemöller 's avatar
Björn Peemöller committed
417 418
visitQualTypeIdent qident = do
  mid <- moduleId
419
  let (mmod, ident) = (qidModule qident, qidIdent qident)
Björn Peemöller 's avatar
Björn Peemöller committed
420 421 422 423
      modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
            = Id.moduleName preludeMIdent
            | otherwise
            = maybe (Id.moduleName mid) Id.moduleName mmod
424
  return (QName Nothing Nothing modid $ idName ident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
425 426 427 428

--
visitExternalName :: String -> FlatState String
visitExternalName extname
Björn Peemöller 's avatar
Björn Peemöller committed
429
  = moduleId >>= \mid -> return (Id.moduleName mid ++ "." ++ extname)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
430 431 432 433 434 435


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

--
getVisibility :: Bool -> QualIdent -> FlatState Visibility
Björn Peemöller 's avatar
Björn Peemöller committed
436 437 438
getVisibility isConstr qident = do
  public <- isPublic isConstr qident
  return $ if public then Public else Private
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
439 440 441

--
getExportedImports :: FlatState [CS.IDecl]
Björn Peemöller 's avatar
Björn Peemöller committed
442 443 444 445
getExportedImports = do
  mid  <- moduleId
  exps <- exports
  genExportedIDecls $ Map.toList $ getExpImports mid Map.empty exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
446 447 448 449

--
getExpImports :: ModuleIdent -> Map.Map ModuleIdent [CS.Export] -> [CS.Export]
		 -> Map.Map ModuleIdent [CS.Export]
Björn Peemöller 's avatar
Björn Peemöller committed
450
getExpImports _      expenv [] = expenv
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
451
getExpImports mident expenv ((CS.Export qident):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
452 453 454
  = getExpImports mident
    (bindExpImport mident qident (CS.Export qident) expenv)
    exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
455
getExpImports mident expenv ((CS.ExportTypeWith qident idents):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
456 457 458
  = getExpImports mident
    (bindExpImport mident qident (CS.ExportTypeWith qident idents) expenv)
    exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
459
getExpImports mident expenv ((CS.ExportTypeAll qident):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
460 461 462
  = getExpImports mident
    (bindExpImport mident qident (CS.ExportTypeAll qident) expenv)
    exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
463
getExpImports mident expenv ((CS.ExportModule mident'):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
464
  = getExpImports mident (Map.insert mident' [] expenv) exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
465 466 467 468 469

--
bindExpImport :: ModuleIdent -> QualIdent -> CS.Export
	         -> Map.Map ModuleIdent [CS.Export] -> Map.Map ModuleIdent [CS.Export]
bindExpImport mident qident export expenv
Björn Peemöller 's avatar
Björn Peemöller committed
470 471 472
  | isJust (localIdent mident qident)
  = expenv
  | otherwise
473
  = let (Just modid) = qidModule qident
Björn Peemöller 's avatar
Björn Peemöller committed
474 475 476
    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
477 478 479 480 481 482 483 484

--
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
485 486 487 488
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
489
 where
Björn Peemöller 's avatar
Björn Peemöller committed
490 491 492 493
  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
494 495 496 497

--
isExportedIDecl :: [CS.Export] -> CS.IDecl -> Bool
isExportedIDecl exprts (CS.IInfixDecl _ _ _ qident)
Björn Peemöller 's avatar
Björn Peemöller committed
498
  = isExportedQualIdent qident exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
499
isExportedIDecl exprts (CS.IDataDecl _ qident _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
500
  = isExportedQualIdent qident exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
501
isExportedIDecl exprts (CS.ITypeDecl _ qident _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
502
  = isExportedQualIdent qident exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
503
isExportedIDecl exprts (CS.IFunctionDecl _ qident _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
504
  = isExportedQualIdent qident exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
505 506 507 508 509 510
isExportedIDecl _ _ = False

--
isExportedQualIdent :: QualIdent -> [CS.Export] -> Bool
isExportedQualIdent _ [] = False
isExportedQualIdent qident ((CS.Export qident'):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
511
  = qident == qident' || isExportedQualIdent qident exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
512
isExportedQualIdent qident ((CS.ExportTypeWith qident' _):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
513
  = qident == qident' || isExportedQualIdent qident exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
514
isExportedQualIdent qident ((CS.ExportTypeAll qident'):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
515
  = qident == qident' || isExportedQualIdent qident exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
516
isExportedQualIdent qident ((CS.ExportModule _):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
517
  = isExportedQualIdent qident exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
518 519 520

--
qualifyIDecl :: ModuleIdent -> CS.IDecl -> CS.IDecl
521 522 523 524 525 526 527 528 529 530 531
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
532 533
qualifyIDecl _ idecl = idecl

534 535 536 537 538 539 540 541 542
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 []

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
543 544 545 546 547 548 549 550 551 552 553 554

--
typeArity :: IL.Type -> Int
typeArity (IL.TypeArrow _ t)       = 1 + (typeArity t)
typeArity (IL.TypeConstructor _ _) = 0
typeArity (IL.TypeVariable _)      = 0


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

--
genFlatApplication :: IL.Expression -> IL.Expression -> FlatState Expr
Björn Peemöller 's avatar
Björn Peemöller committed
555 556 557 558
genFlatApplication e1 e2 = genFlatApplic [e2] e1
  where
  genFlatApplic args expression = case expression of
    (IL.Apply expr1 expr2) -> genFlatApplic (expr2:args) expr1
559
    (IL.Function qident _) -> do
Björn Peemöller 's avatar
Björn Peemöller committed
560 561 562 563 564 565 566 567 568 569 570 571 572 573
      arity_ <- lookupIdArity qident
      qname <- visitQualIdent qident
      maybe (internalError (funcArity qident))
            (\arity -> genFuncCall qname arity args)
            arity_
    (IL.Constructor qident _) -> do
      arity_ <- lookupIdArity qident
      qname <- visitQualIdent qident
      maybe (internalError (consArity qident))
            (\arity -> genConsCall qname arity args)
            arity_
    _ -> do
      expr <- visitExpression expression
      genApplicComb expr args
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
574 575 576 577

--
genFuncCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
genFuncCall qname arity args
Björn Peemöller 's avatar
Björn Peemöller committed
578
  | arity > cnt = genComb qname args $ FuncPartCall $ arity - cnt
579
  | arity < cnt = do
Björn Peemöller 's avatar
Björn Peemöller committed
580 581 582 583
      let (funcargs, applicargs) = splitAt arity args
      funccall <- genComb qname funcargs FuncCall
      genApplicComb funccall applicargs
   | otherwise  = genComb qname args FuncCall
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607
 where cnt = length args

--
genConsCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
genConsCall qname arity args
   | arity > cnt
     = genComb qname args (ConsPartCall (arity - cnt))
   | arity < cnt
     = do let (funcargs, applicargs) = splitAt arity args
	  conscall <- genComb qname funcargs ConsCall
	  genApplicComb conscall applicargs
   | otherwise
     = genComb qname args ConsCall
 where cnt = length args

--
genComb :: QName -> [IL.Expression] -> CombType -> FlatState Expr
genComb qname args combtype
   = do exprs <- mapM visitExpression args
	return (Comb combtype qname exprs)

--
genApplicComb :: Expr -> [IL.Expression] -> FlatState Expr
genApplicComb expr [] = return expr
Björn Peemöller 's avatar
Björn Peemöller committed
608 609 610 611 612 613
genApplicComb expr (e1:es) = do
  expr1 <- visitExpression e1
  qname <- visitQualIdent qidApply
  genApplicComb (Comb FuncCall qname [expr, expr1]) es
  where
  qidApply = qualifyWith preludeMIdent (mkIdent "apply")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
614 615 616 617 618 619 620

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

--
genOpDecl :: CS.IDecl -> FlatState OpDecl
621
genOpDecl (CS.IInfixDecl _ fixity mprec qident) = do
Björn Peemöller 's avatar
Björn Peemöller committed
622
  qname <- visitQualIdent qident
623
  return $ Op qname (genFixity fixity) (mkPrec mprec)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
624 625
genOpDecl _ = internalError "GenFlatCurry: no infix interface"

Björn Peemöller 's avatar
Björn Peemöller committed
626 627 628 629
genFixity :: CS.Infix -> Fixity
genFixity CS.InfixL = InfixlOp
genFixity CS.InfixR = InfixrOp
genFixity CS.Infix  = InfixOp
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
630 631 632

-- 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
633
-- representation of all type synonyms is generated (see "ModuleSummary")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
634 635 636 637 638 639 640
-- 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
Björn Peemöller 's avatar
Björn Peemöller committed
641 642 643 644 645 646 647 648 649
genTypeSynonym (CS.ITypeDecl _ qident params ty) = do
  let is = [0 .. (length params) - 1]
  tyEnv <- gets typeEnvE
  tcEnv <- gets tConsEnvE
  let ty' = elimRecordTypes tyEnv tcEnv ty
  texpr <- visitType $ snd $ cs2ilType (zip params is) ty'
  qname <- visitQualTypeIdent qident
  vis   <- getVisibility False qident
  return $ TypeSyn qname vis is texpr
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676
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
genRecordType (CS.ITypeDecl _ qident params (CS.RecordType fields _))
   = do let is = [0 .. (length params) - 1]
677
	    (modid,ident) = (qidModule qident, qidIdent qident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
678 679 680 681
	qname <- visitQualIdent ((maybe qualify qualifyWith modid)
				 (recordExtId ident))
	labels <- mapM (genRecordLabel modid (zip params is)) fields
	return (Type qname Public is labels)
682
genRecordType _ = internalError "GenFlatCurry.genRecordType: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
683 684 685 686 687 688 689 690

--
genRecordLabel :: Maybe ModuleIdent -> [(Ident,Int)] -> ([Ident],CS.TypeExpr)
	       -> FlatState ConsDecl
genRecordLabel modid vis ([ident],typeexpr)
   = do tyEnv <- gets typeEnvE
        tcEnv <- gets tConsEnvE
	let typeexpr' = elimRecordTypes tyEnv tcEnv typeexpr
Björn Peemöller 's avatar
Björn Peemöller committed
691
        texpr <- visitType (snd (cs2ilType vis typeexpr'))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
692 693 694
	qname <- visitQualIdent ((maybe qualify qualifyWith modid)
				 (labelExtId ident))
	return (Cons qname 1 Public [texpr])
695
genRecordLabel _ _ _ = internalError "GenFlatCurry.genRecordLabel: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739


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

-- 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.
elimRecordTypes :: ValueEnv -> TCEnv -> CS.TypeExpr -> CS.TypeExpr
elimRecordTypes tyEnv tcEnv (CS.ConstructorType qid typeexprs)
   = CS.ConstructorType qid (map (elimRecordTypes tyEnv tcEnv) typeexprs)
elimRecordTypes _ _ (CS.VariableType ident)
   = CS.VariableType ident
elimRecordTypes tyEnv tcEnv (CS.TupleType typeexprs)
   = CS.TupleType (map (elimRecordTypes tyEnv tcEnv) typeexprs)
elimRecordTypes tyEnv tcEnv (CS.ListType typeexpr)
   = CS.ListType (elimRecordTypes tyEnv tcEnv typeexpr)
elimRecordTypes tyEnv tcEnv (CS.ArrowType typeexpr1 typeexpr2)
   = CS.ArrowType (elimRecordTypes tyEnv tcEnv typeexpr1)
                  (elimRecordTypes tyEnv tcEnv typeexpr2)
elimRecordTypes tyEnv tcEnv (CS.RecordType fss _)
   = let fs = flattenRecordTypeFields fss
     in  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 = map (\i -> maybe
			 	          (CS.VariableType
					     (mkIdent ("#tvar" ++ show i)))
				          (elimRecordTypes tyEnv tcEnv)
				          (Map.lookup i ms))
			         [0 .. n-1]
	         in  CS.ConstructorType record types
	       _ -> internalError ("GenFlatCurry.elimRecordTypes: "
		 		   ++ "no record type")
	   _ -> internalError ("GenFlatCurry.elimRecordTypes: "
			       ++ "no label")

matchTypeVars :: [(Ident,CS.TypeExpr)] -> Map.Map Int CS.TypeExpr
	      -> (Ident, Type) -> Map.Map Int CS.TypeExpr
Björn Peemöller 's avatar
Björn Peemöller committed
740
matchTypeVars fs ms (l,ty) = maybe ms (match ms ty) (lookup l fs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759
  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]
  match ms1 (TypeRecord fs' _) (CS.RecordType fss _)
     = foldl (matchTypeVars (flattenRecordTypeFields fss)) ms1 fs'
  match _ ty1 typeexpr
     = internalError ("GenFlatCurry.matchTypeVars: "
		      ++ show ty1 ++ "\n" ++ show typeexpr)

  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
760 761
flattenRecordTypeFields :: [([Ident], CS.TypeExpr)] -> [(Ident, CS.TypeExpr)]
flattenRecordTypeFields = concatMap (\ (ls, ty) -> map (\l -> (l, ty)) ls)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
762 763 764 765 766

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

--
checkOverlapping :: Expr -> Expr -> FlatState ()
767
checkOverlapping e1 e2 = do
768 769
  warnOpts <- optWarnOpts `liftM` compilerOpts
  when (WarnOverlapping `elem` wnWarnFlags warnOpts) $ checkOverlap e1 e2
770
  where
Björn Peemöller 's avatar
Björn Peemöller committed
771 772 773
  checkOverlap (Case _ _ _ _) _ = functionId >>= genWarning . overlappingRules
  checkOverlap _ (Case _ _ _ _) = functionId >>= genWarning . overlappingRules
  checkOverlap _ _              = return ()
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
774 775 776 777

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

--
Björn Peemöller 's avatar
Björn Peemöller committed
778
cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> ([(Ident,Int)], IL.Type)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
779
cs2ilType ids (CS.ConstructorType qident typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
780 781
  = let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs
    in  (ids', IL.TypeConstructor qident ilTypeexprs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
782
cs2ilType ids (CS.VariableType ident)
Björn Peemöller 's avatar
Björn Peemöller committed
783 784 785 786 787 788
  = let mid        = lookup ident ids
        nid        | null ids  = 0
                   | otherwise = 1 + snd (head ids)
        (ident1, ids') | isJust mid = (fromJust mid, ids)
                       | otherwise  = (nid, (ident, nid):ids)
    in  (ids', IL.TypeVariable ident1)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
789
cs2ilType ids (CS.ArrowType type1 type2)
Björn Peemöller 's avatar
Björn Peemöller committed
790 791 792
  = let (ids',  ilType1) = cs2ilType ids type1
        (ids'', ilType2) = cs2ilType ids' type2
    in  (ids'', IL.TypeArrow ilType1 ilType2)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
793
cs2ilType ids (CS.ListType typeexpr)
Björn Peemöller 's avatar
Björn Peemöller committed
794 795
  = let (ids', ilTypeexpr) = cs2ilType ids typeexpr
    in  (ids', IL.TypeConstructor (qualify listId) [ilTypeexpr])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
796
cs2ilType ids (CS.TupleType typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
797 798 799 800 801 802 803
  = 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
804 805 806

-------------------------------------------------------------------------------
-- Messages for internal errors and warnings
Björn Peemöller 's avatar
Björn Peemöller committed
807 808
funcArity :: Show a => a -> [Char]
funcArity qid = "GenFlatCurry: missing arity for function \"" ++ show qid ++ "\""
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
809

Björn Peemöller 's avatar
Björn Peemöller committed
810
consArity :: Show a => a -> [Char]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
811
consArity qid = "GenFlatCurry: missing arity for constructor \""
Björn Peemöller 's avatar
Björn Peemöller committed
812
  ++ show qid ++ "\""
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
813

Björn Peemöller 's avatar
Björn Peemöller committed
814
missingVarIndex :: Show a => a -> [Char]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
815 816
missingVarIndex ident = "GenFlatCurry: missing index for \"" ++ show ident ++ "\""

817
overlappingRules :: QualIdent -> Message
818 819 820
overlappingRules qid = posMessage qid $ hsep $ map text
  [ "Function", '"' : qualName qid ++ "\""
  , "is non-deterministic due to non-trivial overlapping rules" ]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
821 822 823 824 825 826

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

--
isDataDecl :: IL.Decl -> Bool
isDataDecl (IL.DataDecl _ _ _) = True
Björn Peemöller 's avatar
Björn Peemöller committed
827
isDataDecl _                   = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
828 829 830 831 832 833 834 835 836

--
isFuncDecl :: IL.Decl -> Bool
isFuncDecl (IL.FunctionDecl _ _ _ _) = True
isFuncDecl (IL.ExternalDecl _ _ _ _) = True
isFuncDecl _                         = False

--
isPublicDataDecl :: IL.Decl -> FlatState Bool
Björn Peemöller 's avatar
Björn Peemöller committed
837 838
isPublicDataDecl (IL.DataDecl qident _ _) = isPublic False qident
isPublicDataDecl _                        = return False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870

--
isPublicFuncDecl :: IL.Decl -> FlatState Bool
isPublicFuncDecl (IL.FunctionDecl qident _ _ _) = isPublic False qident
isPublicFuncDecl (IL.ExternalDecl qident _ _ _) = isPublic False qident
isPublicFuncDecl _                              = return False

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

--
isRecordIDecl :: CS.IDecl -> Bool
isRecordIDecl (CS.ITypeDecl _ _ _ (CS.RecordType (_:_) _)) = True
isRecordIDecl _                                            = False

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

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

--
bindingIdent :: IL.Binding -> Ident
bindingIdent (IL.Binding ident _) = ident

Björn Peemöller 's avatar
Björn Peemöller committed
871
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
872 873 874 875 876 877 878 879 880 881 882

--
moduleId :: FlatState ModuleIdent
moduleId = gets moduleIdE

--
functionId :: FlatState QualIdent
functionId = gets (fst . functionIdE)

--
setFunctionId :: (QualIdent, [(Ident, IL.Type)]) -> FlatState ()
Björn Peemöller 's avatar
Björn Peemöller committed
883
setFunctionId qid = modify $ \ s -> s { functionIdE = qid }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
884 885 886 887 888 889 890 891 892 893

--
compilerOpts :: FlatState Options
compilerOpts = gets compilerOptsE

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

--
894
imports :: FlatState [CS.IImportDecl]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910
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
911 912
isPublic isConstr qid = gets $ \ s -> maybe False isP
  (Map.lookup (unqualify qid) $ publicEnvE s)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
913
  where
Björn Peemöller 's avatar
Björn Peemöller committed
914 915 916
  isP NotConstr     = not isConstr
  isP OnlyConstr    = isConstr
  isP NotOnlyConstr = True
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
917 918

--
919 920
lookupModuleIntf :: ModuleIdent -> FlatState (Maybe CS.Interface)
lookupModuleIntf mid = gets (Map.lookup mid . interfaceEnvE)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
921 922 923

--
lookupIdArity :: QualIdent -> FlatState (Maybe Int)
Björn Peemöller 's avatar
Björn Peemöller committed
924
lookupIdArity qid = gets (lookupA . typeEnvE)
925
  where
Björn Peemöller 's avatar
Björn Peemöller committed
926
  lookupA tyEnv = case qualLookupValue qid tyEnv of
927 928 929
    [DataConstructor  _ a _] -> Just a
    [NewtypeConstructor _ _] -> Just 1
    [Value            _ a _] -> Just a
Björn Peemöller 's avatar
Björn Peemöller committed
930
    []                       -> case lookupValue (unqualify qid) tyEnv of
931 932 933 934 935
      [DataConstructor  _ a _] -> Just a
      [NewtypeConstructor _ _] -> Just 1
      [Value            _ a _] -> Just a
      _                        -> Nothing
    _                        -> Nothing
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
936

937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952
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
ttrans _     _     (TypeRecord         [] _) = internalError $
  "Generators.GenFlatCurry.ttrans: empty type record"
ttrans tcEnv tyEnv (TypeRecord ((l, _):_) _) = case lookupValue l tyEnv of
  [Label _ rec _ ] -> case qualLookupTC rec tcEnv of
    [AliasType _ n (TypeRecord _ _)] ->
      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
953 954 955 956 957 958

-- 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
959 960
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
961
lookupIdType (QualIdent Nothing (Ident _ ":" _))
Björn Peemöller 's avatar
Björn Peemöller committed
962 963
  = return (Just (FuncType (TVar 0) (FuncType (l0) (l0))))
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
964
lookupIdType (QualIdent Nothing (Ident _ "()" _))
Björn Peemöller 's avatar
Björn Peemöller committed
965 966
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "()")) []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
967
lookupIdType (QualIdent Nothing (Ident _ t@('(':',':r) _))
Björn Peemöller 's avatar
Björn Peemöller committed
968 969 970 971 972
  = return $ Just funtype
  where tupArity   = length r + 1
        argTypes   = map TVar [1 .. tupArity]
        contype    = TCons (mkQName ("Prelude", t)) argTypes
        funtype    = foldr FuncType contype argTypes
973 974 975 976
lookupIdType qid = do
  aEnv <- gets typeEnvE
  lt <- gets localTypes
  ct <- gets constrTypes
977 978 979
  m  <- gets moduleIdE
  tyEnv <- gets typeEnvE
  tcEnv <- gets tConsEnvE
980
  case Map.lookup qid lt `mplus` Map.lookup qid ct of
Björn Peemöller 's avatar
Björn Peemöller committed
981
    Just t  -> trace' ("lookupIdType local " ++ show (qid, t)) $ liftM Just (visitType t)  -- local name or constructor
982
    Nothing -> case [ t | Value _ _ (ForAll _ t) <- qualLookupValue qid aEnv ] of
983
      t : _ -> liftM Just (visitType (transType m tyEnv tcEnv t))  -- imported name
984
      []    -> case qidModule qid of
Björn Peemöller 's avatar
Björn Peemöller committed
985
        Nothing -> trace' ("no type for "  ++ show qid) $ return Nothing  -- no known type
986
        Just _ -> lookupIdType qid {qidModule = Nothing}
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
987 988 989 990
--

-- Generates a new index for a variable
newVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
991 992 993 994 995 996
newVarIndex ident = do
  idx <- (+1) `liftM` gets varIndexE
  ty  <- getTypeOf ident
  let vid = VarIndex ty idx
  modify $ \ s -> s { varIndexE = idx, varIdsE = ScopeEnv.insert ident vid (varIdsE s) }
  return vid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
997

998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017
getTypeOf :: Ident -> FlatState (Maybe TypeExpr)
getTypeOf ident = do
  valEnv <- gets typeEnvE
  tcEnv  <- gets tConsEnvE
  case lookupValue ident valEnv of
    Value _ _ (ForAll _ t) : _ -> do
      t1 <- visitType (ttrans tcEnv valEnv t)
      trace' ("getTypeOf(" ++ show ident ++ ") = " ++ show t1) $
        return (Just t1)
    DataConstructor _ _ (ForAllExist _ _ t) : _ -> do
      t1 <- visitType (ttrans tcEnv valEnv t)
      trace' ("getTypeOfDataCon(" ++ show ident ++ ") = " ++ show t1) $
        return (Just t1)
    _ -> do
    (_, ats) <- gets functionIdE
    case lookup ident ats of
      Just t -> liftM Just (visitType t)
      Nothing -> trace' ("lookupValue did not return a value for index " ++ show ident)
                 (return Nothing)

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1018 1019
--
lookupVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
1020 1021 1022
lookupVarIndex ident = do
  index_ <- gets (ScopeEnv.lookup ident . varIdsE)
  maybe (internalError $ missingVarIndex ident) return index_
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1023 1024 1025

--
clearVarIndices :: FlatState ()
Björn Peemöller 's avatar
Björn Peemöller committed
1026
clearVarIndices = modify $ \ s -> s { varIndexE = 0, varIdsE = ScopeEnv.new }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1027 1028

--
1029 1030
genWarning :: Message -> FlatState ()
genWarning msg = modify $ \ s -> s { messagesE = msg : messagesE s }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1031 1032 1033 1034 1035

--
genInterface :: FlatState Bool
genInterface = gets genInterfaceE

Björn Peemöller 's avatar
Björn Peemöller committed
1036 1037 1038 1039 1040 1041
inNewScope :: FlatState a -> FlatState a
inNewScope act = do
  modify $ \ s -> s { varIdsE  = ScopeEnv.beginScope $ varIdsE s }
  res <- act
  modify $ \ s -> s { varIdsE  = ScopeEnv.endScope $ varIdsE s }
  return res
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1042 1043 1044 1045

--
whenFlatCurry :: FlatState a -> FlatState a -> FlatState a
whenFlatCurry genFlat genIntf
Björn Peemöller 's avatar
Björn Peemöller committed
1046
  = genInterface >>= (\intf -> if intf then genIntf else genFlat)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058

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

-- 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
1059 1060 1061
  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
1062
  where
Björn Peemöller 's avatar
Björn Peemöller committed
1063 1064 1065 1066 1067
  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
1068 1069 1070 1071

--
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
1072 1073 1074 1075
  = maybe env
    (\ident -> foldl bindEnvConstrDecl (bindIdentExport ident False env)
            (catMaybes mcdecls))
    (localIdent mid qid)