GenFlatCurry.hs 41.3 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
2 3 4 5 6 7 8
--
-- GenFlatCurry - Generates FlatCurry program terms and FlatCurry interfaces
--                (type 'FlatCurry.Prog')
--
-- November 2005,
-- Martin Engelke (men@informatik.uni-kiel.de)
--
Björn Peemöller 's avatar
Björn Peemöller committed
9
-- ---------------------------------------------------------------------------
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
import Control.Monad (filterM, liftM, liftM2, liftM3, mplus, when)
14
import Control.Monad.State (State, runState, gets, modify)
Björn Peemöller 's avatar
Björn Peemöller committed
15
import Data.List (mapAccumL, nub)
16 17
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 21 22 23 24 25
import Curry.Base.MessageMonad
import Curry.Base.Ident as Id
import Curry.ExtendedFlat.Type
import Curry.ExtendedFlat.TypeInference
import qualified Curry.Syntax as CS

Björn Peemöller 's avatar
Björn Peemöller committed
26
-- Base
27
import Base.Messages (internalError, qposMsg)
Björn Peemöller 's avatar
Björn Peemöller committed
28 29 30
import Base.ScopeEnv (ScopeEnv)
import qualified Base.ScopeEnv as ScopeEnv
import Base.TopEnv (topEnvMap)
Björn Peemöller 's avatar
Björn Peemöller committed
31
import Base.Types
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
32

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

-- other
import CompilerOpts (Options (..))
import qualified IL as IL
import qualified ModuleSummary
import Transformations (translType)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
43 44 45 46 47 48 49

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

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

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

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

65 66 67
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
68
  | otherwise    = p
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
69

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

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

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
97
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
98 99 100 101 102 103 104

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

127
data IdentExport
Björn Peemöller 's avatar
Björn Peemöller committed
128 129 130
  = NotConstr     -- function, type-constructor
  | OnlyConstr    -- constructor
  | NotOnlyConstr -- constructor, function, type-constructor
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
131 132

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

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

--
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
179 180
  modify $ \ s -> s { localTypes = Map.fromList ts }
  ops     <- genOpDecls
181
  whenFlatCurry
