GenAbstractCurry.hs 39.8 KB
Newer Older
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
{- |GenAbstractCurry - Generates an AbstractCurry program term
                       (type 'CurryProg')

    July 2005, Martin Engelke (men@informatik.uni-kiel.de)
-}
module Gen.GenAbstractCurry (genTypedAbstract, genUntypedAbstract) where

import Data.List (find)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe, isJust)
import qualified Data.Set as Set

import Curry.AbstractCurry
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Syntax

import Base.TypeConstructors (TCEnv, lookupTC)
import Base.Types (fromType)
import Base.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
import Env.TopEnv
import Messages (internalError, errorAt)
import Types

Björn Peemöller 's avatar
Björn Peemöller committed
25
26
27
-- ---------------------------------------------------------------------------
-- Interface
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
28

Björn Peemöller 's avatar
Björn Peemöller committed
29
30
31
-- |Generates standard (type infered) AbstractCurry code from a CurrySyntax
--  module. The function needs the type environment 'tyEnv' to determin the
--  infered function types.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
32
33
34
35
genTypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg
genTypedAbstract tyEnv tcEnv modul
   = genAbstract (genAbstractEnv TypedAcy tyEnv tcEnv modul) modul

Björn Peemöller 's avatar
Björn Peemöller committed
36
37
38
-- |Generates untyped AbstractCurry code from a CurrySyntax module. The type
--  signature takes place in every function type annotation, if it exists,
--  otherwise the dummy type "Prelude.untyped" is used.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
39
40
41
42
genUntypedAbstract :: ValueEnv -> TCEnv -> Module -> CurryProg
genUntypedAbstract tyEnv tcEnv modul
   = genAbstract (genAbstractEnv UntypedAcy tyEnv tcEnv modul) modul

Björn Peemöller 's avatar
Björn Peemöller committed
43
-- |Generate an AbstractCurry program term from the syntax tree
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
44
45
genAbstract :: AbstractEnv -> Module -> CurryProg
genAbstract env (Module mid _ decls)
Björn Peemöller 's avatar
Björn Peemöller committed
46
47
48
49
50
51
52
53
54
55
56
57
58
  = CurryProg modname imps types (Map.elems funcs) ops
  where
    modname    = moduleName mid
    partitions = foldl partitionDecl emptyPartitions decls
    (imps, _)  = mapfoldl genImportDecl env (reverse (importDecls partitions))
    (types, _) = mapfoldl genTypeDecl env (reverse (typeDecls partitions))
    (_, funcs) = Map.mapAccumWithKey (genFuncDecl False) env
                                     (funcDecls partitions)
    (ops, _)   = mapfoldl genOpDecl env (reverse (opDecls partitions))

-- ---------------------------------------------------------------------------
-- Partitions
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
59
60
61
62
63
64

-- The following types and functions can be used to spread a list of
-- CurrySyntax declarations into four parts: a list of imports, a list of
-- type declarations (data types and type synonyms), a table of function
-- declarations and a list of fixity declarations.

Björn Peemöller 's avatar
Björn Peemöller committed
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
{- |Data type for representing partitions of CurrySyntax declarations
    (according to the definition of the AbstractCurry program
    representation; type 'CurryProg').
    Since a complete function declaration usually consist of more than one
    declaration (e.g. rules, type signature etc.), it is necessary
    to collect them within an association list
-}
data Partitions = Partitions
  { importDecls :: [Decl]
  , typeDecls   :: [Decl]
  , funcDecls   :: Map.Map Ident [Decl]
  , opDecls     :: [Decl]
  } deriving Show

-- |Generate initial partitions
emptyPartitions :: Partitions
emptyPartitions = Partitions
  { importDecls = []
  , typeDecls   = []
  , funcDecls   = Map.empty
  , opDecls     = []
  }
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
87
88
89
90

-- Inserts a CurrySyntax top level declaration into a partition.
-- Note: declarations are collected in reverse order.
partitionDecl :: Partitions -> Decl -> Partitions
Björn Peemöller 's avatar
Björn Peemöller committed
91
92
93
94
95
-- import decls
partitionDecl parts decl@(ImportDecl _ _ _ _ _)
  = parts {importDecls = decl : importDecls parts }
-- type decls
partitionDecl parts decl@(DataDecl _ _ _ _)
96
  = parts {typeDecls = decl : typeDecls parts }
Björn Peemöller 's avatar
Björn Peemöller committed
97
partitionDecl parts decl@(TypeDecl _ _ _ _)
98
  = parts {typeDecls = decl : typeDecls parts }
Björn Peemöller 's avatar
Björn Peemöller committed
99
100
101
102
103
104
105
106
107
108
109
110
111
-- func decls
partitionDecl parts (TypeSig pos ids tyexpr)
  = partitionFuncDecls (\ident -> TypeSig pos [ident] tyexpr) parts ids
partitionDecl parts (EvalAnnot pos ids annot)
  = partitionFuncDecls (\ident -> EvalAnnot pos [ident] annot) parts ids
partitionDecl parts (FunctionDecl pos ident equs)
  = partitionFuncDecls (const (FunctionDecl pos ident equs)) parts [ident]
partitionDecl parts (ExternalDecl pos conv dname ident tyexpr)
  = partitionFuncDecls (const (ExternalDecl pos conv dname ident tyexpr)) parts [ident]
partitionDecl parts (FlatExternalDecl pos ids)
   = partitionFuncDecls (\ident -> FlatExternalDecl pos [ident]) parts ids
-- op decls
partitionDecl parts (InfixDecl pos fix prec idents)
112
   = parts {opDecls = map (\ident -> (InfixDecl pos fix prec [ident])) idents ++ opDecls parts }
Björn Peemöller 's avatar
Björn Peemöller committed
113
114
-- default
partitionDecl parts _ = parts
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
115
116
117

