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)
18
import Text.PrettyPrint
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
19

20
-- curry-base
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
21 22 23 24 25 26
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
27
-- Base
28
import Base.Messages (internalError)
Björn Peemöller 's avatar
Björn Peemöller committed
29 30 31
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
32
import Base.Types
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
33

Björn Peemöller 's avatar
Björn Peemöller committed
34
 -- environments
Björn Peemöller 's avatar
Björn Peemöller committed
35
import Env.Interface
36
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
Björn Peemöller 's avatar
Björn Peemöller committed
37 38 39 40 41 42 43
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
44 45 46 47 48 49 50

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

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

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

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

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

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

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

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

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

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

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

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

--
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
180 181
  modify $ \ s -> s { localTypes = Map.fromList ts }
  ops     <- genOpDecls
182
  whenFlatCurry
Björn Peemöller 's avatar
Björn Peemöller committed
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 209
    ( 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
210 211 212

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

--
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
519
  = (CS.IInfixDecl pos fixi prec (qualQualify mident qident))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
520
qualifyIDecl mident (CS.IDataDecl pos qident idents cdecls)
Björn Peemöller 's avatar
Björn Peemöller committed
521
  = (CS.IDataDecl pos (qualQualify mident qident) idents cdecls)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
522
qualifyIDecl mident (CS.INewtypeDecl pos qident idents ncdecl)
Björn Peemöller 's avatar
Björn Peemöller committed
523
  = (CS.INewtypeDecl pos (qualQualify mident qident) idents ncdecl)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
524
qualifyIDecl mident (CS.ITypeDecl pos qident idents texpr)
Björn Peemöller 's avatar
Björn Peemöller committed
525
  = (CS.ITypeDecl pos (qualQualify mident qident) idents texpr)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
526
qualifyIDecl mident (CS.IFunctionDecl pos qident arity texpr)
Björn Peemöller 's avatar
Björn Peemöller committed
527
  = (CS.IFunctionDecl pos (qualQualify mident qident) arity texpr)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
528 529 530 531 532 533 534 535 536 537 538 539 540 541
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
542 543 544 545
genFlatApplication e1 e2 = genFlatApplic [e2] e1
  where
  genFlatApplic args expression = case expression of
    (IL.Apply expr1 expr2) -> genFlatApplic (expr2:args) expr1
546
    (IL.Function qident _) -> do
Björn Peemöller 's avatar
Björn Peemöller committed
547 548 549 550 551 552 553 554 555 556 557 558 559 560
      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
561 562 563 564

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

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

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

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

-- 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
620
-- representation of all type synonyms is generated (see "ModuleSummary")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
621 622 623 624 625 626 627
-- 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
628 629 630 631 632 633 634 635 636
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
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 663
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]
664
	    (modid,ident) = (qidModule qident, qidIdent qident)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
665 666 667 668
	qname <- visitQualIdent ((maybe qualify qualifyWith modid)
				 (recordExtId ident))
	labels <- mapM (genRecordLabel modid (zip params is)) fields
	return (Type qname Public is labels)
669
genRecordType _ = internalError "GenFlatCurry.genRecordType: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
670 671 672 673 674 675 676 677

--
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
678
        texpr <- visitType (snd (cs2ilType vis typeexpr'))
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
679 680 681
	qname <- visitQualIdent ((maybe qualify qualifyWith modid)
				 (labelExtId ident))
	return (Cons qname 1 Public [texpr])
682
genRecordLabel _ _ _ = internalError "GenFlatCurry.genRecordLabel: no pattern match"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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 726


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

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

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

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

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

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

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

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

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

804
overlappingRules :: QualIdent -> Message
805 806 807
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
808 809 810 811 812 813

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

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

--
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
824 825
isPublicDataDecl (IL.DataDecl qident _ _) = isPublic False qident
isPublicDataDecl _                        = return False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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 856 857

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

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

--
compilerOpts :: FlatState Options
compilerOpts = gets compilerOptsE

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

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

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

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

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

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

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

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

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

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

--
genInterface :: FlatState Bool
genInterface = gets genInterfaceE

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

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

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

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

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

--
bindEnvITypeDecl :: Map.Map Ident IdentExport -> Ident -> CS.TypeExpr