GenAbstractCurry.hs 38.3 KB
Newer Older
1 2 3
{- |
    Module      :  $Header$
    Description :  Generation of AbstractCurry program terms
4 5
    Copyright   :  (c) 2005, Martin Engelke  (men@informatik.uni-kiel.de)
                       2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
6 7 8 9 10 11 12 13
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module contains the generation of an 'AbstractCurry' program term
    for a given 'Curry' module.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
14
-}
Björn Peemöller 's avatar
Björn Peemöller committed
15 16
module Generators.GenAbstractCurry
  ( genTypedAbstract, genUntypedAbstract ) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
17

18 19 20 21
import Data.List (find, mapAccumL)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Set as Set
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
22 23 24

import Curry.AbstractCurry
import Curry.Base.Ident
25
import Curry.Base.Position
26
import Curry.Syntax hiding (isFunctionDecl)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
27

Björn Peemöller 's avatar
Björn Peemöller committed
28
import Base.CurryTypes (fromType)
29
import Base.Messages (internalError)
Björn Peemöller 's avatar
Björn Peemöller committed
30
import Base.TopEnv
Björn Peemöller 's avatar
Björn Peemöller committed
31 32
import Base.Types

33
import Env.TypeConstructor (TCEnv, lookupTC)
Björn Peemöller 's avatar
Björn Peemöller committed
34
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
35
import Env.OpPrec (mkPrec)
Björn Peemöller 's avatar
Björn Peemöller committed
36

37 38
import CompilerEnv

39
-- ---------------------------------------------------------------------------
Björn Peemöller 's avatar
Björn Peemöller committed
40
-- Interface
41
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
42

43 44
-- |Generate type inferred AbstractCurry code from a Curry module.
--  The function needs the type environment 'tyEnv' to determine the
45 46
--  inferred function types.
genTypedAbstract :: CompilerEnv -> Module -> CurryProg
47
genTypedAbstract = genAbstract TypedAcy
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
48

49
-- |Generate untyped AbstractCurry code from a Curry module. The type
Björn Peemöller 's avatar
Björn Peemöller committed
50 51
--  signature takes place in every function type annotation, if it exists,
--  otherwise the dummy type "Prelude.untyped" is used.
52
genUntypedAbstract :: CompilerEnv -> Module -> CurryProg
53
genUntypedAbstract = genAbstract UntypedAcy
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
54

Björn Peemöller 's avatar
Björn Peemöller committed
55
-- |Generate an AbstractCurry program term from the syntax tree
56
genAbstract :: AbstractType -> CompilerEnv -> Module -> CurryProg
57 58
genAbstract ty env mdl@(Module _ mid _ imps decls)
  = CurryProg mid' imps' types funcs ops
Björn Peemöller 's avatar
Björn Peemöller committed
59
  where
60 61 62 63 64 65 66
  aEnv  = abstractEnv ty env mdl
  mid'  = moduleName mid
  imps' = map genImportDecl imps
  types = snd $ mapAccumL genTypeDecl aEnv         $ reverse $ typeDecls part
  funcs = snd $ mapAccumL (genFuncDecl False) aEnv $ funcDecls part
  ops   =       concatMap (genOpDecl aEnv)         $ reverse $ opDecls part
  part  = foldl partitionDecl emptyPartition decls
Björn Peemöller 's avatar
Björn Peemöller committed
67 68

-- ---------------------------------------------------------------------------
69
-- Partition of declarations
Björn Peemöller 's avatar
Björn Peemöller committed
70
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
71

72
-- The following code is used to split a list of Curry declarations into
73
-- three parts:
74 75 76
--   * a list of type declarations (data types and type synonyms),
--   * a table of function declarations,
--   * a list of fixity declarations for infix operators.
77

78
-- |Partition of Curry declarations.
79 80 81 82 83 84
-- (according to the definition of the AbstractCurry program
-- representation; type 'CurryProg').
-- Since a complete function declaration usually consists of more than one
-- declaration (e.g. rules, type signature etc.), it is necessary
-- to collect them within an association list
data Partition = Partition
85 86 87
  { typeDecls   :: [Decl]
  , funcDecls   :: [(Ident, [Decl])] -- no Map to preserve order
  , opDecls     :: [Decl]
Björn Peemöller 's avatar
Björn Peemöller committed
88 89
  } deriving Show

90 91 92 93 94 95 96
-- |Generate initial partitions
emptyPartition :: Partition
emptyPartition = Partition
  { typeDecls   = []
  , funcDecls   = []
  , opDecls     = []
  }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
97

98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
-- |Insert a CurrySyntax top level declaration into a partition.
-- /Note:/ Declarations are collected in reverse order.
partitionDecl :: Partition -> Decl -> Partition
-- operator infix declarations
partitionDecl p d@(InfixDecl _ _ _ _) = p { opDecls   = d : opDecls   p }
-- type declarations
partitionDecl p d@(DataDecl  _ _ _ _) = p { typeDecls = d : typeDecls p }
partitionDecl p d@(TypeDecl  _ _ _ _) = p { typeDecls = d : typeDecls p }
-- function declarations
partitionDecl p (TypeSig pos ids ty)
  = partitionFuncDecls (\q -> TypeSig pos [q] ty) p ids
partitionDecl p d@(FunctionDecl _ ident _)
  = partitionFuncDecls (const d) p [ident]
partitionDecl p d@(ForeignDecl _ _ _ ident _)
  = partitionFuncDecls (const d) p [ident]
partitionDecl p (ExternalDecl pos ids)
  = partitionFuncDecls (\q -> ExternalDecl pos [q]) p ids
-- other (ignored)
partitionDecl p _ = p
117

118 119 120 121 122 123 124 125
--
partitionFuncDecls :: (Ident -> Decl) -> Partition -> [Ident] -> Partition
partitionFuncDecls genDecl parts fs
  = parts { funcDecls = foldl insertDecls (funcDecls parts) fs }
  where
  insertDecls funcs f = case span ((/=f) . fst) funcs of
    (others, []                ) -> others ++ (f, genDecl f : []    ) : []
    (others, (_, fDecls) : rest) -> others ++ (f, genDecl f : fDecls) : rest
126

127 128 129
-- ---------------------------------------------------------------------------
-- Conversion from Curry to AbstractCurry
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
130

131
--
132 133
genImportDecl :: ImportDecl -> String
genImportDecl (ImportDecl _ mid _ _ _) = moduleName mid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
134

135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204
--
genTypeDecl :: AbstractEnv -> Decl -> (AbstractEnv, CTypeDecl)
genTypeDecl env (DataDecl _ n vs cs)
  = ( resetScope env2
    , CType (genQName True env2 $ qualifyWith (moduleId env) n)
            (genVisibility env2 n)
            (zip idxs $ map idName vs)
            cs'
    )
  where (env1, idxs) = mapAccumL genTVarIndex env vs
        (env2, cs' ) = mapAccumL genConsDecl env1 cs
genTypeDecl env (TypeDecl _ n vs ty)
  = ( resetScope env2
    , CTypeSyn (genQName True env2 $ qualifyWith (moduleId env) n)
               (genVisibility env2 n)
               (zip idxs $ map idName vs)
               ty'
    )
  where (env1, idxs) = mapAccumL genTVarIndex env vs
        (env2, ty' ) = genTypeExpr env1 ty
genTypeDecl env (NewtypeDecl _ n vs (NewConstrDecl p nvs nc ty))
  = (resetScope env2
    , CType (genQName True env2 $ qualifyWith (moduleId env) n)
            (genVisibility env2 n)
            (zip idxs $ map idName vs)
            [nc']
    ) where (env1, idxs) = mapAccumL genTVarIndex env vs
            (env2, nc' ) = genConsDecl env1 (ConstrDecl p nvs nc [ty])
genTypeDecl _ _
  = internalError "GenAbstractCurry.genTypeDecl: unexpected declaration"

--
genConsDecl :: AbstractEnv -> ConstrDecl -> (AbstractEnv, CConsDecl)
genConsDecl env (ConstrDecl _ _ n vs)
  = ( env', CCons (genQName False env' $ qualifyWith (moduleId env) n)
                  (length vs)
                  (genVisibility env' n)
                  vs'
    ) where (env', vs') = mapAccumL genTypeExpr env vs
genConsDecl env (ConOpDecl p vs ty1 op ty2)
  = genConsDecl env (ConstrDecl p vs op [ty1, ty2])

--
genTypeExpr :: AbstractEnv -> TypeExpr -> (AbstractEnv, CTypeExpr)
genTypeExpr env (ConstructorType q vs)
  = (env', CTCons (genQName True env' q) vs')
  where (env', vs') = mapAccumL genTypeExpr env vs
genTypeExpr env (VariableType ident) = case getTVarIndex env ident of
  Just ix -> (env , CTVar (ix , idName ident))
  Nothing -> (env', CTVar (idx, idName ident))
  where (env', idx) = genTVarIndex env ident
genTypeExpr env (TupleType     tys) = genTypeExpr env $ case tys of
   []   -> ConstructorType qUnitId []
   [ty] -> ty
   _    -> ConstructorType (qTupleId $ length tys) tys
genTypeExpr env (ListType       ty)
  = genTypeExpr env $ ConstructorType qListId [ty]
genTypeExpr env (ArrowType ty1 ty2) = (env2, CFuncType ty1' ty2')
  where (env1, ty1') = genTypeExpr env  ty1
        (env2, ty2') = genTypeExpr env1 ty2
genTypeExpr env (RecordType fss mr) = case mr of
  Nothing -> (env1, CRecordType (zip ls' ts') Nothing)
  Just tvar@(VariableType _) ->
    let (env2, CTVar iname) = genTypeExpr env1 tvar
    in  (env2, CRecordType (zip ls' ts') (Just iname))
  Just r@(RecordType _ _) ->
    let (env2, CRecordType fields rbase) = genTypeExpr env1 r
        fields' = foldr (uncurry insertEntry) fields (zip ls' ts')
    in  (env2, CRecordType fields' rbase)
  _ -> internalError "GenAbstractCurry.gegnTypeExpr: illegal record base"
205
  where
206 207 208 209 210
  (ls  , ts ) = unzip $ concatMap (\ (ls1,ty) -> map (\l -> (l,ty)) ls1) fss
  (env1, ts') = mapAccumL genTypeExpr env ts
  ls'        = map idName ls

genOpDecl :: AbstractEnv -> Decl -> [COpDecl]
211
genOpDecl env (InfixDecl _ fix mprec ops) = map genCOp (reverse ops)
212 213 214
  where
  genCOp op = COp (genQName False env $ qualifyWith (moduleId env) op)
                  (genFixity fix)
215
                  (fromInteger (mkPrec mprec))
216 217 218 219 220 221 222 223

  genFixity InfixL = CInfixlOp
  genFixity InfixR = CInfixrOp
  genFixity Infix  = CInfixOp
genOpDecl _ _ = internalError "GenAbstractCurry.genOpDecl: no infix declaration"

-- Generate an AbstractCurry function declaration from a list of CurrySyntax
-- function declarations.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
224
-- NOTES:
225
--   - every declaration in 'decls' must declare exactly one function.
226
--   - since inferred types are internally represented in flat style,
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
227 228
--     all type variables are renamed with generated symbols when
--     generating typed AbstractCurry.
229 230 231 232 233
genFuncDecl :: Bool -> AbstractEnv -> (Ident, [Decl]) -> (AbstractEnv, CFuncDecl)
genFuncDecl isLocal env (ident, decls)
  | null decls = internalError $ "GenAbstractCurry.genFuncDecl: "
              ++ "missing declaration for function \"" ++ show ident ++ "\""
  | otherwise  = (env3, CFunc qname arity visibility typeexpr rule)
234
  where
235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
  qname       = genQName False env $ qualify ident
  visibility  = genVisibility env ident
  evalannot   = CFlex
--   evalannot   = case find isEvalAnnot decls of
--                   Nothing -> CFlex
--                   Just (EvalAnnot _ _ ea) -> genEvalAnnot ea
--                   _ -> internalError "Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation"
  (env1, mtype) = case genFuncType env decls of
                  Nothing        -> (env, Nothing)
                  Just (env', t) -> (env', Just t)
  (env2, rules) = case find isFunctionDecl decls of
                  Nothing -> (env1, [])
                  Just (FunctionDecl _ _ eqs) -> mapAccumL genRule env1 eqs
                  _ -> internalError "Gen.GenAbstractCurry.genFuncDecl: no FunctionDecl"
  mexternal   = genExternal `fmap` find isExternal decls
  arity       = compArity mtype rules
  typeexpr    = fromMaybe (CTCons ("Prelude", "untyped") []) mtype
  rule        = compRule evalannot rules mexternal
  env3        = if isLocal then env1 else resetScope env2

  genFuncType env' decls'
    | acytype == UntypedAcy = genTypeSig  env' `fmap` find isTypeSig decls'
    | acytype == TypedAcy   = genTypeExpr env' `fmap` mftype
    | otherwise             = Nothing
    where
    acytype = acyType env
    mftype | isLocal   = lookupType ident (typeEnv env)
           | otherwise = qualLookupType (qualifyWith (moduleId env) ident)
                          (typeEnv env)

  genTypeSig env' (TypeSig         _ _ ts) = genTypeExpr env' ts
  genTypeSig env' (ForeignDecl _ _ _ _ ts) = genTypeExpr env' ts
  genTypeSig _    _ =
    internalError "GenAbstractCurry.genFuncDecl.genTypeSig: no pattern match"

  genExternal (ForeignDecl _ _ mname ident' _)
    = CExternal (fromMaybe (idName ident') mname)
  genExternal (ExternalDecl _ [ident'])
    = CExternal (idName ident')
  genExternal _
    = internalError $ "GenAbstractCurry.genExternal: "
      ++ "illegal external declaration occured"

  compArity Nothing   [] = internalError $ "GenAbstractCurry.compArity: "
                           ++ "unable to compute arity for function \""
                           ++ show ident ++ "\""
  compArity (Just ty) [] = compArityFromType ty
  compArity _         (CRule patts _ _ : _) = length patts

  compArityFromType (CTVar         _) = 0
  compArityFromType (CFuncType  _ t2) = 1 + compArityFromType t2
  compArityFromType (CTCons      _ _) = 0
  compArityFromType (CRecordType _ _) =
    internalError "GenAbstractCurry.genFuncDecl.compArityFromType: record type"

  compRule _  [] Nothing  = internalError $ "GenAbstractCurry.compRule: "
                            ++ "missing rule for function \""
                            ++ show ident ++ "\""
  compRule _  [] (Just e) = e
  compRule ea rs _        = CRules ea rs
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
295

296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463
--
genRule :: AbstractEnv -> Equation -> (AbstractEnv, CRule)
genRule env (Equation pos lhs rhs)
  = let (env1, patts ) = mapAccumL (genPattern pos)
                                   (beginScope env)
                                   (simplifyLhs lhs)
        (env2, locals) = genLocalDecls env1 (simplifyRhsLocals rhs)
        (env3, crhss ) = mapAccumL (genRhs pos) env2 (simplifyRhsExpr rhs)
    in  (endScope env3, CRule patts crhss locals)

--
genRhs :: Position -> AbstractEnv -> (Expression, Expression)
       -> (AbstractEnv, (CExpr, CExpr))
genRhs p env (cond, expr)
  = let (env1, cond') = genExpr p env cond
        (env2, expr') = genExpr p env1 expr
    in  (env2, (cond', expr'))

-- NOTE: guarded expressions and 'where' declarations in local pattern
-- declarations are not supported in PAKCS
genLocalDecls :: AbstractEnv -> [Decl] -> (AbstractEnv, [CLocalDecl])
genLocalDecls env decls
  = genLocals (foldl genLocalIndex env decls)
              (funcDecls (foldl partitionDecl emptyPartition decls))
              decls
 where
  genLocalIndex env' (PatternDecl _ constr _)
    = genLocalPatternIndex env' constr
  genLocalIndex env' (FreeDecl _ idents)
    = let (env'', _) = mapAccumL genVarIndex env' idents
      in  env''
  genLocalIndex env' _ = env'

  genLocalPatternIndex env' (VariablePattern ident)
    = fst $ genVarIndex env' ident
  genLocalPatternIndex env' (ConstructorPattern _ args)
    = foldl genLocalPatternIndex env' args
  genLocalPatternIndex env' (InfixPattern c1 _ c2)
    = foldl genLocalPatternIndex env' [c1, c2]
  genLocalPatternIndex env' (ParenPattern c)
    = genLocalPatternIndex env' c
  genLocalPatternIndex env' (TuplePattern _ args)
    = foldl genLocalPatternIndex env' args
  genLocalPatternIndex env' (ListPattern _ args)
    = foldl genLocalPatternIndex env' args
  genLocalPatternIndex env' (AsPattern ident c)
    = genLocalPatternIndex (fst $ genVarIndex env' ident) c
  genLocalPatternIndex env' (LazyPattern _ c)
    = genLocalPatternIndex env' c
  genLocalPatternIndex env' (RecordPattern fields mc)
    = let env'' = foldl genLocalPatternIndex env' (map fieldTerm fields)
      in  maybe env'' (genLocalPatternIndex env'') mc
  genLocalPatternIndex env' _ = env'

  -- The association list 'fdecls' is necessary because function
  -- rules may not be together in the declaration list
  genLocals :: AbstractEnv -> [(Ident, [Decl])] -> [Decl]
            -> (AbstractEnv, [CLocalDecl])
  genLocals env' _ [] = (env', [])
  genLocals env' fdecls ((FunctionDecl _ ident _):decls1)
    = let (env1, funcdecl) = genLocalFuncDecl (beginScope env') fdecls ident
          (env2, locals  ) = genLocals (endScope env1) fdecls decls1
      in  (env2, funcdecl:locals)
  genLocals env' fdecls ((ForeignDecl _ _ _ ident _):decls1)
    = let (env1, funcdecl) = genLocalFuncDecl (beginScope env') fdecls ident
          (env2, locals  ) = genLocals (endScope env1) fdecls decls1
      in  (env2, funcdecl:locals)
  genLocals env' fdecls ((ExternalDecl pos idents):decls1)
    | null idents = genLocals env' fdecls decls1
    | otherwise
    = let (env1, funcdecl) = genLocalFuncDecl (beginScope env') fdecls (head idents)
          (env2, locals  ) = genLocals (endScope env1) fdecls (ExternalDecl pos (tail idents):decls1)
      in  (env2, funcdecl:locals)
  genLocals env' fdecls (PatternDecl pos constr rhs : decls1)
    = let (env1, patt   ) = genLocalPattern pos env' constr
          (env2, plocals) = genLocalDecls (beginScope env1)
                              (simplifyRhsLocals rhs)
          (env3, expr   ) = genLocalPattRhs pos env2 (simplifyRhsExpr rhs)
          (env4, locals ) = genLocals (endScope env3) fdecls decls1
      in  (env4, CLocalPat patt expr plocals:locals)
  genLocals env' fdecls ((FreeDecl pos idents):decls1)
    | null idents  = genLocals env' fdecls decls1
    | otherwise
      = let ident  = head idents
            idx    = fromMaybe
                  (internalError ("GenAbstractCurry.genLocals: cannot find index"
                ++ " for free variable \""
                ++ show ident ++ "\""))
                  (getVarIndex env' ident)
            decls' = FreeDecl pos (tail idents) : decls1
            (env'', locals) = genLocals env' fdecls decls'
        in (env'', CLocalVar (idx, idName ident) : locals)
  genLocals env' fdecls ((TypeSig _ _ _):decls1)
    = genLocals env' fdecls decls1
  genLocals _ _ decl = internalError ("GenAbstractCurry.genLocals: unexpected local declaration: \n" ++ show (head decl))

  genLocalFuncDecl :: AbstractEnv -> [(Ident, [Decl])] -> Ident
                   -> (AbstractEnv, CLocalDecl)
  genLocalFuncDecl env' fdecls ident
    = let fdecl = fromMaybe
              (internalError ("GenAbstractCurry.genLocalFuncDecl: missing declaration"
                  ++ " for local function \""
                  ++ show ident ++ "\""))
              (lookup ident fdecls)
          (_, funcdecl) = genFuncDecl True env' (ident, fdecl)
      in  (env', CLocalFunc funcdecl)

  genLocalPattern pos env' (LiteralPattern l) = case l of
    String _ cs
      -> genLocalPattern pos env' $ ListPattern [] $ map (LiteralPattern . Char noRef) cs
    _ -> (env', CPLit $ genLiteral l)
  genLocalPattern _ env' (VariablePattern v) = case getVarIndex env' v of
    Nothing  -> internalError $ "GenAbstractCurry.genLocalPattern: "
      ++ "cannot find index" ++ " for pattern variable \"" ++ show v ++ "\""
    Just idx -> (env', CPVar (idx, idName v))
  genLocalPattern pos env' (ConstructorPattern qident args)
    = let (env'', args') = mapAccumL (genLocalPattern pos) env' args
      in (env'', CPComb (genQName False env' qident) args')
  genLocalPattern pos env' (InfixPattern larg qident rarg)
    = genLocalPattern pos env' (ConstructorPattern qident [larg, rarg])
  genLocalPattern pos env' (ParenPattern patt)
    = genLocalPattern pos env' patt
  genLocalPattern pos env' (TuplePattern _ args)
    | len == 0  = genLocalPattern pos env' (ConstructorPattern qUnitId [])
    | len == 1  = genLocalPattern pos env' (head args)
    | otherwise = genLocalPattern pos env' (ConstructorPattern (qTupleId len) args) -- len > 1
    where len = length args
  genLocalPattern pos env' (ListPattern _ args)
    = genLocalPattern pos env'
      (foldr (\p1 p2 -> ConstructorPattern qConsId [p1,p2])
        (ConstructorPattern qNilId [])
        args)
  genLocalPattern _ _ (NegativePattern _ _)
    = internalError "negative patterns are not supported in AbstractCurry"
  genLocalPattern pos env' (AsPattern ident cterm)
    = let (env1, patt) = genLocalPattern pos env' cterm
          idx          = fromMaybe
                (internalError ("GenAbstractCurry.genLocalPattern: cannot find index"
                    ++ " for alias variable \""
                    ++ show ident ++ "\""))
                (getVarIndex env1 ident)
      in  (env1, CPAs (idx, idName ident) patt)
  genLocalPattern pos env' (LazyPattern _ cterm)
    = let (env'', patt) = genLocalPattern pos env' cterm
      in  (env'', CPLazy patt)
  genLocalPattern pos env' (RecordPattern fields mr)
    = let (env1, fields') = mapAccumL (genField genLocalPattern) env' fields
          (env2, mr'    ) = case mr of
                              Nothing -> (env1, Nothing)
                              Just r  -> let (envX, patt) = genLocalPattern pos env1 r in (envX, Just patt)
      in  (env2, CPRecord fields' mr')
  genLocalPattern _ _ _ = internalError "GenAbstractCurry.genLocalDecls.genLocalPattern: no pattern match"

  genLocalPattRhs pos env' [(Variable _, expr)]
    = genExpr pos env' expr
  genLocalPattRhs _ _ _
    = internalError ("guarded expressions in pattern declarations"
      ++ " are not supported in AbstractCurry")

--
genExpr :: Position -> AbstractEnv -> Expression -> (AbstractEnv, CExpr)
genExpr pos env (Literal l) = case l of
  String _ cs -> genExpr pos env $ List [] $ map (Literal . Char noRef) cs
  _           -> (env, CLit $ genLiteral l)
genExpr _ env   (Variable v)
  | isJust midx     = (env, CVar (fromJust midx, idName ident))
  | v == qSuccessId = (env, CSymbol $ genQName False env qSuccessFunId)
  | otherwise       = (env, CSymbol $ genQName False env v)
464
  where
465 466 467 468 469 470 471 472 473 474
  ident = unqualify v
  midx  = getVarIndex env ident
genExpr _   env (Constructor c) = (env, CSymbol $ genQName False env c)
genExpr pos env (Paren    expr) = genExpr pos env expr
genExpr pos env (Typed  expr _) = genExpr pos env expr
genExpr pos env (Tuple  _ args) = genExpr pos env $ case args of
  []  -> Variable qUnitId
  [x] -> x
  _   -> foldl Apply (Variable $ qTupleId $ length args) args
genExpr pos env (List _ args)
475 476
  = let cons = Constructor qConsId
        nil  = Constructor qNilId
477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588
    in  genExpr pos env (foldr (Apply . Apply cons) nil args)
genExpr pos env (ListCompr _ expr stmts)
  = let (env1, stmts') = mapAccumL (genStatement pos) (beginScope env) stmts
        (env2, expr' )  = genExpr pos env1 expr
    in  (endScope env2, CListComp expr' stmts')
genExpr pos env (EnumFrom expr)
  = genExpr pos env (Apply (Variable qEnumFromId) expr)
genExpr pos env (EnumFromThen expr1 expr2)
  = genExpr pos env (Apply (Apply (Variable qEnumFromThenId) expr1) expr2)
genExpr pos env (EnumFromTo expr1 expr2)
  = genExpr pos env (Apply (Apply (Variable qEnumFromToId) expr1) expr2)
genExpr pos env (EnumFromThenTo expr1 expr2 expr3)
  = genExpr pos env (Apply (Apply (Apply (Variable qEnumFromThenToId)
          expr1) expr2) expr3)
genExpr pos env (UnaryMinus _ expr)
  = genExpr pos env (Apply (Variable qNegateId) expr)
genExpr pos env (Apply expr1 expr2)
  = let (env1, expr1') = genExpr pos env expr1
        (env2, expr2') = genExpr pos env1 expr2
    in  (env2, CApply expr1' expr2')
genExpr pos env (InfixApply expr1 op expr2)
  = genExpr pos env (Apply (Apply (opToExpr op) expr1) expr2)
genExpr pos env (LeftSection expr op)
  = let ident  = freshVar env "x"
        patt   = VariablePattern ident
        var    = Variable (qualify ident)
        applic = Apply (Apply (opToExpr op) expr) var
    in  genExpr pos env (Lambda noRef [patt] applic)
genExpr pos env (RightSection op expr)
  = let ident  = freshVar env "x"
        patt   = VariablePattern ident
        var    = Variable (qualify ident)
        applic = Apply (Apply (opToExpr op) var) expr
    in  genExpr pos env (Lambda noRef [patt] applic)
genExpr pos env (Lambda _ params expr)
  = let (env1, params') = mapAccumL (genPattern pos) (beginScope env) params
        (env2, expr'  )   = genExpr pos env1 expr
    in  (endScope env2, CLambda params' expr')
genExpr pos env (Let decls expr)
  = let (env1, decls') = genLocalDecls (beginScope env) decls
        (env2, expr' ) = genExpr pos env1 expr
    in  (endScope env2, CLetDecl decls' expr')
genExpr pos env (Do stmts expr)
  = let (env1, stmts') = mapAccumL (genStatement pos) (beginScope env) stmts
        (env2, expr' )  = genExpr pos env1 expr
    in  (endScope env2, CDoExpr (stmts' ++ [CSExpr expr']))
genExpr pos env (IfThenElse _ expr1 expr2 expr3)
  = genExpr pos env (Apply (Apply (Apply (Variable qIfThenElseId)
                    expr1) expr2) expr3)
genExpr pos env (Case _ _ expr alts)
  = let (env1, expr') = genExpr pos env expr
        (env2, alts') = mapAccumL genBranchExpr env1 alts
    in  (env2, CCase expr' alts')
genExpr _ env (RecordConstr fields)
  = let (env1, fields') = mapAccumL (genField genExpr) env fields
    in  (env1, CRecConstr fields')
genExpr pos env (RecordSelection expr label)
  = let (env1, expr') = genExpr pos env expr
    in  (env1, CRecSelect expr' $ idName label)
genExpr pos env (RecordUpdate fields expr)
  = let (env1, fields') = mapAccumL (genField genExpr) env fields
        (env2, expr'  ) = genExpr pos env1 expr
    in  (env2, CRecUpdate fields' expr')

--
genStatement :: Position -> AbstractEnv -> Statement -> (AbstractEnv, CStatement)
genStatement pos env (StmtExpr _ expr)
  = let (env', expr') = genExpr pos env expr
    in  (env', CSExpr expr')
genStatement _ env (StmtDecl decls)
  = let (env', decls') = genLocalDecls env decls
    in  (env', CSLet decls')
genStatement pos env (StmtBind _ patt expr)
  = let (env1, expr') = genExpr pos env expr
        (env2, patt') = genPattern pos env1 patt
    in  (env2, CSPat patt' expr')

-- NOTE: guarded expressions and local declarations in case branches
-- are not supported in PAKCS
genBranchExpr :: AbstractEnv -> Alt -> (AbstractEnv, CBranchExpr)
genBranchExpr env (Alt p pat rhs)
  = let (env1, pat') = genPattern p (beginScope env) pat
        (env2, be  ) = genBranch env1 pat' $ simplifyRhsExpr rhs
    in  (endScope env2, be)
  where
  genBranch env' pat' [(Variable _, expr)] -- no guards!
    = let (env2, expr') = genExpr p env' expr
      in  (env2, CBranch pat' expr')
  genBranch env' pat' bs
    = let (env2, bs') = mapAccumL (genRhs p) env' bs
      in  (env2, CGuardedBranch pat' bs')

--
genPattern :: Position -> AbstractEnv -> Pattern -> (AbstractEnv, CPattern)
genPattern pos env (LiteralPattern l) = case l of
  String _ cs -> genPattern pos env $ ListPattern [] $ map (LiteralPattern . Char noRef) cs
  _           -> (env, CPLit $ genLiteral l)
genPattern _ env (VariablePattern v)
  = let (env', idx) = genVarIndex env v
    in  (env', CPVar (idx, idName v))
genPattern pos env (ConstructorPattern qident args)
  = let (env', args') = mapAccumL (genPattern pos) env args
    in  (env', CPComb (genQName False env qident) args')
genPattern pos env (InfixPattern larg qident rarg)
  = genPattern pos env $ ConstructorPattern qident [larg, rarg]
genPattern pos env (ParenPattern patt)
  = genPattern pos env patt
genPattern pos env (TuplePattern _ args) = genPattern pos env $ case args of
  []   -> ConstructorPattern qUnitId []
  [ty] -> ty
  _    -> ConstructorPattern (qTupleId $ length args) args
genPattern pos env (ListPattern _ args) = genPattern pos env $
589
  foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2])
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624
        (ConstructorPattern qNilId [])
        args
genPattern _ _ (NegativePattern _ _)
  = internalError "negative patterns are not supported in AbstractCurry"
genPattern pos env (AsPattern ident cterm)
  = let (env1, patt) = genPattern pos env cterm
        (env2, idx ) = genVarIndex env1 ident
    in  (env2, CPAs (idx, idName ident) patt)
genPattern pos env (LazyPattern _ cterm)
  = let (env', patt) = genPattern pos env cterm
    in  (env', CPLazy patt)
genPattern pos env (FunctionPattern qident cterms)
  = let (env', patts) = mapAccumL (genPattern pos) env cterms
    in  (env', CPFuncComb (genQName False env qident) patts)
genPattern pos env (InfixFuncPattern cterm1 qident cterm2)
  = genPattern pos env (FunctionPattern qident [cterm1, cterm2])
genPattern pos env (RecordPattern fields mr)
  = let (env1, fields') = mapAccumL (genField genPattern) env fields
        (env2, mr')     = case mr of
          Nothing -> (env1, Nothing)
          Just r  -> let (env', patt) = genPattern pos env1 r in (env', Just patt)
    in  (env2, CPRecord fields' mr')

--
genField :: (Position -> AbstractEnv -> a -> (AbstractEnv, b))
         -> AbstractEnv -> Field a -> (AbstractEnv, CField b)
genField genTerm env (Field p l t) = (env1, (idName l, t'))
  where (env1, t') = genTerm p env t

--
genLiteral :: Literal -> CLiteral
genLiteral (Char  _ c) = CCharc  c
genLiteral (Int   _ i) = CIntc   i
genLiteral (Float _ f) = CFloatc f
genLiteral _           = internalError "GenAbstractCurry.genLiteral: unsupported literal"
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
625

626
-- |Create a qualified AbstractCurry identifier from a Curry 'QualIdent'.
627
--
628
-- * Some prelude identifiers are not qualified. The first check ensures
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
629
--   that they get a correct qualifier.
630
-- * The test for unqualified identifiers is necessary to qualify
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
631
--   them correctly in the untyped AbstractCurry representation.
632 633 634 635 636
genQName :: Bool -> AbstractEnv -> QualIdent -> QName
genQName isTypeCons env qident
  | isPreludeSymbol qident = genQualName $ qualQualify preludeMIdent qident
  | isQualified     qident = genQualName qident
  | otherwise              = genQualName $ getQualIdent $ unqualify qident
637
  where
638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654
  genQualName qid = ( moduleName $ fromMaybe (moduleId env) $ qidModule qid
                    , idName $ qidIdent qid
                    )
-- TODO@bjp (2012-01-04): Disabled
--   genQualName qid = (moduleName mid, name ident)
--     where (mmid, ident) = (qidModule qid, qidIdent qid)
--           mid           = maybe (moduleId env)
--                           (`sureLookupAlias` aliases env)
--                           mmid

  getQualIdent ident
    | isTypeCons = case lookupTC ident $ tconsEnv env of
        [info] -> origName info
        _      -> qualifyWith (moduleId env) ident
    | otherwise  = case lookupValue ident $ typeEnv env of
        [info] -> origName info
        _      -> qualifyWith (moduleId env) ident
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
655

656 657 658 659 660
--
genVisibility :: AbstractEnv -> Ident -> CVisibility
genVisibility env ident
  | isExported env ident = Public
  | otherwise            = Private
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
661

662 663 664
-------------------------------------------------------------------------------
-- This part defines an environment containing all necessary information
-- for generating the AbstractCurry representation of a CurrySyntax term.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
665

666 667 668 669 670 671 672 673 674 675 676 677 678
-- |Data type for representing an AbstractCurry generator environment
data AbstractEnv = AbstractEnv
  { moduleId   :: ModuleIdent         -- ^name of the module
  , typeEnv    :: ValueEnv            -- ^known values
  , tconsEnv   :: TCEnv               -- ^known type constructors
  , exports    :: Set.Set Ident       -- ^exported symbols
--   , aliases    :: AliasEnv            -- ^module aliases
  , varIndex   :: Int                 -- ^counter for variable indices
  , tvarIndex  :: Int                 -- ^counter for type variable indices
  , varScope   :: [Map.Map Ident Int] -- ^stack of variable tables
  , tvarScope  :: [Map.Map Ident Int] -- ^stack of type variable tables
  , acyType    :: AbstractType        -- ^type of code to be generated
  } deriving Show
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
679

680 681 682 683 684 685
-- |Data type representing the type of AbstractCurry code to be generated
-- (typed infered or untyped (i.e. type signated))
data AbstractType
  = TypedAcy
  | UntypedAcy
    deriving (Eq, Show)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743
-- |Initialize the AbstractCurry generator environment
abstractEnv :: AbstractType -> CompilerEnv -> Module -> AbstractEnv
abstractEnv absType env (Module _ mid exps _ decls) = AbstractEnv
  { moduleId  = mid
  , typeEnv   = valueEnv env
  , tconsEnv  = tyConsEnv env
  , exports   = foldl (buildExportTable mid decls) Set.empty exps'
--   , aliases   = aliasEnv env
  , varIndex  = 0
  , tvarIndex = 0
  , varScope  = [Map.empty]
  , tvarScope = [Map.empty]
  , acyType   = absType
  }
 where exps' = maybe (buildExports mid decls) (\ (Exporting _ es) -> es) exps

-- Generates a list of exports for all specified top level declarations
buildExports :: ModuleIdent -> [Decl] -> [Export]
buildExports _ [] = []
buildExports mid (DataDecl _ ident _ _:ds)
  = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds
buildExports mid ((NewtypeDecl _ ident _ _):ds)
  = ExportTypeAll (qualifyWith mid ident) : buildExports mid ds
buildExports mid ((TypeDecl _ ident _ _):ds)
  = Export (qualifyWith mid ident) : buildExports mid ds
buildExports mid ((FunctionDecl _ ident _):ds)
  = Export (qualifyWith mid ident) : buildExports mid ds
buildExports mid (ForeignDecl _ _ _ ident _ : ds)
  = Export (qualifyWith mid ident) : buildExports mid ds
buildExports mid (ExternalDecl _ idents : ds)
  = map (Export . qualifyWith mid) idents ++ buildExports mid ds
buildExports mid (_:ds) = buildExports mid ds

-- Builds a table containing all exported (i.e. public) identifiers
-- from a module.
buildExportTable :: ModuleIdent -> [Decl] -> Set.Set Ident -> Export
                 -> Set.Set Ident
buildExportTable mid _ exptab (Export qident)
  | isJust (localIdent mid qident)
  = insertExportedIdent exptab (unqualify qident)
  | otherwise = exptab
buildExportTable mid _ exptab (ExportTypeWith qident ids)
  | isJust (localIdent mid qident)
  = foldl insertExportedIdent
          (insertExportedIdent exptab (unqualify qident))
          ids
  | otherwise  = exptab
buildExportTable mid decls exptab (ExportTypeAll qident)
  | isJust ident'
  = foldl insertExportedIdent
          (insertExportedIdent exptab ident)
          (maybe [] getConstrIdents (find (isDataDeclOf ident) decls))
  | otherwise = exptab
  where
  ident' = localIdent mid qident
  ident  = fromJust ident'
buildExportTable _ _ exptab (ExportModule _) = exptab
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
744

745 746 747
--
insertExportedIdent :: Set.Set Ident -> Ident -> Set.Set Ident
insertExportedIdent env ident = Set.insert ident env
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
748

749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836
--
getConstrIdents :: Decl -> [Ident]
getConstrIdents (DataDecl _ _ _ cs) = map getConstr cs
  where getConstr (ConstrDecl  _ _  c _) = c
        getConstr (ConOpDecl _ _ _ op _) = op
getConstrIdents _ = internalError "GenAbstractCurry.getConstrIdents: no data declaration"

-- Checks whether an identifier is exported or not.
isExported :: AbstractEnv -> Ident -> Bool
isExported env ident = Set.member ident $ exports env

-- Generates an unique index for the  variable 'ident' and inserts it
-- into the  variable table of the current scope.
genVarIndex :: AbstractEnv -> Ident -> (AbstractEnv, Int)
genVarIndex env ident
  = let idx            = varIndex env
        (vtab : vtabs) = varScope env
    in  ( env { varIndex = idx + 1
              , varScope = Map.insert ident idx vtab : vtabs
              }
        , idx
        )

-- Generates an unique index for the type variable 'ident' and inserts it
-- into the type variable table of the current scope.
genTVarIndex :: AbstractEnv -> Ident -> (AbstractEnv, Int)
genTVarIndex env ident
  = let idx            = tvarIndex env
        (vtab : vtabs) = tvarScope env
    in  ( env { tvarIndex = idx + 1
              , tvarScope = Map.insert ident idx vtab : vtabs
              }
        , idx
        )

-- Looks up the unique index for the variable 'ident' in the
-- variable table of the current scope.
getVarIndex :: AbstractEnv -> Ident -> Maybe Int
getVarIndex env ident = Map.lookup ident $ head $ varScope env

-- Looks up the unique index for the type variable 'ident' in the type
-- variable table of the current scope.
getTVarIndex :: AbstractEnv -> Ident -> Maybe Int
getTVarIndex env ident = Map.lookup ident $ head $ tvarScope env

-- Generates an indentifier which doesn't occur in the variable table
-- of the current scope.
freshVar :: AbstractEnv -> String -> Ident
freshVar env vname = genFreshVar env vname (0 :: Integer)
  where
  genFreshVar env1 name1 idx
    | isJust (getVarIndex env1 ident)
    = genFreshVar env1 name1 (idx + 1)
    | otherwise
    = ident
    where ident = mkIdent $ name1 ++ show idx

-- Sets the index counter back to zero and deletes all stack entries.
resetScope :: AbstractEnv -> AbstractEnv
resetScope env = env
  { varIndex  = 0
  , tvarIndex = 0
  , varScope  = [Map.empty]
  , tvarScope = [Map.empty]
  }

-- Starts a new scope, i.e. copies and pushes the variable table of the current
-- scope onto the top of the stack
beginScope :: AbstractEnv -> AbstractEnv
beginScope env = env { varScope  = head vs : vs, tvarScope = head tvs : tvs }
  where
  vs  = varScope env
  tvs = tvarScope env

-- End the current scope, i.e. pops and deletes the variable table of the
-- current scope from the top of the stack.
endScope :: AbstractEnv -> AbstractEnv
endScope env = env { varScope  = newVarScope, tvarScope = newTVarScope }
  where
  newVarScope  = if isSingleton  vs then  vs else tail  vs
  newTVarScope = if isSingleton tvs then tvs else tail tvs
  vs           = varScope env
  tvs          = tvarScope env

-------------------------------------------------------------------------------
-- Miscellaneous...

-- Some identifiers...
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
837
qEnumFromId :: QualIdent
838
qEnumFromId = qualifyWith preludeMIdent (mkIdent "enumFrom")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
839 840

qEnumFromThenId :: QualIdent
841
qEnumFromThenId = qualifyWith preludeMIdent (mkIdent "enumFromThen")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
842 843

qEnumFromToId :: QualIdent
844
qEnumFromToId = qualifyWith preludeMIdent (mkIdent "enumFromTo")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
845 846 847 848 849

qEnumFromThenToId :: QualIdent
qEnumFromThenToId = qualifyWith preludeMIdent (mkIdent "enumFromThenTo")

qNegateId :: QualIdent
850
qNegateId = qualifyWith preludeMIdent (mkIdent "negate")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
851 852

qIfThenElseId :: QualIdent
853
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
854 855

qSuccessFunId :: QualIdent
856
qSuccessFunId = qualifyWith preludeMIdent (mkIdent "success")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
857

858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924
-- The following functions check whether a declaration is of a certain kind
isFunctionDecl :: Decl -> Bool
isFunctionDecl (FunctionDecl _ _ _) = True
isFunctionDecl _                    = False

isExternal :: Decl -> Bool
isExternal (ForeignDecl _ _ _ _ _) = True
isExternal (ExternalDecl      _ _) = True
isExternal _                       = False

-- Checks, whether a declaration is the data declaration of 'ident'.
isDataDeclOf :: Ident -> Decl -> Bool
isDataDeclOf i (DataDecl _ j _ _) = i == j
isDataDeclOf _ _                  = False

-- Checks, whether a symbol is defined in the Prelude.
isPreludeSymbol :: QualIdent -> Bool
isPreludeSymbol qident
   = let (mmid, ident) = (qidModule qident, qidIdent qident)
     in (isJust mmid && preludeMIdent == fromJust mmid)
        || elem ident [unitId, listId, nilId, consId]
        || isTupleId ident

-- Converts an infix operator to an expression
opToExpr :: InfixOp -> Expression
opToExpr (InfixOp    op) = Variable op
opToExpr (InfixConstr c) = Constructor c

-- Looks up the type of a qualified symbol in the type environment and
-- converts it to a CurrySyntax type term.
qualLookupType :: QualIdent -> ValueEnv -> Maybe TypeExpr
qualLookupType qident tyEnv = case qualLookupValue qident tyEnv of
  [Value _ _ (ForAll _ ty)] -> Just $ fromType ty
  _                         -> Nothing

-- Looks up the type of a symbol in the type environment and
-- converts it to a CurrySyntax type term.
lookupType :: Ident -> ValueEnv -> Maybe TypeExpr
lookupType ident tyEnv = case lookupValue ident tyEnv of
  [Value _ _ (ForAll _ ty)] -> Just $ fromType ty
  _                         -> Nothing

-- The following functions transform left-hand-side and right-hand-side terms
-- for a better handling
simplifyLhs :: Lhs -> [Pattern]
simplifyLhs = snd . flatLhs

simplifyRhsExpr :: Rhs -> [(Expression, Expression)]
simplifyRhsExpr (SimpleRhs _ e _) = [(Variable qSuccessId, e)]
simplifyRhsExpr (GuardedRhs gs _) = map (\ (CondExpr _ g e) -> (g, e)) gs

simplifyRhsLocals :: Rhs -> [Decl]
simplifyRhsLocals (SimpleRhs _ _ locals) = locals
simplifyRhsLocals (GuardedRhs  _ locals) = locals

-- Insert a value under a key into an association list. If the list
-- already contains a value for that key, the old value is replaced.
insertEntry :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
insertEntry k v []             = [(k, v)]
insertEntry k v ((l, w) : kvs)
  | k == l    = (k, v) : kvs
  | otherwise = (l, w) : insertEntry k v kvs

-- Return 'True' iff a list is a singleton list (contains exactly one element)
isSingleton :: [a] -> Bool
isSingleton [_] = True
isSingleton _   = False