--
partitionFuncDecls :: (Ident -> Decl) -> Partitions -> [Ident] -> Partitions
Björn Peemöller 's avatar
Björn Peemöller committed
118
119
120
121
122
123
partitionFuncDecls genDecl parts ids
  = parts { funcDecls = foldl partitionFuncDecl (funcDecls parts) ids }
  where
    partitionFuncDecl funcs' ident
      = Map.insert ident
          (genDecl ident : fromMaybe [] (Map.lookup ident funcs')) funcs'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
124
125
126
127
128
129
130
131
132
133
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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242

-------------------------------------------------------------------------------
-- The following functions convert CurrySyntax terms to AbstractCurry
-- terms.

--
genImportDecl :: AbstractEnv -> Decl -> (String, AbstractEnv)
genImportDecl env (ImportDecl _ mid _ _ _) = (moduleName mid, env)
genImportDecl _ _ = error "GenAbstractCurry.genImportDecl: no import declaration"

--
genTypeDecl :: AbstractEnv -> Decl -> (CTypeDecl, AbstractEnv)
genTypeDecl env (DataDecl _ ident params cdecls)
   = let (idxs, env1)    = mapfoldl genTVarIndex env params
	 (cdecls', env2) = mapfoldl genConsDecl env1 cdecls
     in  (CType (genQName True env2 (qualifyWith (moduleId env) ident))
	        (genVisibility env2 ident)
	        (zip idxs (map name params))
	        cdecls',
	  resetScope env2)
genTypeDecl env (TypeDecl _ ident params typeexpr)
   = let (idxs, env1)      = mapfoldl genTVarIndex env params
	 (typeexpr', env2) = genTypeExpr env1 typeexpr
     in  (CTypeSyn (genQName True env2 (qualifyWith (moduleId env) ident))
	           (genVisibility env2 ident)
	           (zip idxs (map name params))
	           typeexpr',
	  resetScope env2)
genTypeDecl _ (NewtypeDecl pos _ _ _)
   = errorAt pos "'newtype' declarations are not supported in AbstractCurry"
genTypeDecl _ _
   = internalError "unexpected declaration"


--
genConsDecl :: AbstractEnv -> ConstrDecl -> (CConsDecl, AbstractEnv)
genConsDecl env (ConstrDecl _ _ ident params)
   = let (params', env') = mapfoldl genTypeExpr env params
     in  (CCons (genQName False env' (qualifyWith (moduleId env) ident))
	        (length params)
	        (genVisibility env' ident)
	        params',
	  env')
genConsDecl env (ConOpDecl pos ids ltype ident rtype)
   = genConsDecl env (ConstrDecl pos ids ident [ltype, rtype])


--
genTypeExpr :: AbstractEnv -> TypeExpr -> (CTypeExpr, AbstractEnv)
genTypeExpr env (ConstructorType qident targs)
   = let (targs', env') = mapfoldl genTypeExpr env targs
     in  (CTCons (genQName True env' qident) targs', env')
genTypeExpr env (VariableType ident)
   | isJust midx = (CTVar (fromJust midx, name ident), env)
   | otherwise   = (CTVar (idx, name ident), env')
 where
   midx        = getTVarIndex env ident
   (idx, env') = genTVarIndex env ident
genTypeExpr env (TupleType targs)
   | len == 0  = genTypeExpr env (ConstructorType qUnitId targs)
   | len == 1  = genTypeExpr env (head targs)
   | otherwise = genTypeExpr env (ConstructorType (qTupleId len) targs) -- len > 1
 where len = length targs
genTypeExpr env (ListType typeexpr)
   = genTypeExpr env (ConstructorType qListId [typeexpr])
genTypeExpr env (ArrowType texpr1 texpr2)
   = let (texpr1', env1) = genTypeExpr env texpr1
	 (texpr2', env2) = genTypeExpr env1 texpr2
     in  (CFuncType texpr1' texpr2', env2)
genTypeExpr env (RecordType fss mr)
   = let fs = concatMap (\ (ls1,typeexpr) -> map (\l -> (l,typeexpr)) ls1) fss
         (ls,ts) = unzip fs
         (ts',env1) = mapfoldl genTypeExpr env ts
         ls' = map name ls
     in case mr of
           Nothing
             -> (CRecordType (zip ls' ts') Nothing, env1)
           Just tvar@(VariableType _)
             -> let (CTVar iname, env2) = genTypeExpr env1 tvar
                in  (CRecordType (zip ls' ts') (Just iname), env2)
           (Just r@(RecordType _ _))
             -> let (CRecordType fields rbase, env2) = genTypeExpr env1 r
		    fields' = foldr (uncurry insertEntry)
				    fields
			            (zip ls' ts')
		in  (CRecordType fields' rbase, env2)
           _ -> internalError "illegal record base"


-- NOTE: every infix declaration must declare exactly one operator.
genOpDecl :: AbstractEnv -> Decl -> (COpDecl, AbstractEnv)
genOpDecl env (InfixDecl _ fix prec [ident])
   = (COp (genQName False env (qualifyWith (moduleId env) ident))
          (genFixity fix)
          (fromInteger prec),
      env)
genOpDecl _ _ = error "GenAbstractCurry.genOpDecl: no pattern match"


--
genFixity :: Infix -> CFixity
genFixity InfixL = CInfixlOp
genFixity InfixR = CInfixrOp
genFixity Infix  = CInfixOp


-- Generate an AbstractCurry function declaration from a list of CurrySyntax
-- function declarations.
-- NOTES:
--   - every declaration in 'decls' must declare exactly one function.
--   - since infered types are internally represented in flat style,
--     all type variables are renamed with generated symbols when
--     generating typed AbstractCurry.
genFuncDecl :: Bool -> AbstractEnv -> Ident -> [Decl] -> (AbstractEnv, CFuncDecl)
genFuncDecl isLocal env ident decls
   | not (null decls)
     = let qname          = genQName False env (qualify ident)
	   visibility    = genVisibility env ident
           evalannot     = maybe CFlex
243
244
245
	                         (\ x -> case x of
															(EvalAnnot _ _ ea) -> genEvalAnnot ea
															_                  -> error "Gen.GenAbstractCurry.genFuncDecl: no Eval Annotation")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
246
247
248
249
250
				 (find isEvalAnnot decls)
           (mtype, env1) = maybe (Nothing, env)
                                 (\ (t, env') -> (Just t, env'))
				 (genFuncType env decls)
	   (rules, env2) = maybe ([], env1)
251
252
253
			         (\ d -> case d of
							   (FunctionDecl _ _ equs) -> mapfoldl genRule env1 equs
							   _                       -> error "Gen.GenAbstractCurry.genFuncDecl: no FunctionDecl")
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
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
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
464
465
466
467
468
469
470
471
472
473
474
475
476
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
589
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
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
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
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
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
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
				 (find isFunctionDecl decls)
           mexternal     = fmap genExternal (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
       in  (env3, CFunc qname arity visibility typeexpr rule)
   | otherwise
     = internalError ("missing declaration for function \""
		      ++ show ident ++ "\"")
 where
   genFuncType env' decls'
      | acytype == UntypedAcy
	= fmap (genTypeSig env') (find isTypeSig decls')
      | acytype == TypedAcy
	= fmap (genTypeExpr env') 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' (ExternalDecl _ _ _ _ ts) = genTypeExpr env' ts
   genTypeSig _   _ = error "GenAbstractCurry.genFuncDecl.genTypeSig: no pattern match"

   genExternal (ExternalDecl _ _ mname ident' _)
      = CExternal (fromMaybe (name ident') mname)
   genExternal (FlatExternalDecl _ [ident'])
      = CExternal (name ident')
   genExternal _
      = internalError "illegal external declaration occured"

   compArity mtypeexpr rules
      | not (null rules)
        = let (CRule patts _ _) = head rules in length patts
      | otherwise
        = maybe (internalError ("unable to compute arity for function \""
				++ show ident ++ "\""))
	        compArityFromType
		mtypeexpr

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

   compRule evalannot rules mexternal
      | not (null rules) = CRules evalannot rules
      | otherwise
	= fromMaybe (internalError ("missing rule for function \""
				    ++ show ident ++ "\""))
	            mexternal


--
genRule :: AbstractEnv -> Equation -> (CRule, AbstractEnv)
genRule env (Equation pos lhs rhs)
   = let (patts, env1)  = mapfoldl (genPattern pos)
			           (beginScope env)
				   (simplifyLhs lhs)
	 (locals, env2) = genLocalDecls env1 (simplifyRhsLocals rhs)
	 (crhss, env3)  = mapfoldl (genCrhs pos) env2 (simplifyRhsExpr rhs)
     in  (CRule patts crhss locals, endScope env3)


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


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

   genLocalPatternIndex env' (VariablePattern ident)
      = snd (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 (snd (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 -> Map.Map Ident [Decl] -> [Decl]
	        -> ([CLocalDecl], AbstractEnv)
   genLocals env' _ [] = ([], env')
   genLocals env' fdecls ((FunctionDecl _ ident _):decls1)
      = let (funcdecl, env1) = genLocalFuncDecl (beginScope env') fdecls ident
	    (locals, env2)   = genLocals (endScope env1) fdecls decls1
        in  (funcdecl:locals, env2)
   genLocals env' fdecls ((ExternalDecl _ _ _ ident _):decls1)
      = let (funcdecl, env1) = genLocalFuncDecl (beginScope env') fdecls ident
	    (locals, env2)   = genLocals (endScope env1) fdecls decls1
        in  (funcdecl:locals, env2)
   genLocals env' fdecls ((FlatExternalDecl pos idents):decls1)
      | null idents = genLocals env' fdecls decls1
      | otherwise
        = let (funcdecl, env1)
		= genLocalFuncDecl (beginScope env') fdecls (head idents)
	      (locals, env2)
		= genLocals (endScope env1)
		            fdecls
			    (FlatExternalDecl pos (tail idents):decls1)
          in  (funcdecl:locals, env2)
   genLocals env' fdecls (PatternDecl pos constr rhs : decls1)
      = let (patt, env1)    = genLocalPattern pos env' constr
	    (plocals, env2) = genLocalDecls (beginScope env1)
			                    (simplifyRhsLocals rhs)
	    (expr, env3)    = genLocalPattRhs pos env2 (simplifyRhsExpr rhs)
	    (locals, env4)  = genLocals (endScope env3) fdecls decls1
	in  (CLocalPat patt expr plocals:locals, env4)
   genLocals env' fdecls ((ExtraVariables pos idents):decls1)
      | null idents  = genLocals env' fdecls decls1
      | otherwise
        = let ident  = head idents
	      idx    = fromMaybe
		         (internalError ("cannot find index"
					 ++ " for free variable \""
					 ++ show ident ++ "\""))
		         (getVarIndex env' ident)
	      decls' = ExtraVariables pos (tail idents) : decls1
	      (locals, env'') = genLocals env' fdecls decls'
          in (CLocalVar (idx, name ident) : locals, env'')
   genLocals env' fdecls ((TypeSig _ _ _):decls1)
      = genLocals env' fdecls decls1
   genLocals _ _ decl = internalError ("unexpected local declaration: \n"
				       ++ show (head decl))

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

   genLocalPattern pos env' (LiteralPattern lit)
      = case lit of
       String _ cs
         -> genLocalPattern pos env'
                 (ListPattern [] (map (LiteralPattern . Char noRef) cs))
       _ -> (CPLit (genLiteral lit), env')
   genLocalPattern _ env' (VariablePattern ident)
      = let idx = fromMaybe
		     (internalError ("cannot find index"
				    ++ " for pattern variable \""
				    ++ show ident ++ "\""))
		     (getVarIndex env' ident)
        in  (CPVar (idx, name ident), env')
   genLocalPattern pos env' (ConstructorPattern qident args)
      = let (args', env'') = mapfoldl (genLocalPattern pos) env' args
	in (CPComb (genQName False env' qident) args', env'')
   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 pos _ (NegativePattern _ _)
      = errorAt pos "negative patterns are not supported in AbstractCurry"
   genLocalPattern pos env' (AsPattern ident cterm)
      = let (patt, env1) = genLocalPattern pos env' cterm
	    idx          = fromMaybe
			      (internalError ("cannot find index"
					      ++ " for alias variable \""
					      ++ show ident ++ "\""))
			      (getVarIndex env1 ident)
        in  (CPAs (idx, name ident) patt, env1)
   genLocalPattern pos env' (LazyPattern _ cterm)
      = let (patt, env'') = genLocalPattern pos env' cterm
        in  (CPLazy patt, env'')
   genLocalPattern pos env' (RecordPattern fields mr)
      = let (fields', env1) = mapfoldl (genField genLocalPattern) env' fields
	    (mr', env2)
		= maybe (Nothing, env1)
		        (applyFst Just . genLocalPattern pos env1)
			mr
	in  (CPRecord fields' mr', env2)
   genLocalPattern _ _ _ = error "GenAbstractCurry.genLocalDecls.genLocalPattern: no pattern match"

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


--
genExpr :: Position -> AbstractEnv -> Expression -> (CExpr, AbstractEnv)
genExpr pos env (Literal lit)
   = case lit of
       String _ cs -> genExpr pos env (List [] (map (Literal . Char noRef) cs))
       _           -> (CLit (genLiteral lit), env)
genExpr _ env (Variable qident)
   | isJust midx          = (CVar (fromJust midx, name ident), env)
   | qident == qSuccessId = (CSymbol (genQName False env qSuccessFunId), env)
   | otherwise            = (CSymbol (genQName False env qident), env)
 where
   ident = unqualify qident
   midx  = getVarIndex env ident
genExpr _ env (Constructor qident)
   = (CSymbol (genQName False env qident), env)
genExpr pos env (Paren expr)
   = genExpr pos env expr
genExpr pos env (Typed expr _)
   = genExpr pos env expr
genExpr pos env (Tuple _ args)
   | len == 0  = genExpr pos env (Variable qUnitId)
   | len == 1  = genExpr pos env (head args)
   | otherwise = genExpr pos env (foldl Apply (Variable (qTupleId (length args))) args) -- len > 1
 where len = length args
genExpr pos env (List _ args)
   = let cons = Constructor qConsId
	 nil  = Constructor qNilId
     in  genExpr pos env (foldr (Apply . Apply cons) nil args)
genExpr pos env (ListCompr _ expr stmts)
   = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts
	 (expr', env2)  = genExpr pos env1 expr
     in  (CListComp expr' stmts', endScope env2)
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 (expr1', env1) = genExpr pos env expr1
	 (expr2', env2) = genExpr pos env1 expr2
     in  (CApply expr1' expr2', env2)
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 (params', env1) = mapfoldl (genPattern pos) (beginScope env) params
	 (expr', env2)   = genExpr pos env1 expr
     in  (CLambda params' expr', endScope env2)
genExpr pos env (Let decls expr)
   = let (decls', env1) = genLocalDecls (beginScope env) decls
	 (expr', env2)  = genExpr pos env1 expr
     in  (CLetDecl decls' expr', endScope env2)
genExpr pos env (Do stmts expr)
   = let (stmts', env1) = mapfoldl (genStatement pos) (beginScope env) stmts
	 (expr', env2)  = genExpr pos env1 expr
     in  (CDoExpr (stmts' ++ [CSExpr expr']), endScope env2)
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 (expr', env1) = genExpr pos env expr
	 (alts', env2) = mapfoldl genBranchExpr env1 alts
     in  (CCase expr' alts', env2)
genExpr _ env (RecordConstr fields)
   = let (fields', env1) = mapfoldl (genField genExpr) env fields
     in  (CRecConstr fields', env1)
genExpr pos env (RecordSelection expr label)
   = let (expr', env1) = genExpr pos env expr
     in  (CRecSelect expr' (name label), env1)
genExpr pos env (RecordUpdate fields expr)
   = let (fields', env1) = mapfoldl (genField genExpr) env fields
         (expr', env2)   = genExpr pos env1 expr
     in  (CRecUpdate fields' expr', env2)


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


-- NOTE: guarded expressions and local declarations in case branches
-- are not supported in PAKCS
genBranchExpr :: AbstractEnv -> Alt -> (CBranchExpr, AbstractEnv)
genBranchExpr env (Alt pos patt rhs)
   = let (patt', env1) = genPattern pos (beginScope env) patt
	 (expr', env2) = genBranchRhs pos env1 (simplifyRhsExpr rhs)
     in  (CBranch patt' expr', endScope env2)
 where
   genBranchRhs pos' env' [(Variable _, expr)]
      = genExpr pos' env' expr
   genBranchRhs pos' _ _
      = errorAt pos' ("guarded expressions in case alternatives"
		     ++ " are not supported in AbstractCurry")


--
genPattern :: Position -> AbstractEnv -> ConstrTerm -> (CPattern, AbstractEnv)
genPattern pos env (LiteralPattern lit)
   = case lit of
       String _ cs
         -> genPattern pos env (ListPattern [] (map (LiteralPattern . Char noRef) cs))
       _ -> (CPLit (genLiteral lit), env)
genPattern _ env (VariablePattern ident)
   = let (idx, env') = genVarIndex env ident
     in  (CPVar (idx, name ident), env')
genPattern pos env (ConstructorPattern qident args)
   = let (args', env') = mapfoldl (genPattern pos) env args
     in  (CPComb (genQName False env qident) args', env')
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)
  | len == 0  = genPattern pos env (ConstructorPattern qUnitId [])
  | len == 1  = genPattern pos env (head args)
  | otherwise = genPattern pos env (ConstructorPattern (qTupleId len) args) -- len > 1
 where len = length args
genPattern pos env (ListPattern _ args)
   = genPattern pos env (foldr (\x1 x2 -> ConstructorPattern qConsId [x1, x2])
		         (ConstructorPattern qNilId [])
		         args)
genPattern pos _ (NegativePattern _ _)
   = errorAt pos "negative patterns are not supported in AbstractCurry"
genPattern pos env (AsPattern ident cterm)
   = let (patt, env1) = genPattern pos env cterm
	 (idx, env2) = genVarIndex env1 ident
     in  (CPAs (idx, name ident) patt, env2)
genPattern pos env (LazyPattern _ cterm)
   = let (patt, env') = genPattern pos env cterm
     in  (CPLazy patt, env')
genPattern pos env (FunctionPattern qident cterms)
   = let (patts, env') = mapfoldl (genPattern pos) env cterms
     in  (CPFuncComb (genQName False env qident) patts, env')
genPattern pos env (InfixFuncPattern cterm1 qident cterm2)
   = genPattern pos env (FunctionPattern qident [cterm1, cterm2])
genPattern pos env (RecordPattern fields mr)
   = let (fields', env1) = mapfoldl (genField genPattern) env fields
         (mr', env2)     = maybe (Nothing, env1)
                                 (applyFst Just . genPattern pos env1)
				 mr
     in  (CPRecord fields' mr', env2)


--
genField :: (Position -> AbstractEnv -> a -> (b, AbstractEnv))
	 -> AbstractEnv -> Field a -> (CField b, AbstractEnv)
genField genTerm env (Field pos label term)
   = let (term',env1) = genTerm pos env term
     in  ((name label, term'), env1)

--
genLiteral :: Literal -> CLiteral
genLiteral (Char _ c)  = CCharc c
genLiteral (Int _ i)   = CIntc i
genLiteral (Float _ f) = CFloatc f
genLiteral _           = internalError "unsupported literal"


-- Notes:
-- - Some prelude identifiers are not quialified. The first check ensures
--   that they get a correct qualifier.
-- - The test for unqualified identifiers is necessary to qualify
--   them correctly in the untyped AbstractCurry representation.
genQName :: Bool -> AbstractEnv -> QualIdent -> QName
genQName isTypeCons env qident
   | isPreludeSymbol qident
     = genQualName (qualQualify preludeMIdent qident)
   | not (isQualified qident)
     = genQualName (getQualIdent (unqualify qident))
   | otherwise
     = genQualName qident
 where
  genQualName qid
     = let (mmid, ident) = (qualidMod qid, qualidId qid)
	   mid = maybe (moduleId env)
		       (\mid' -> fromMaybe mid' (Map.lookup mid' (imports env)))
		       mmid
       in  (moduleName mid, name ident)

  getQualIdent ident
     | isTypeCons = case (lookupTC ident (tconsEnv env)) of
		      --[DataType qid _ _] -> qid
		      --[RenamingType qid _ _] -> qid
		      --[AliasType qid _ _] -> qid
		      [info] -> origName info
		      _ ->  qualifyWith (moduleId env) ident
     | otherwise  = case (lookupValue ident (typeEnv env)) of
		      --[DataConstructor qid _] -> qid
		      --[NewtypeConstructor qid _] -> qid
		      --[Value qid _] -> qid
		      [info] -> origName info
		      _ -> qualifyWith (moduleId env) ident



--
genVisibility :: AbstractEnv -> Ident -> CVisibility
genVisibility env ident
   | isExported env ident = Public
   | otherwise            = Private


--
genEvalAnnot :: EvalAnnotation -> CEvalAnnot
genEvalAnnot EvalRigid  = CRigid
genEvalAnnot EvalChoice = CChoice


-------------------------------------------------------------------------------
-- This part defines an environment containing all necessary information
-- for generating the AbstractCurry representation of a CurrySyntax term.

-- Data type for representing an AbstractCurry generator environment.
--
--    moduleName  - name of the module
--    typeEnv     - table of all known types
--    exports     - table of all exported symbols from the module
--    imports     - table of import aliases
--    varIndex    - index counter for generating variable indices
--    tvarIndex   - index counter for generating type variable indices
--    varScope    - stack of variable tables
--    tvarScope   - stack of type variable tables
--    acyType     - type of AbstractCurry code to be generated
data AbstractEnv = AbstractEnv {moduleId   :: ModuleIdent,
				typeEnv    :: ValueEnv,
				tconsEnv   :: TCEnv,
				exports    :: Set.Set Ident,
				imports    :: Map.Map ModuleIdent ModuleIdent,
				varIndex   :: Int,
				tvarIndex  :: Int,
				varScope   :: [Map.Map Ident Int],
				tvarScope  :: [Map.Map Ident Int],
                                acyType    :: AbstractType
			       } deriving Show

-- 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)


-- Initializes the AbstractCurry generator environment.
genAbstractEnv :: AbstractType -> ValueEnv -> TCEnv -> Module -> AbstractEnv
genAbstractEnv absType tyEnv tcEnv (Module mid exps decls)
   = AbstractEnv
       {moduleId     = mid,
	typeEnv      = tyEnv,
	tconsEnv     = tcEnv,
	exports      = foldl (buildExportTable mid decls) Set.empty exps',
	imports      = foldl buildImportTable Map.empty decls,
	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 (ExternalDecl _ _ _ ident _ : ds)
   = Export (qualifyWith mid ident) : buildExports mid ds
buildExports mid (FlatExternalDecl _ 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

--
insertExportedIdent :: Set.Set Ident -> Ident -> Set.Set Ident
insertExportedIdent env ident = Set.insert ident env

--
getConstrIdents :: Decl -> [Ident]
getConstrIdents (DataDecl _ _ _ constrs)
   = map getConstrIdent constrs
 where
   getConstrIdent (ConstrDecl _ _ ident _)  = ident
   getConstrIdent (ConOpDecl _ _ _ ident _) = ident
getConstrIdents _ = error "GenAbstractCurry.getConstrIdents: no pattern match"


-- Builds a table for dereferencing import aliases
buildImportTable :: Map.Map ModuleIdent ModuleIdent -> Decl
		    -> Map.Map ModuleIdent ModuleIdent
buildImportTable env (ImportDecl _ mid _ malias _)
   = Map.insert (fromMaybe mid malias) mid env
buildImportTable env _ = env


-- 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 -> (Int, AbstractEnv)
genVarIndex env ident
   = let idx   = varIndex env
         vtabs = varScope env
	 vtab  = head vtabs --if null vtabs then Map.empty else head vtabs
     in  (idx, env {varIndex = idx + 1,
		    varScope = Map.insert ident idx vtab : sureTail vtabs})

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


-- 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  = if oneElement vs then vs else tail vs,
		    tvarScope = if oneElement tvs then tvs else tail tvs}
 where
 vs  = varScope env
 tvs = tvarScope env


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

-- Some identifiers...
qEnumFromId :: QualIdent
qEnumFromId       = qualifyWith preludeMIdent (mkIdent "enumFrom")

qEnumFromThenId :: QualIdent
qEnumFromThenId   = qualifyWith preludeMIdent (mkIdent "enumFromThen")

qEnumFromToId :: QualIdent
qEnumFromToId     = qualifyWith preludeMIdent (mkIdent "enumFromTo")

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

qNegateId :: QualIdent
qNegateId         = qualifyWith preludeMIdent (mkIdent "negate")

qIfThenElseId :: QualIdent
qIfThenElseId     = qualifyWith preludeMIdent (mkIdent "if_then_else")

qSuccessFunId :: QualIdent
qSuccessFunId     = qualifyWith preludeMIdent (mkIdent "success")

-- The following functions check whether a declaration is of a certain kind
isFunctionDecl :: Decl -> Bool
isFunctionDecl (FunctionDecl _ _ _) = True
isFunctionDecl _                    = False

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

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


-- Checks, whether a symbol is defined in the Prelude.
isPreludeSymbol :: QualIdent -> Bool
isPreludeSymbol qident
   = let (mmid, ident) = (qualidMod qident, qualidId 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 qident)     = Variable qident
opToExpr (InfixConstr qident) = Constructor qident


-- 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 _ ts] -> (\ (ForAll _ ty) -> Just (fromType ty)) ts
       _            -> 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 _ ts] -> (\ (ForAll _ ty) -> Just (fromType ty)) ts
       _            -> Nothing


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

simplifyRhsExpr :: Rhs -> [(Expression, Expression)]
simplifyRhsExpr (SimpleRhs _ expr _)
   = [(Variable qSuccessId, expr)]
simplifyRhsExpr (GuardedRhs crhs _)
   = map (\ (CondExpr _ cond expr) -> (cond, expr)) crhs

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


-- FIXME This mapfold is a twisted mapAccumL
-- A combination of 'map' and 'foldl'. It maps a function to a list
-- from left to right while updating the argument 'e' continously.
mapfoldl :: (a -> b -> (c,a)) -> a -> [b] -> ([c], a)
mapfoldl _ e []     = ([], e)
mapfoldl f e (x:xs) = let (x', e')   = f e x
                          (xs', e'') = mapfoldl f e' xs
                      in  (x':xs', e'')

-- Inserts an element under a key into an association list
insertEntry :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
insertEntry k e [] = [(k,e)]
insertEntry k e ((x,y):xys)
   | k == x    = (k,e):xys
   | otherwise = (x,y) : insertEntry k e xys


-- Returns the list without the first element. If the list is empty, an
-- empty list will be returned.
sureTail :: [a] -> [a]
sureTail []     = []
sureTail (_:xs) = xs

-- Returns 'True', if a list contains exactly one element
oneElement :: [a] -> Bool
oneElement [_] = True
oneElement _   = False

-- Applies 'f' on the first value in a tuple
applyFst :: (a -> c) -> (a,b) -> (c,b)
applyFst f (x,y) = (f x, y)