Björn Peemöller 's avatar
Björn Peemöller committed
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
    ( 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
209 210 211

--
visitDataDecl :: IL.Decl -> FlatState TypeDecl
212
visitDataDecl (IL.DataDecl qident arity constrs) = do
Björn Peemöller 's avatar
Björn Peemöller committed
213 214 215 216
  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
217 218 219 220
visitDataDecl _ = internalError "GenFlatCurry: no data declaration"

--
visitConstrDecl :: IL.ConstrDecl [IL.Type] -> FlatState [ConsDecl]
221
visitConstrDecl (IL.ConstrDecl qident types) = do
Björn Peemöller 's avatar
Björn Peemöller committed
222 223 224 225 226 227 228
  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
229 230 231

--
visitType :: IL.Type -> FlatState TypeExpr
232
visitType (IL.TypeConstructor qid tys) = do
Björn Peemöller 's avatar
Björn Peemöller committed
233 234 235 236 237 238
  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
239
visitType (IL.TypeArrow       ty1 ty2) = do
Björn Peemöller 's avatar
Björn Peemöller committed
240 241 242
  ty1' <- visitType ty1
  ty2' <- visitType ty2
  return $ FuncType ty1' ty2'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
243 244 245

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

--
visitExpression :: IL.Expression -> FlatState Expr
Björn Peemöller 's avatar
Björn Peemöller committed
279 280 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
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'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
320 321 322

--
visitLiteral :: IL.Literal -> FlatState Literal
Björn Peemöller 's avatar
Björn Peemöller committed
323 324 325
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
326 327 328

--
visitAlt :: IL.Alt -> FlatState BranchExpr
Björn Peemöller 's avatar
Björn Peemöller committed
329
visitAlt (IL.Alt p e) = liftM2 Branch (visitConstrTerm p) (visitExpression e)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
330 331 332

--
visitConstrTerm :: IL.ConstrTerm -> FlatState Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
333 334 335 336 337 338
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
339 340 341 342 343 344 345 346

--
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
347
visitBinding (IL.Binding v e) = liftM2 (,) (lookupVarIndex v) (visitExpression e)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
348 349 350 351 352

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

--
visitFuncIDecl :: CS.IDecl -> FlatState FuncDecl
Björn Peemöller 's avatar
Björn Peemöller committed
353 354 355 356
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
357 358 359 360
visitFuncIDecl _ = internalError "GenFlatCurry: no function interface"

--
visitTypeIDecl :: CS.IDecl -> FlatState TypeDecl
Björn Peemöller 's avatar
Björn Peemöller committed
361
visitTypeIDecl (CS.IDataDecl _ t vs cs) = do
362
  let mid = fromMaybe (internalError "GenFlatCurry: no module name") (qidModule t)
Björn Peemöller 's avatar
Björn Peemöller committed
363 364 365 366 367 368 369 370 371
      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
372 373 374 375
visitTypeIDecl _ = internalError "GenFlatCurry: no type interface"

--
visitConstrIDecl :: ModuleIdent -> [(Ident, Int)] -> CS.ConstrDecl
Björn Peemöller 's avatar
Björn Peemöller committed
376 377 378 379 380
                 -> 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
381
visitConstrIDecl mid tis (CS.ConOpDecl pos ids type1 ident type2)
Björn Peemöller 's avatar
Björn Peemöller committed
382
  = visitConstrIDecl mid tis (CS.ConstrDecl pos ids ident [type1,type2])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
383 384 385

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

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

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

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

-- 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
413 414
visitQualTypeIdent qident = do
  mid <- moduleId
415
  let (mmod, ident) = (qidModule qident, qidIdent qident)
Björn Peemöller 's avatar
Björn Peemöller committed
416 417 418 419
      modid | elem ident [listId, consId, nilId, unitId] || isTupleId ident
            = Id.moduleName preludeMIdent
            | otherwise
            = maybe (Id.moduleName mid) Id.moduleName mmod
420
  return (QName Nothing Nothing modid $ idName ident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
421 422 423 424

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


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

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

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

--
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
446
getExpImports _      expenv [] = expenv
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
447
getExpImports mident expenv ((CS.Export qident):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
448 449 450
  = getExpImports mident
    (bindExpImport mident qident (CS.Export qident) expenv)
    exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
451
getExpImports mident expenv ((CS.ExportTypeWith qident idents):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
452 453 454
  = getExpImports mident
    (bindExpImport mident qident (CS.ExportTypeWith qident idents) expenv)
    exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
455
getExpImports mident expenv ((CS.ExportTypeAll qident):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
456 457 458
  = getExpImports mident
    (bindExpImport mident qident (CS.ExportTypeAll qident) expenv)
    exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
459
getExpImports mident expenv ((CS.ExportModule mident'):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
460
  = getExpImports mident (Map.insert mident' [] expenv) exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
461 462 463 464 465

--
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
466 467 468
  | isJust (localIdent mident qident)
  = expenv
  | otherwise
469
  = let (Just modid) = qidModule qident
Björn Peemöller 's avatar
Björn Peemöller committed
470 471 472
    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
473 474 475 476 477 478 479 480

--
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
481 482 483 484
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
485
 where
Björn Peemöller 's avatar
Björn Peemöller committed
486 487 488 489
  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
490 491 492 493

--
isExportedIDecl :: [CS.Export] -> CS.IDecl -> Bool
isExportedIDecl exprts (CS.IInfixDecl _ _ _ qident)
Björn Peemöller 's avatar
Björn Peemöller committed
494
  = isExportedQualIdent qident exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
495
isExportedIDecl exprts (CS.IDataDecl _ qident _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
496
  = isExportedQualIdent qident exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
497
isExportedIDecl exprts (CS.ITypeDecl _ 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.IFunctionDecl _ qident _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
500
  = isExportedQualIdent qident exprts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
501 502 503 504 505 506
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
507
  = qident == qident' || isExportedQualIdent qident exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
508
isExportedQualIdent qident ((CS.ExportTypeWith qident' _):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
509
  = qident == qident' || isExportedQualIdent qident exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
510
isExportedQualIdent qident ((CS.ExportTypeAll 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.ExportModule _):exps)
Björn Peemöller 's avatar
Björn Peemöller committed
513
  = isExportedQualIdent qident exps
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
514 515 516 517

--
qualifyIDecl :: ModuleIdent -> CS.IDecl -> CS.IDecl
qualifyIDecl mident (CS.IInfixDecl pos fixi prec qident)
Björn Peemöller 's avatar
Björn Peemöller committed
518
  = (CS.IInfixDecl pos fixi prec (qualQualify mident qident))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
519
qualifyIDecl mident (CS.IDataDecl pos qident idents cdecls)
Björn Peemöller 's avatar
Björn Peemöller committed
520
  = (CS.IDataDecl pos (qualQualify mident qident) idents cdecls)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
521
qualifyIDecl mident (CS.INewtypeDecl pos qident idents ncdecl)
Björn Peemöller 's avatar
Björn Peemöller committed
522
  = (CS.INewtypeDecl pos (qualQualify mident qident) idents ncdecl)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
523
qualifyIDecl mident (CS.ITypeDecl pos qident idents texpr)
Björn Peemöller 's avatar
Björn Peemöller committed
524
  = (CS.ITypeDecl pos (qualQualify mident qident) idents texpr)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
525
qualifyIDecl mident (CS.IFunctionDecl pos qident arity texpr)
Björn Peemöller 's avatar
Björn Peemöller committed
526
  = (CS.IFunctionDecl pos (qualQualify mident qident) arity texpr)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
527 528 529 530 531 532 533 534 535 536 537 538 539 540
qualifyIDecl _ idecl = idecl


--
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
541 542 543 544
genFlatApplication e1 e2 = genFlatApplic [e2] e1
  where
  genFlatApplic args expression = case expression of
    (IL.Apply expr1 expr2) -> genFlatApplic (expr2:args) expr1
545
    (IL.Function qident _) -> do
Björn Peemöller 's avatar
Björn Peemöller committed
546 547 548 549 550 551 552 553 554 555 556 557 558 559
      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
560 561 562 563

--
genFuncCall :: QName -> Int -> [IL.Expression] -> FlatState Expr
genFuncCall qname arity args
Björn Peemöller 's avatar
Björn Peemöller committed
564
  | arity > cnt = genComb qname args $ FuncPartCall $ arity - cnt
565
  | arity < cnt = do
Björn Peemöller 's avatar
Björn Peemöller committed
566 567 568 569
      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
570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593
 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
594 595 596 597 598 599
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
600 601 602 603 604 605 606

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

--
genOpDecl :: CS.IDecl -> FlatState OpDecl
Björn Peemöller 's avatar
Björn Peemöller committed
607 608 609
genOpDecl (CS.IInfixDecl _ fixity prec qident) = do
  qname <- visitQualIdent qident
  return $ Op qname (genFixity fixity) prec
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
610 611
genOpDecl _ = internalError "GenFlatCurry: no infix interface"

Björn Peemöller 's avatar
Björn Peemöller committed
612 613 614 615
genFixity :: CS.Infix -> Fixity
genFixity CS.InfixL = InfixlOp
genFixity CS.InfixR = InfixrOp
genFixity CS.Infix  = InfixOp
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
616 617 618

-- 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
619
-- representation of all type synonyms is generated (see "ModuleSummary")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
620 621 622 623 624 625 626
-- 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
627 628 629 630 631 632 633 634 635
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
636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662
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]
663
	    (modid,ident) = (qidModule qident, qidIdent qident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
664 665 666 667
	qname <- visitQualIdent ((maybe qualify qualifyWith modid)
				 (recordExtId ident))
	labels <- mapM (genRecordLabel modid (zip params is)) fields
	return (Type qname Public is labels)
668
genRecordType _ = internalError "GenFlatCurry.genRecordType: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
669 670 671 672 673 674 675 676

--
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
677
        texpr <- visitType (snd (cs2ilType vis typeexpr'))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
678 679 680
	qname <- visitQualIdent ((maybe qualify qualifyWith modid)
				 (labelExtId ident))
	return (Cons qname 1 Public [texpr])
681
genRecordLabel _ _ _ = internalError "GenFlatCurry.genRecordLabel: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
682 683 684 685 686 687 688 689 690 691 692 693 694 695 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


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

-- 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
726
matchTypeVars fs ms (l,ty) = maybe ms (match ms ty) (lookup l fs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745
  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
746 747
flattenRecordTypeFields :: [([Ident], CS.TypeExpr)] -> [(Ident, CS.TypeExpr)]
flattenRecordTypeFields = concatMap (\ (ls, ty) -> map (\l -> (l, ty)) ls)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
748 749 750 751 752

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

--
checkOverlapping :: Expr -> Expr -> FlatState ()
753 754 755 756
checkOverlapping expr1 expr2 = do
  opts <- compilerOpts
  when (optOverlapWarn opts) $ checkOverlap expr1 expr2
  where
Björn Peemöller 's avatar
Björn Peemöller committed
757 758 759
  checkOverlap (Case _ _ _ _) _ = functionId >>= genWarning . overlappingRules
  checkOverlap _ (Case _ _ _ _) = functionId >>= genWarning . overlappingRules
  checkOverlap _ _              = return ()
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
760 761 762 763

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

--
Björn Peemöller 's avatar
Björn Peemöller committed
764
cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> ([(Ident,Int)], IL.Type)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
765
cs2ilType ids (CS.ConstructorType qident typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
766 767
  = let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs
    in  (ids', IL.TypeConstructor qident ilTypeexprs)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
768
cs2ilType ids (CS.VariableType ident)
Björn Peemöller 's avatar
Björn Peemöller committed
769 770 771 772 773 774
  = 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
775
cs2ilType ids (CS.ArrowType type1 type2)
Björn Peemöller 's avatar
Björn Peemöller committed
776 777 778
  = let (ids',  ilType1) = cs2ilType ids type1
        (ids'', ilType2) = cs2ilType ids' type2
    in  (ids'', IL.TypeArrow ilType1 ilType2)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
779
cs2ilType ids (CS.ListType typeexpr)
Björn Peemöller 's avatar
Björn Peemöller committed
780 781
  = let (ids', ilTypeexpr) = cs2ilType ids typeexpr
    in  (ids', IL.TypeConstructor (qualify listId) [ilTypeexpr])
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
782
cs2ilType ids (CS.TupleType typeexprs)
Björn Peemöller 's avatar
Björn Peemöller committed
783 784 785 786 787 788 789
  = 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
790 791 792

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

Björn Peemöller 's avatar
Björn Peemöller committed
796
consArity :: Show a => a -> [Char]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
797
consArity qid = "GenFlatCurry: missing arity for constructor \""
Björn Peemöller 's avatar
Björn Peemöller committed
798
  ++ show qid ++ "\""
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
799

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

803 804
overlappingRules :: QualIdent -> Message
overlappingRules qid = qposMsg qid $ "Function \"" ++ qualName qid
Björn Peemöller 's avatar
Björn Peemöller committed
805
  ++ "\" is non-deterministic due to non-trivial overlapping rules"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
806 807 808 809 810 811

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

--
isDataDecl :: IL.Decl -> Bool
isDataDecl (IL.DataDecl _ _ _) = True
Björn Peemöller 's avatar
Björn Peemöller committed
812
isDataDecl _                   = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
813 814 815 816 817 818 819 820 821

--
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
822 823
isPublicDataDecl (IL.DataDecl qident _ _) = isPublic False qident
isPublicDataDecl _                        = return False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855

--
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
856
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
857 858 859 860 861 862 863 864 865 866 867

--
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
868
setFunctionId qid = modify $ \ s -> s { functionIdE = qid }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
869 870 871 872 873 874 875 876 877 878

--
compilerOpts :: FlatState Options
compilerOpts = gets compilerOptsE

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

--
879
imports :: FlatState [CS.IImportDecl]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895
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
896 897
isPublic isConstr qid = gets $ \ s -> maybe False isP
  (Map.lookup (unqualify qid) $ publicEnvE s)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
898
  where
Björn Peemöller 's avatar
Björn Peemöller committed
899 900 901
  isP NotConstr     = not isConstr
  isP OnlyConstr    = isConstr
  isP NotOnlyConstr = True
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
902 903

--
904 905
lookupModuleIntf :: ModuleIdent -> FlatState (Maybe CS.Interface)
lookupModuleIntf mid = gets (Map.lookup mid . interfaceEnvE)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
906 907 908

--
lookupIdArity :: QualIdent -> FlatState (Maybe Int)
Björn Peemöller 's avatar
Björn Peemöller committed
909
lookupIdArity qid = gets (lookupA . typeEnvE)
910
  where
Björn Peemöller 's avatar
Björn Peemöller committed
911
  lookupA tyEnv = case qualLookupValue qid tyEnv of
912 913 914
    [DataConstructor  _ a _] -> Just a
    [NewtypeConstructor _ _] -> Just 1
    [Value            _ a _] -> Just a
Björn Peemöller 's avatar
Björn Peemöller committed
915
    []                       -> case lookupValue (unqualify qid) tyEnv of
916 917 918 919 920
      [DataConstructor  _ a _] -> Just a
      [NewtypeConstructor _ _] -> Just 1
      [Value            _ a _] -> Just a
      _                        -> Nothing
    _                        -> Nothing
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
921

922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937
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
938 939 940 941 942 943

-- 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
944 945
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
946
lookupIdType (QualIdent Nothing (Ident _ ":" _))
Björn Peemöller 's avatar
Björn Peemöller committed
947 948
  = return (Just (FuncType (TVar 0) (FuncType (l0) (l0))))
  where l0 = TCons (mkQName ("Prelude", "[]")) [TVar 0]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
949
lookupIdType (QualIdent Nothing (Ident _ "()" _))
Björn Peemöller 's avatar
Björn Peemöller committed
950 951
  = return (Just l0)
  where l0 = TCons (mkQName ("Prelude", "()")) []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
952
lookupIdType (QualIdent Nothing (Ident _ t@('(':',':r) _))
Björn Peemöller 's avatar
Björn Peemöller committed
953 954 955 956 957
  = return $ Just funtype
  where tupArity   = length r + 1
        argTypes   = map TVar [1 .. tupArity]
        contype    = TCons (mkQName ("Prelude", t)) argTypes
        funtype    = foldr FuncType contype argTypes
958 959 960 961
lookupIdType qid = do
  aEnv <- gets typeEnvE
  lt <- gets localTypes
  ct <- gets constrTypes
962 963 964
  m  <- gets moduleIdE
  tyEnv <- gets typeEnvE
  tcEnv <- gets tConsEnvE
965
  case Map.lookup qid lt `mplus` Map.lookup qid ct of
Björn Peemöller 's avatar
Björn Peemöller committed
966
    Just t  -> trace' ("lookupIdType local " ++ show (qid, t)) $ liftM Just (visitType t)  -- local name or constructor
967
    Nothing -> case [ t | Value _ _ (ForAll _ t) <- qualLookupValue qid aEnv ] of
968
      t : _ -> liftM Just (visitType (translType m tyEnv tcEnv t))  -- imported name
969
      []    -> case qidModule qid of
Björn Peemöller 's avatar
Björn Peemöller committed
970
        Nothing -> trace' ("no type for "  ++ show qid) $ return Nothing  -- no known type
971
        Just _ -> lookupIdType qid {qidModule = Nothing}
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
972 973 974 975
--

-- Generates a new index for a variable
newVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
976 977 978 979 980 981
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
982

983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002
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
1003 1004
--
lookupVarIndex :: Ident -> FlatState VarIndex
Björn Peemöller 's avatar
Björn Peemöller committed
1005 1006 1007
lookupVarIndex ident = do
  index_ <- gets (ScopeEnv.lookup ident . varIdsE)
  maybe (internalError $ missingVarIndex ident) return index_
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1008 1009 1010

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

--
1014 1015
genWarning :: Message -> FlatState ()
genWarning msg = modify $ \ s -> s { messagesE = msg : messagesE s }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1016 1017 1018 1019 1020

--
genInterface :: FlatState Bool
genInterface = gets genInterfaceE

Björn Peemöller 's avatar
Björn Peemöller committed
1021 1022 1023 1024 1025 1026
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
1027 1028 1029 1030

--
whenFlatCurry :: FlatState a -> FlatState a -> FlatState a
whenFlatCurry genFlat genIntf
Björn Peemöller 's avatar
Björn Peemöller committed
1031
  = genInterface >>= (\intf -> if intf then genIntf else genFlat)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043

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

-- 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
1044 1045 1046
  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
1047
  where
Björn Peemöller 's avatar
Björn Peemöller committed
1048 1049 1050 1051 1052
  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
1053 1054 1055 1056

--
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
1057 1058 1059 1060
  = maybe env
    (\ident -> foldl bindEnvConstrDecl (bindIdentExport ident False env)
            (catMaybes mcdecls))
    (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1061
bindEnvIDecl mid env (CS.INewtypeDecl _ qid _ ncdecl)
Björn Peemöller 's avatar
Björn Peemöller committed
1062 1063 1064
  = maybe env
    (\ident -> bindEnvNewConstrDecl (bindIdentExport ident False env) ncdecl)
    (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1065
bindEnvIDecl mid env (CS.ITypeDecl _ qid _ texpr)
Björn Peemöller 's avatar
Björn Peemöller committed
1066
  = maybe env (\ident -> bindEnvITypeDecl env ident texpr) (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1067
bindEnvIDecl mid env (CS.IFunctionDecl _ qid _ _)
Björn Peemöller 's avatar
Björn Peemöller committed
1068
  = maybe env (\ident -> bindIdentExport ident False env) (localIdent mid qid)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1069 1070 1071 1072
bindEnvIDecl _ env _ = env

--
bindEnvITypeDecl :: Map.Map Ident IdentExport -> Ident -> CS.TypeExpr
Björn Peemöller 's avatar
Björn Peemöller committed
1073
                 -> Map.Map Ident IdentExport
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed