← Back to branch summary

~ubuntu-branches/ubuntu/vivid/monodevelop/vivid-proposed

« back to all changes in this revision

Viewing changes to external/fsharpbinding/monodevelop/MonoDevelop.FSharpBinding/PowerPack/CodeDomGenerator.fs

  • Committer: Package Import Robot
  • Author(s): Jo Shields
  • Date: 2014-10-09 14:09:23 UTC
  • mfrom: (10.3.5)
  • Revision ID: package-import@ubuntu.com-20141009140923-s0d22u5f9kg8jvds
Tags: 5.5.0.227-1
http://bugs.debian.org/754316
* [b2c8331] Imported Upstream version 5.5.0.227 (Closes: #754316)
* [d210995] Delete obsolete patches
* [1b59ae1] Clear patch fizz, via quilt refresh
* [3dd147d] Fix error in configure.in which applies for tarball builds but 
  not git builds when running autoreconf
* [21c2a57] Remove Metacity references for good
* [3331661] Ensure NUnit 2.6.3 is installed
* [fd85c88] Build-depend on NuGet
* [a1ae116] Add WebKit to build dependencies, for Xwt moduleref resolution
* [9b4cf12] Since the GDB addin is integrated now, declare it in 
  debian/control
* [6231562] Correct NUnit links
* [3d2b693] Fix NuGet addin, by copying libs locally
* [74bf9a8] Don't symlink unused Mocks NUnit assembly
* [ade52b2] Ensure IKVM.Reflection is built with default (4.5) profile

Show diffs side-by-side

added added

removed removed

Lines of Context:
external/fsharpbinding/monodevelop/MonoDevelop.FSharpBinding/PowerPack/CodeDomGenerator.fs
 
1
// This is a _modified_ version of the original implementation of the FSharp CodeDomGenerator
 
2
//
 
3
// This CodeDomGenerator is used by monodevelop to generate code for ASP.NET, 'empty class', snippets and other things.
 
4
// The code generated before the modifications was really complicated because it was a full 
 
5
// code generator. For monodevelop binding all we need is a codedom that generates nice looking 
 
6
// code in the specific cases we care about. So we have started to adjust the codedom to do nice 
 
7
// code for the samples generated by monodevelop. 
 
8
//
 
9
// This code dom should not currently be used for F# code generation in other settings.
 
10
 
 
11
 
 
12
namespace Microsoft.FSharp.Compiler.CodeDom.Internal
 
13
#nowarn "57" // parametrized active patterns
 
14
#nowarn "62" // This construct is for ML compatibility.
 
15
 
 
16
open System
 
17
open System.IO
 
18
open System.Text
 
19
open System.Reflection
 
20
open System.Collections
 
21
open System.Collections.Generic
 
22
open System.CodeDom
 
23
open System.CodeDom.Compiler
 
24
 
 
25
open Microsoft.FSharp.Compiler.CodeDom.Internal.Visitor
 
26
 
 
27
 
 
28
module internal Generator =
 
29
 
 
30
    type ResizeArray<'T> = System.Collections.Generic.List<'T> // alias
 
31
  
 
32
    //---------------------------------------------------------------------------------------------
 
33
    // Context and configuration
 
34
 
 
35
    type AdditionalOptions =
 
36
      /// No extra configuration
 
37
      | None = 0                      
 
38
      
 
39
      /// Reference inherited fields using "fld" instead of "this.fld" 
 
40
      /// (could be used in the future to allow implicit classes in ASP.NET?)
 
41
      | UnknonwFieldsAsLocals = 1     
 
42
                                      
 
43
      /// Hacking for ASP.NET incorrect array initializers 
 
44
      /// They generate "string" where codedom test suite uses "string[]"
 
45
      | AspNetArrays = 2              
 
46
                                      
 
47
    
 
48
    type Context = 
 
49
      {
 
50
        /// Some unique ID for every namespace (so we don't have name clashes)
 
51
        UniqueID:string
 
52
        
 
53
        /// Options, output, ...
 
54
        Options:AdditionalOptions
 
55
        Writer:IndentedTextWriter
 
56
        
 
57
        // *** Method/type scope ***
 
58
        
 
59
        /// Names of all type arguments in scope (need to rename T -> 'T etc.)
 
60
        TypeArgumentNames:Set<string>
 
61
        /// Types of all local variables in the method
 
62
        LocalVariableTypes:Map<string,Type>;
 
63
        /// Type of the method 
 
64
        CurrentMethodReturnType:CodeTypeReference option;
 
65
        /// We use exception for returning value when generating complex
 
66
        /// code that returns using imperative "return" statement
 
67
        ReturnUsingException:bool;
 
68
      
 
69
        // *** Information for the current class *** 
 
70
        
 
71
        CurrentType:CodeTypeDeclaration;
 
72
        BaseTypes:CodeTypeReference option * CodeTypeReference list
 
73
        AllFields:Map<string,CodeMemberField>;
 
74
        AllProps:Map<string,CodeMemberProperty>;
 
75
        AllMeths:Map<string,CodeMemberMethod>;
 
76
        AllEvents:Map<string,CodeMemberEvent>;
 
77
        FieldTypes:Map<string,CodeTypeReference>;
 
78
        PropertyTypes:Map<string,CodeTypeReference>;
 
79
        DeclaredEvents:CodeMemberEvent list;
 
80
          
 
81
        // *** Namespace scope ***         
 
82
        
 
83
        // Renamed types (when flattening nested classes)
 
84
        TypeRenames:Map<string,string>
 
85
        // Current namespace (can't be used in the type reference expression)
 
86
        CurrentNamespace:string; 
 
87
        // Set of interface names declared in the current namespace
 
88
        DeclaredInterfaces:Set<string>
 
89
        // A static Main method declared by one of the classes in this namespace
 
90
        MainMethodForCurrentNamespace:(CodeEntryPointMethod * CodeTypeDeclaration) option
 
91
      }
 
92
    
 
93
    /// Create context using specified text writer and options
 
94
    let createContext (wr:TextWriter) (opts:CodeGeneratorOptions) (addopts) = 
 
95
      { UniqueID = (Guid.NewGuid()).ToString("N")
 
96
        Writer = new IndentedTextWriter(wr); TypeRenames = Map.empty; 
 
97
        CurrentType = null; CurrentNamespace = ""; 
 
98
        DeclaredEvents = []; 
 
99
        BaseTypes = (None, []); 
 
100
        AllFields = Map.empty;
 
101
        AllEvents = Map.empty;
 
102
        AllProps = Map.empty;
 
103
        AllMeths = Map.empty;
 
104
        FieldTypes = Map.empty 
 
105
        CurrentMethodReturnType = None; 
 
106
        LocalVariableTypes = Map.empty; 
 
107
        ReturnUsingException = false; 
 
108
        PropertyTypes = Map.empty
 
109
        Options = addopts; 
 
110
        DeclaredInterfaces = Set.empty; 
 
111
        TypeArgumentNames = Set.empty; 
 
112
        MainMethodForCurrentNamespace = None }    
 
113
 
 
114
    /// Where are we generating member?
 
115
    type MemberGenerateType = 
 
116
      | InsideInterface = 0
 
117
      | InsideStruct = 1
 
118
      | InsideClass = 2
 
119
      
 
120
    //---------------------------------------------------------------------------------------------
 
121
    // Collections and combinators for generating
 
122
 
 
123
    /// Function composition operator
 
124
    let (+>) (ctx:Context -> Context) (foo:Context -> Context) x =
 
125
      foo (ctx x);
 
126
 
 
127
    /// Print unique id using: "+> uniqid"
 
128
    let uniqid (c:Context) =
 
129
      c.Writer.Write(c.UniqueID);
 
130
      c;
 
131
 
 
132
    /// Break-line and append specified string
 
133
    let (++) (ctx:Context -> Context) (str:String) x =
 
134
      let c = (ctx x)
 
135
      c.Writer.WriteLine();
 
136
      c.Writer.Write(str);
 
137
      c;
 
138
 
 
139
    /// Append specified string without line-break
 
140
    let (--) (ctx:Context -> Context) (str:String) x =
 
141
      let c = (ctx x)
 
142
      c.Writer.Write(str);
 
143
      c;
 
144
 
 
145
    /// Call function, but give it context as an argument      
 
146
    let withCtxt f x =
 
147
      (f x) x;
 
148
      
 
149
    /// Identity function
 
150
    let id a = a
 
151
 
 
152
    /// Print object converted to string
 
153
    let str (o: 'T) (ctx:Context) =
 
154
      ctx.Writer.Write(o :> obj);
 
155
      ctx;
 
156
 
 
157
    /// Create closure to do the counting 
 
158
    /// (this is usend when we need indexing during collection processing)
 
159
    let createCounter() =   
 
160
      let i = ref (-1)
 
161
      (fun () -> i := (!i) + 1; !i)
 
162
      
 
163
    /// Perform map and filter operations in one 
 
164
    let rec mapFilter f l =
 
165
      match l with
 
166
      | [] -> [];
 
167
      | a::r -> match (f a) with | None -> (mapFilter f r) | Some el -> el::(mapFilter f r)
 
168
 
 
169
    /// Process collection - keeps context through the whole processing calls 'f' for every 
 
170
    /// element in sequence and 'fs' between every two elements as a separator
 
171
    let col fs (c:IEnumerable) f (ctx:Context) = 
 
172
      let mutable tryPick = true in
 
173
      let mutable st = ctx
 
174
      let e = c.GetEnumerator()
 
175
      while (e.MoveNext()) do
 
176
        if (tryPick) then tryPick <- false else st <- fs st
 
177
        st <- f (unbox e.Current) st
 
178
      st
 
179
    
 
180
    /// Process collection - keeps context through the whole processing
 
181
    /// calls 'f' for every element in sequence and 'fs' between every two elements 
 
182
    /// as a separator. This is a variant that works on typed collections.
 
183
    let colT fs (c:seq<'T>) f (ctx:Context) =
 
184
      let mutable tryPick = true in
 
185
      let mutable st = ctx
 
186
      let e = c.GetEnumerator();
 
187
      while (e.MoveNext()) do
 
188
        if (tryPick) then tryPick <- false else st <- fs st;
 
189
        st <- f (e.Current) st;
 
190
      st
 
191
        
 
192
    /// Call specified function only on elements of specified type.
 
193
    /// (performs dynamic type test using x.GetType())
 
194
    let colFilterT<'T> fs (c:IEnumerable) (f: 'T -> Context -> Context) ctx =
 
195
      let sq : seq<'T>
 
196
          = c |> Seq.cast |> Seq.filter (fun (o:obj) -> o.GetType() = typeof<'T>) |> Seq.cast
 
197
      colT fs sq f ctx
 
198
 
 
199
    let colFilter<'T> fs (c:IEnumerable) (f: 'T -> Context -> Context) ctx =
 
200
      let sq = c |> Seq.cast |> Seq.filter (fun (o:obj) -> o.GetType() = typeof<'T>)
 
201
      col fs sq f ctx
 
202
 
 
203
    // Separator functions        
 
204
    let sepDot          = id -- "."
 
205
    let sepWordAnd      = id -- " and "      
 
206
    let sepSpace        = id -- " "      
 
207
    let sepNln          = id ++ ""
 
208
    let sepArgs         = id -- ", "
 
209
    let sepArgsSemi     = id -- "; "
 
210
    let sepNone         = id
 
211
    let sepStar         = id -- " * "
 
212
    let sepNlnSemiSpace = id -- ";" ++ "  "
 
213
    
 
214
    //---------------------------------------------------------------------------------------------
 
215
    // F# keywords and identifiers and also type resolving for standard .NET libraries
 
216
    
 
217
    let fsKeyWords = 
 
218
      set ["abstract"; "and"; "as"; "assert"; "asr"; "base"; "begin"; "class"; "default"; "delegate"; "do"; "done";
 
219
           "downcast"; "downto"; "elif"; "else"; "end"; "exception"; "extern"; "false"; "finally"; "for"; "fun";
 
220
           "function"; "if"; "in"; "inherit"; "inline"; "interface"; "internal"; "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; "lxor";
 
221
           "match"; "member"; "method"; "mod"; "module"; "mutable"; "namespace"; "new"; "null"; "of"; "open"; "or"; "override";
 
222
           "private"; "public"; "rec"; "return"; "sig"; "static"; "struct"; "then"; "to"; "true"; "try"; "type"; "upcast"; "use"; "val"; "virtual"; "void"; "when"; 
 
223
           "while"; "with"; "yield";
 
224
           
 
225
           "atomic"; "break"; 
 
226
           "checked"; "component"; "const"; "constraint"; "constructor"; "continue"; 
 
227
           "eager"; 
 
228
           "fixed"; "fori"; "functor"; "global";"recursive";"measure"; 
 
229
           "include";  (* "instance"; *)
 
230
           "mixin"; 
 
231
           "object"; "parallel"; "params";  "process"; "protected"; "pure"; (* "pattern"; *)
 
232
           "sealed"; "trait";  "tailcall";
 
233
           "volatile"; ]
 
234
 
 
235
    let isValidIdentifier str = 
 
236
      not (fsKeyWords.Contains(str))
 
237
 
 
238
    let makeEscapedIdentifier str = 
 
239
      if (fsKeyWords.Contains(str)) then "i'"+str+"'" else str;
 
240
 
 
241
    let makeValidIdentifier str = 
 
242
      if (fsKeyWords.Contains(str)) then "_"+str else str;
 
243
      
 
244
    let freshName = 
 
245
      let counter = createCounter ()
 
246
      (fun () -> "UnnamedMethod_" + counter().ToString())
 
247
 
 
248
    // List of "known" libraries that we try to search when we need to resolve a type
 
249
    let coreAssemblies = 
 
250
       ["mscorlib"; "System"; "System.Web"; "System.Xml"; 
 
251
        "System.Data"; "System.Deployment"; "System.Design"; "System.DirectoryServices"; 
 
252
        "System.Drawing.Design"; "System.Drawing"; "System.EnterpriseServices"; 
 
253
        "System.Management"; "System.Messaging"; "System.Runtime.Remoting"; 
 
254
        "System.Security"; "System.ServiceProcess"; "System.Transactions"; 
 
255
        "System.Configuration"; "System.Web.Mobile"; "System.Web.RegularExpressions"; 
 
256
        "System.Web.Services"; "System.Windows.Forms"; "System.Core";
 
257
        "PresentationCore"; "PresentationFramework"; "WindowsBase"; "WindowsFormsIntegration"]
 
258
      |> List.map ( fun n -> lazy(try Some(System.Reflection.Assembly.LoadWithPartialName(n)) with _ -> None); );
 
259
 
 
260
    let dict = new Dictionary<string, Type>();
 
261
 
 
262
    /// Tries to find .NET type for specified type name
 
263
    /// This is used when we need to know type in order to generate something correctly,
 
264
    /// but it's just a fallback case
 
265
    let (|FoundSystemType|_|) s =
 
266
      if (dict.ContainsKey(s)) then Some dict.[s] else
 
267
      let ty = coreAssemblies |> Seq.tryPick ( fun lazyAsm -> 
 
268
        match lazyAsm.Force() with 
 
269
        | None -> None
 
270
        | Some asm -> 
 
271
            match (try asm.GetType(s) with _ -> null) with
 
272
            | null -> None
 
273
            | t -> Some t ) 
 
274
      match ty with | Some t -> dict.Add(s, t) | _ -> ()
 
275
      ty
 
276
 
 
277
    //---------------------------------------------------------------------------------------------
 
278
    // Interface recognition magic
 
279
 
 
280
    // If the name of the type matches a name of interface declared in this file 
 
281
    // (stored in a set in the context) than we treat it as an interface, otherwise
 
282
    // we rely on .NET naming pattern (starts with I followed by uppercase letter)
 
283
    // We could search known DLLs, but that's useless since all DLLs we could find
 
284
    // follow this naming pattern...
 
285
    let isInterface (t:CodeTypeReference) (ctx:Context) = 
 
286
      let tn = t.BaseType.Substring(t.BaseType.LastIndexOf(".") + 1) 
 
287
      let decLoc = Set.contains tn ctx.DeclaredInterfaces
 
288
      decLoc || (tn.StartsWith("I") && (((tn.ToUpper()).[1]) = (tn.[1])))
 
289
 
 
290
 
 
291
    // Splits base types into base class and implemented interfaces
 
292
    // using rules described in <c>isInterface</c>
 
293
    // Returns optional base class and list of interfaces
 
294
    let resolveHierarchy (c:CodeTypeDeclaration) ctx =
 
295
      let (interf, bcl) = 
 
296
        c.BaseTypes |> Seq.cast |> Seq.toList
 
297
          |> List.partition ( fun (r:CodeTypeReference) -> isInterface r ctx )
 
298
          
 
299
      if (bcl.Length = 0) then 
 
300
        // All supertypes all interfaces
 
301
        (None, interf)
 
302
      elif (bcl.Length = 1) then 
 
303
        // Exactly one supertype is class, other were recognized as interfaces
 
304
        (Some (List.head bcl), interf) 
 
305
      else 
 
306
        // Fallback case - we found more than one supertypes that look like a class
 
307
        // so we just return the tryPick one and treat other as interfaces
 
308
        (Some (List.head bcl), (List.tail bcl)@interf) 
 
309
        
 
310
    
 
311
    //---------------------------------------------------------------------------------------------
 
312
    // Generating strings and working with context   
 
313
    
 
314
    let incIndent (ctx:Context) = 
 
315
      ctx.Writer.Indent <- ctx.Writer.Indent + 1
 
316
      ctx
 
317
 
 
318
    let decIndent (ctx:Context) = 
 
319
      ctx.Writer.Indent <- ctx.Writer.Indent - 1
 
320
      ctx
 
321
 
 
322
    /// Output string as a valid F# identifier
 
323
    let (-!) (ctx:Context -> Context) (str:String) x =
 
324
      let c = (ctx x)
 
325
      c.Writer.Write(makeValidIdentifier str);
 
326
      c;
 
327
      
 
328
    //---------------------------------------------------------------------------------------------
 
329
    // Default values, types, generic parameters
 
330
    
 
331
    let generateDefaultValue (t:CodeTypeReference) = 
 
332
      if (t.ArrayElementType <> null) then
 
333
        id -- "Unchecked.defaultof<_>"
 
334
      else
 
335
        match t.BaseType with 
 
336
          | "System.Single" -> id -- "0.0f"
 
337
          | "System.Double" -> id -- "0.0"
 
338
          | "System.Char" -> id -- "'\000'"
 
339
          | "System.Int16" -> id -- "0s"
 
340
          | "System.Int32" -> id -- "0"
 
341
          | "System.Int64" -> id -- "0L"
 
342
          | "System.Byte" -> id -- "0uy"
 
343
          | "System.SByte" -> id -- "0y"
 
344
          | "System.UInt16" -> id -- "0us"
 
345
          | "System.UInt32" -> id -- "0u"
 
346
          | "System.UInt64" -> id -- "0UL"
 
347
          | "System.String" -> id -- "\"\""
 
348
          | "System.Boolean" -> id -- "false"
 
349
          | _ -> id -- "Unchecked.defaultof<_>" 
 
350
    
 
351
    /// Get System.Type of know type (either standard type or resolved)  
 
352
    let tryGetSystemType (cr:CodeTypeReference option) =
 
353
      match cr with 
 
354
        | None -> None
 
355
        | Some cr when (cr.ArrayRank = 0) ->
 
356
          match cr.BaseType with 
 
357
          | "System.Single" -> Some (typeof<float32>)
 
358
          | "System.Double" -> Some (typeof<float>)
 
359
          | "System.Char" -> Some (typeof<char>)
 
360
          | "System.Int16" -> Some (typeof<int16>)
 
361
          | "System.Int32" -> Some (typeof<int>)
 
362
          | "System.Int64" -> Some (typeof<int64>)
 
363
          | "System.UInt16" -> Some (typeof<uint16>)
 
364
          | "System.UInt32" -> Some (typeof<uint32>)
 
365
          | "System.UInt64" -> Some (typeof<uint64>)
 
366
          | "System.String" -> Some (typeof<string>)
 
367
          | "System.Boolean" -> Some (typeof<bool>)
 
368
          | FoundSystemType t -> Some t
 
369
          | _ -> None;      
 
370
        | _ -> None
 
371
 
 
372
    /// Tries to resolve type of a variable and adds it to the Context dictionary
 
373
    let tryAddVariableType (name:string) (cr:CodeTypeReference) (varTypes:Map<string,Type>) =
 
374
      let ret t = Map.add name t varTypes
 
375
      match tryGetSystemType (Some cr) with 
 
376
        | Some t -> ret t; 
 
377
        | _ -> varTypes
 
378
 
 
379
    // Returns string with type arguments
 
380
    let rec getTypeArgs (tya:CodeTypeReferenceCollection) renames ns tyParams fsSyntax =
 
381
      if (tya.Count > 0) then
 
382
        let sb = new StringBuilder()
 
383
        sb.Append("<") |> ignore
 
384
        for a in tya do
 
385
          let str = (getTypeRef a renames ns tyParams fsSyntax):string
 
386
          sb.Append(str).Append(", ") |> ignore
 
387
        let s = sb.ToString()
 
388
        s.Substring(0, s.Length - 2) + ">"
 
389
      else
 
390
        ""
 
391
        
 
392
        // Several standard renaming tricks      
 
393
              
 
394
    and isKnownSealedType (t:CodeTypeReference) = 
 
395
        t.ArrayRank = 0 &&
 
396
        match t.BaseType with 
 
397
        | "System.String" 
 
398
        | "System.Single" 
 
399
        | "System.Double" 
 
400
        | "System.DateTime" 
 
401
        | "System.TimeSpan" 
 
402
        | "System.Decimal" 
 
403
        | "System.Char" 
 
404
        | "System.SByte" 
 
405
        | "System.Byte" 
 
406
        | "System.Int16" 
 
407
        | "System.Int32" 
 
408
        | "System.Int64" 
 
409
        | "System.UInt16" 
 
410
        | "System.UInt32" 
 
411
        | "System.UInt64" 
 
412
        | "System.Boolean" -> true
 
413
        | _ -> false;
 
414
    /// Generates type reference (not for arrays)
 
415
    and getBaseTypeRef (cr:CodeTypeReference) renames (ns:string) (tyParams:Set<string>) fsSyntax =
 
416
      let s = 
 
417
      
 
418
        // Remove current namespace name, because it can't be used in this scope
 
419
        let bst = 
 
420
          if (cr.BaseType.StartsWith(ns+".")) then 
 
421
            cr.BaseType.Substring(ns.Length+1) 
 
422
          elif cr.Options &&& CodeTypeReferenceOptions.GlobalReference <> enum 0 then 
 
423
            "global."+cr.BaseType
 
424
          else 
 
425
            cr.BaseType
 
426
      
 
427
        // Several standard renaming tricks      
 
428
        match Map.tryFind bst renames with
 
429
          // Renamed type (former nested type)
 
430
          | Some nn -> nn
 
431
          
 
432
          // It is a type paramter - rename T to 'T
 
433
          | None when Set.contains cr.BaseType tyParams ->
 
434
              "'" + cr.BaseType
 
435
              
 
436
          // Try if it's standard F# type
 
437
          // This also renames Void to unit, which may not be completly correct, 
 
438
          // but it works much better than if we don't do it
 
439
          | None when fsSyntax ->
 
440
              match cr.BaseType with 
 
441
              | "System.Void" -> "unit"
 
442
              | "System.Object" -> "obj"
 
443
              | "System.String" -> "string"
 
444
              | "System.Single" -> "float32"
 
445
              | "System.Double" -> "float"
 
446
              | "System.Char" -> "char"
 
447
              | "System.Int16" -> "int16" 
 
448
              | "System.Int32" -> "int" 
 
449
              | "System.Int64" -> "int64" 
 
450
              | "System.UInt16" -> "uint16" 
 
451
              | "System.UInt32" -> "uint32" 
 
452
              | "System.UInt64" -> "uint64" 
 
453
              | "System.Boolean" -> "bool"
 
454
              | _ -> bst;
 
455
          | _ -> bst;          
 
456
      // drop `xyz, replace "+" for nested classes with "."
 
457
      let sb = new StringBuilder()
 
458
      let mutable i = 0 
 
459
      while i < s.Length do
 
460
        let c = s.[i]
 
461
        match c with
 
462
          | _ when c = '+' || c = '.' -> sb.Append('.') |> ignore;
 
463
          | '`' -> i <- i + 1;
 
464
                   while (i<s.Length && s.[i]>='0' && s.[i]<='9') do 
 
465
                     i <- i + 1
 
466
          | _ -> sb.Append(c) |> ignore
 
467
        i <- i + 1      
 
468
      // generate type arguments
 
469
      sb.Append(getTypeArgs cr.TypeArguments renames ns tyParams fsSyntax).ToString()
 
470
      
 
471
    /// Generate type reference with empty context
 
472
    and getBaseTypeRefString (s:string) =
 
473
      getBaseTypeRef (CodeTypeReference(s)) Map.empty "" Set.empty true
 
474
    
 
475
    
 
476
    /// Get full type reference using information from context  
 
477
    and getTypeRef (c:CodeTypeReference) (rens:Map<string,string>) (ns:string) (tyParams:Set<string>) (fsSyntax:bool) =
 
478
      if (c = null) then  
 
479
        ""
 
480
      elif (c.ArrayRank = 0) then 
 
481
        getBaseTypeRef c rens ns tyParams fsSyntax
 
482
      else      
 
483
        let baseType = (getTypeRef c.ArrayElementType rens ns tyParams fsSyntax)
 
484
        baseType + "[" + (System.String.Concat (Array.create (c.ArrayRank - 1) ",")) + "]"
 
485
 
 
486
    /// Get full type reference string using empty context
 
487
    and getTypeRefSimple (c:CodeTypeReference) = getTypeRef c Map.empty "" Set.empty true
 
488
    
 
489
    /// Get type reference, but don't rename .NET types to F# types
 
490
    /// (this is only needed when calling static methods on the type)
 
491
    let generateTypeRefNet (c:CodeTypeReference) =
 
492
      id +> withCtxt ( fun ctx -> id -- getTypeRef c ctx.TypeRenames ctx.CurrentNamespace ctx.TypeArgumentNames false )
 
493
    
 
494
    /// Generate type reference using context
 
495
    /// (this is most commonly used method)  
 
496
    let generateTypeRef (c:CodeTypeReference) =
 
497
      id +> withCtxt ( fun ctx -> id -- getTypeRef c ctx.TypeRenames ctx.CurrentNamespace ctx.TypeArgumentNames true )
 
498
             
 
499
    /// Generate type arguments using context
 
500
    let generateTypeArgs (c:CodeTypeReferenceCollection) =
 
501
      id +> withCtxt ( fun ctx -> id -- getTypeArgs c ctx.TypeRenames ctx.CurrentNamespace ctx.TypeArgumentNames true )
 
502
             
 
503
    
 
504
    /// Record specified type parameters in the context, call generating function
 
505
    /// and then restore the original type parameters
 
506
    /// (this works if someone uses nested type parameters with the same name)
 
507
    let usingTyParams tyArgs f (x:Context) =
 
508
      let o = x.TypeArgumentNames
 
509
      let n = Array.foldBack Set.add (Array.ofSeq tyArgs) o
 
510
      let x = f { x with TypeArgumentNames = n }
 
511
      { x with TypeArgumentNames = o }      
 
512
 
 
513
 
 
514
    /// Preprocess collection with type parameters
 
515
    /// Returns array to be used with <c>usingTyParams</c> and
 
516
    /// function to be called to generate < ... > code
 
517
    let processTypeArgs (args:CodeTypeParameterCollection) =     
 
518
      let tyargs = seq { for (p:CodeTypeParameter) in args -> p.Name }       
 
519
      let genTyArgs =
 
520
        if (args.Count = 0) then id else
 
521
        let s = tyargs |> Seq.fold (fun ctx s -> ctx + ", '" + s) ""
 
522
        id 
 
523
        -- "<" -- s.Substring(2, s.Length-2)
 
524
        +> if (args.Count = 0) then id -- ">" else
 
525
             let argsWithConstr = args |> Seq.cast |> Seq.filter (fun (p:CodeTypeParameter) -> 
 
526
               p.Constraints.Count <> 0 || p.HasConstructorConstraint) |> Seq.cast |> Seq.toList
 
527
             if (argsWithConstr.Length <> 0) then
 
528
               id -- " when " +>
 
529
               col sepWordAnd argsWithConstr (fun (p:CodeTypeParameter) -> 
 
530
                 col sepWordAnd p.Constraints (fun impl ->
 
531
                   id -- "'" -- p.Name -- " :> " +> generateTypeRef impl)
 
532
                 +> if (not p.HasConstructorConstraint) then id else
 
533
                      if (p.Constraints.Count <> 0) then id -- " and " else id
 
534
                      -- "'" -- p.Name -- " : (new:unit->'" -- p.Name -- ")")
 
535
               -- ">"
 
536
             else id -- ">"
 
537
      tyargs, genTyArgs
 
538
    
 
539
    //---------------------------------------------------------------------------------------------
 
540
    // Binary operators and numeric functions
 
541
    
 
542
    /// Generates code for binary operator using function for left and right operand
 
543
    let binaryOp (op:CodeBinaryOperatorType) fleft fright =
 
544
      id -- "(" +>
 
545
      match op with    
 
546
        | CodeBinaryOperatorType.Add -> fleft -- " + " +> fright;
 
547
        | CodeBinaryOperatorType.BitwiseAnd -> fleft -- " &&& " +> fright;
 
548
        | CodeBinaryOperatorType.BitwiseOr -> fleft -- " ||| " +> fright;
 
549
        | CodeBinaryOperatorType.BooleanAnd -> fleft -- " && " +> fright;
 
550
        | CodeBinaryOperatorType.BooleanOr -> fleft -- " || " +> fright;
 
551
        | CodeBinaryOperatorType.Divide -> fleft -- " / " +> fright;
 
552
        | CodeBinaryOperatorType.GreaterThan -> fleft -- " > " +> fright;
 
553
        | CodeBinaryOperatorType.GreaterThanOrEqual -> fleft -- " >= " +> fright;
 
554
        | CodeBinaryOperatorType.LessThan -> fleft -- " < " +> fright;
 
555
        | CodeBinaryOperatorType.LessThanOrEqual -> fleft -- " <= " +> fright;
 
556
        | CodeBinaryOperatorType.Modulus -> fleft -- " % " +> fright;
 
557
        | CodeBinaryOperatorType.Multiply -> fleft -- " * " +> fright;
 
558
        | CodeBinaryOperatorType.Subtract -> fleft -- " - " +> fright;
 
559
        
 
560
        // REVIEW: this is not used in any tests and it is not sure what it means
 
561
        | CodeBinaryOperatorType.Assign -> fleft -- " <- " +> fright; 
 
562
        
 
563
        // REVIEW: reference and value equality use C# semantics, so it is not sure what we should generate
 
564
        | CodeBinaryOperatorType.ValueEquality -> fleft -- " = " +> fright;  
 
565
        | CodeBinaryOperatorType.IdentityEquality -> id -- "System.Object.ReferenceEquals(" +> fleft -- ", " +> fright -- ")"; 
 
566
        | CodeBinaryOperatorType.IdentityInequality -> id -- "not (System.Object.ReferenceEquals(" +> fleft -- ", " +> fright -- "))"; 
 
567
        | _ -> failwithf "unimplemented binary operator type '%A'" op;
 
568
      -- ")"
 
569
    
 
570
    /// Are both types numerical types where numeric conversion function can be applied?
 
571
    let rec isNumericConversion (src:Type) (target:Type) = 
 
572
      convertFunc src <> "" && convertFunc target <> ""
 
573
    
 
574
    
 
575
    /// Returns F# conversion function for the specified type (or empty string)
 
576
    and convertFunc (ty:Type) = 
 
577
      if (ty = (typeof<int16>)) then "int16"
 
578
      elif (ty = (typeof<int32>)) then "int32"
 
579
      elif (ty = (typeof<int64>)) then "int64"
 
580
      elif (ty = (typeof<int16>)) then "uint16"
 
581
      elif (ty = (typeof<int32>)) then "uint32"
 
582
      elif (ty = (typeof<int64>)) then "uint64"
 
583
      elif (ty = (typeof<float>)) then "float"
 
584
      elif (ty = (typeof<float32>)) then "float32"
 
585
      elif (ty = (typeof<decimal>)) then "decimal"
 
586
      elif (ty = (typeof<byte>)) then "byte"
 
587
      elif (ty = (typeof<sbyte>)) then "sbyte"
 
588
      else ""
 
589
    
 
590
    
 
591
    /// Generate value of primitive expression  
 
592
    let generatePrimitiveExpr (reqty:Type option) (c:CodePrimitiveExpression) =
 
593
      let (value, typ) = 
 
594
        match c.Value with
 
595
          | :? Char as c -> (sprintf "%A" c, Some(typeof<Char>))
 
596
          | :? String as s -> (sprintf "\"%s\"" (s.Replace("\\", "\\\\").Replace("\"", "\\\"").Replace("\n", "\\n").Replace("\t", "\\t").Replace("\r", "\\r").Replace("\b", "\\b")), Some(typeof<string>)) 
 
597
          | :? Boolean as b -> ((if (b) then "true" else "false"), Some(typeof<bool>))
 
598
          | :? Single as f -> (sprintf "%A" f, Some(typeof<float32>))
 
599
          | :? Double as f -> (sprintf "%A" f, Some(typeof<float>))
 
600
          | :? Byte as i -> (sprintf "%A" i, Some(typeof<Byte>))
 
601
          | :? SByte as i -> (sprintf "%A" i, Some(typeof<SByte>))
 
602
          | :? Int16 as i -> (sprintf "%A" i, Some(typeof<int16>))
 
603
          | :? Int32 as i -> (sprintf "%A" i, Some(typeof<int>))
 
604
          | :? Int64 as i -> (sprintf "%A" i, Some(typeof<int64>))
 
605
          | :? UInt16 as i -> (sprintf "%A" i, Some(typeof<uint16>))
 
606
          | :? UInt32 as i -> (sprintf "%A" i, Some(typeof<uint32>))
 
607
          | :? UInt64 as i -> (sprintf "%A" i, Some(typeof<uint64>))
 
608
          | null -> ("(Unchecked.defaultof<_>)", None)
 
609
          | _ -> ("(* Unknown primitive value '"+c.Value.ToString()+"' of type '"+
 
610
                  c.Value.GetType().Name+"'. Please report this to the F# team. *)", None) 
 
611
      match typ, reqty with        
 
612
        | Some t, Some rt when t <> rt -> id -- convertFunc rt -- " (" -- value -- ")"
 
613
        | _, _ ->  id -- value
 
614
        
 
615
        
 
616
    /// Generate array initializer. Checks generator options for ASP.NET workaround.
 
617
    let rec generateArrayCreateExpr (c:CodeArrayCreateExpression) =
 
618
      if (c.Initializers<>null && c.Initializers.Count>0) then
 
619
        id
 
620
        -- "([| " +> col sepArgsSemi c.Initializers generateExpression -- " |] : "
 
621
        +> withCtxt (fun ctx -> 
 
622
            generateTypeRef c.CreateType          
 
623
            -- if (ctx.Options &&& AdditionalOptions.AspNetArrays <> enum 0) then "[]" else "")
 
624
        -- ")" 
 
625
      else
 
626
        id
 
627
        -- "(Array.zeroCreate "
 
628
        +> if (c.SizeExpression <> null) then
 
629
              id -- "(" +> generateExpression c.SizeExpression -- ")"
 
630
           else
 
631
              id +> str c.Size
 
632
        -- ":"
 
633
        +> withCtxt (fun ctx -> 
 
634
            generateTypeRef c.CreateType          
 
635
            -- if (ctx.Options &&& AdditionalOptions.AspNetArrays <> enum 0) then "[]" else "")
 
636
        -- ")";
 
637
    
 
638
    /// Tries to resolve if type is an array, so we can generate 
 
639
    /// appropriate code (it can be either indexer or array, but we need to generate
 
640
    /// .Item call for indexers (no overloading is supported by .[]).
 
641
    /// Returns: "None" - can't resolve, "Some" resovled (true/false - is it an array?)
 
642
    and tryIsExpressionArray c (ctx:Context) = 
 
643
      match (c :> CodeExpression) with
 
644
        | :? CodeFieldReferenceExpression as ce when 
 
645
             (ce.TargetObject :? CodeThisReferenceExpression) -> 
 
646
             match Map.tryFind ce.FieldName ctx.FieldTypes with 
 
647
               | Some t -> Some (t.ArrayRank > 0)
 
648
               | None -> None
 
649
        | :? CodePropertyReferenceExpression as ce when 
 
650
             (ce.TargetObject :? CodeThisReferenceExpression) -> 
 
651
             match Map.tryFind ce.PropertyName ctx.PropertyTypes with 
 
652
               | Some t -> Some (t.ArrayRank > 0)
 
653
               | None -> None
 
654
        | _ -> None    
 
655
    
 
656
    
 
657
    /// Tries to resolve type of an expression using a few tricks:
 
658
    /// * Fields of current type may have known type
 
659
    /// * Properties of current type as well
 
660
    /// * We can also try to resolve other properties (sometimes it helps)
 
661
    /// * Resolve type for local variables or argument reference 
 
662
    and tryGetExpressionType c (ctx:Context) = 
 
663
      match (c :> CodeExpression) with
 
664
        | :? CodeFieldReferenceExpression as ce when 
 
665
             (ce.TargetObject :? CodeThisReferenceExpression) -> 
 
666
             tryGetSystemType (Map.tryFind ce.FieldName ctx.FieldTypes)
 
667
        | :? CodePropertyReferenceExpression as ce when 
 
668
             (ce.TargetObject :? CodeThisReferenceExpression) -> 
 
669
             tryGetSystemType (Map.tryFind ce.PropertyName ctx.PropertyTypes)
 
670
        | :? CodePropertyReferenceExpression as ce ->
 
671
               match (tryGetExpressionType ce.TargetObject ctx) with
 
672
                 | None -> None
 
673
                 | Some t ->
 
674
                     try 
 
675
                       Some (t.GetProperty(ce.PropertyName).PropertyType)
 
676
                     with _ ->
 
677
                       None
 
678
        | :? CodeArgumentReferenceExpression as ce ->                              
 
679
               Map.tryFind ce.ParameterName ctx.LocalVariableTypes  
 
680
               // NOTE:
 
681
               // XSD generates incorrect referenece (uses argument ref where it should be variable ref)
 
682
               // and unfortunately it is followed by wrong numeric type, so we need to workaround this
 
683
        | :? CodeVariableReferenceExpression as ce ->
 
684
               Map.tryFind ce.VariableName ctx.LocalVariableTypes 
 
685
        | _ -> None
 
686
      
 
687
    //---------------------------------------------------------------------------------------------
 
688
    // Generating code for expressions
 
689
          
 
690
    /// Generates a "this" or "CurrentType" reference depending on whether a reference
 
691
    /// is static or not. Used for "ambiguous" references without a type or object qualifier.
 
692
    ///
 
693
    /// Unfortunately the Code tree isn't so kind as to tell us whether a reference is static
 
694
    /// or not up front. Instead we predetermine a set of some static members and 
 
695
    /// assume all other references are instance references. 
 
696
    ///
 
697
    and generateExpressionDefaultThis isKnownStatic c = 
 
698
      withCtxt (fun ctx -> 
 
699
          match c with 
 
700
          | null -> 
 
701
              // REVIEW: this is still incorrect if the reference is static and it is a reference from an inherited type
 
702
              id -- (if isKnownStatic then ctx.CurrentType.Name else "this" )  
 
703
          | _ -> generateExpression c)
 
704
        
 
705
    /// Matches array or indexer expression and corrects it if the generated CodeDOM is incorrect
 
706
    and (|CodeArrayAccessOrIndexer|_|) (ctx:Context) (c:CodeExpression) =
 
707
      let noneT b = match b with Some v -> v | _ -> true
 
708
      let noneF b = match b with Some v -> v | _ -> false
 
709
      match c with 
 
710
        | :? CodeArrayIndexerExpression as ce -> 
 
711
             Some(true && (noneT (tryIsExpressionArray ce.TargetObject ctx)), ce.TargetObject, ce.Indices)
 
712
        | :? CodeIndexerExpression as ce -> 
 
713
             Some(false || (noneF (tryIsExpressionArray ce.TargetObject ctx)), ce.TargetObject, ce.Indices)
 
714
        | _ -> None
 
715
      
 
716
    /// Generate expression - with unkonw type
 
717
    and generateExpression c = generateExpressionTyped None c    
 
718
 
 
719
    // Generates code for CodeExpression
 
720
    // If the caller knows the expected type of the expression it can be given as an argument,
 
721
    // but currently it is used only when generating primitve expression to convert value to the right type
 
722
    and generateExpressionTyped ty c ctx = 
 
723
      (match c with 
 
724
        | :? CodeArgumentReferenceExpression as ce ->
 
725
              id -! ce.ParameterName
 
726
        | :? CodeArrayCreateExpression as ce ->
 
727
              id +> generateArrayCreateExpr ce              
 
728
        
 
729
        // for indexers we generate get_Item to handle overloading
 
730
        | CodeArrayAccessOrIndexer ctx (isArray, target, indices) ->
 
731
              id
 
732
              +> generateExpression target -- "."
 
733
              +> id -- "[" +> col sepArgs indices generateExpression -- "]" 
 
734
              
 
735
        | :? CodeBaseReferenceExpression as ce ->
 
736
              id -- "base"
 
737
              
 
738
        | :? CodeBinaryOperatorExpression as ce ->
 
739
              binaryOp ce.Operator (generateExpressionTyped ty ce.Left) (generateExpressionTyped ty ce.Right)
 
740
        
 
741
        // casting can also represent numeric conversion - we try to detect that case      
 
742
        | :? CodeCastExpression as ce -> 
 
743
              id 
 
744
              +> withCtxt (fun ctx -> 
 
745
                  match tryGetExpressionType (ce.Expression) ctx, tryGetSystemType (Some ce.TargetType) with
 
746
                  | Some(t1), Some(t2) when isNumericConversion t1 t2 ->
 
747
                      id
 
748
                      -- "(" -- (convertFunc t2)
 
749
                      -- "(" +> generateExpression ce.Expression -- "))"
 
750
                  | _ ->
 
751
                    id
 
752
                    -- "((" +> generateExpression ce.Expression -- " :> obj) :?> " +> generateTypeRef ce.TargetType -- ")" )
 
753
        
 
754
        // argument for "ref" or "out" C# parameter - both generated as byref in F#
 
755
        | :? CodeDirectionExpression as ce ->
 
756
              match ce.Direction with 
 
757
              | FieldDirection.Out 
 
758
              | FieldDirection.Ref -> 
 
759
                  id -- "&" +> generateExpression ce.Expression
 
760
              | _ -> 
 
761
                  id +> generateExpression ce.Expression
 
762
        
 
763
        // for delegates, we use 'FuncFromTupled' to get the right function type      
 
764
        | :? CodeDelegateCreateExpression as ce ->
 
765
              id 
 
766
              -- "new " +> generateTypeRef ce.DelegateType -- "(FuncConvert.FuncFromTupled " 
 
767
              +> generateExpression ce.TargetObject 
 
768
              -- "." -- ce.MethodName -- ")";
 
769
        
 
770
        | :? CodeDelegateInvokeExpression as ce ->
 
771
              id
 
772
              +> match ce.TargetObject with 
 
773
                  // "this.<DeclaredEventName>( ... )" - will be translated to a raise function returned
 
774
                  // by create_DelegateEvent
 
775
                  | :? CodeEventReferenceExpression as eref when  
 
776
                      (eref.TargetObject :? CodeThisReferenceExpression) 
 
777
                      && ((ctx.DeclaredEvents |> List.tryFind (fun e -> e.Name = eref.EventName)) <> None) -> 
 
778
                      // F# declared event..
 
779
                      id
 
780
                      -- "this._invoke_" -- eref.EventName -- " [| "
 
781
                      +> col sepArgsSemi ce.Parameters (fun (e:CodeExpression) ->
 
782
                           id
 
783
                           -- " box (" 
 
784
                           +> generateExpression e
 
785
                           -- ")" ) -- " |]"
 
786
                  // other than this.<Event>(). This may not be correct (but works on cases in test suite)
 
787
                  | _ -> 
 
788
                      generateExpression ce.TargetObject 
 
789
                      -- ".Invoke(" +> col sepArgs ce.Parameters generateExpression -- ")"
 
790
        
 
791
        // this prevents using mutable variable in a way it would escape its scope
 
792
        | :? CodeEventReferenceExpression as ce ->
 
793
              id -- "let __e = " +> generateExpression ce.TargetObject -- " in __e." -- ce.EventName
 
794
                          
 
795
        | :? CodeFieldReferenceExpression as ce -> 
 
796
              withCtxt (fun ctx ->  
 
797
              
 
798
                // if 'UnknownFieldsAsLocals' is set than the code will generate
 
799
                // "fld" instead of "this.fld" when accessing field that is not known
 
800
                let sft =
 
801
                  match ce.TargetObject with
 
802
                  | :? CodeThisReferenceExpression as t when 
 
803
                       (ctx.Options &&& AdditionalOptions.UnknonwFieldsAsLocals <> enum 0) ->
 
804
                       Option.isNone (Map.tryFind ce.FieldName ctx.FieldTypes)
 
805
                  | _ -> false
 
806
                if sft then
 
807
                  id -! ce.FieldName
 
808
                else
 
809
                  id 
 
810
                  +> match ce.TargetObject with 
 
811
                       | :? CodeTypeReferenceExpression as ct ->
 
812
                             id +> generateTypeRefNet ct.Type
 
813
                       | _ -> 
 
814
                           let isKnownStatic = 
 
815
                               match ce.TargetObject, ctx.AllFields.TryFind ce.FieldName with 
 
816
                               | null, Some m -> 
 
817
                                  (m.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Static) 
 
818
                               | _ -> false
 
819
                           generateExpressionDefaultThis isKnownStatic ce.TargetObject
 
820
                 -- "." -- ce.FieldName )
 
821
              
 
822
        | :? CodeMethodInvokeExpression as ce ->
 
823
              id 
 
824
              +> generateExpression (ce.Method :> CodeExpression) 
 
825
              -- "(" +> col sepArgs ce.Parameters generateExpression -- ")" 
 
826
              
 
827
        | :? CodeMethodReferenceExpression as ce ->
 
828
              id 
 
829
              +> match ce.TargetObject with 
 
830
                   | :? CodeTypeReferenceExpression as ct ->
 
831
                         id +> generateTypeRefNet ct.Type
 
832
                   | _ -> 
 
833
                       let isKnownStatic = 
 
834
                           match ce.TargetObject, ctx.AllMeths.TryFind ce.MethodName with 
 
835
                           | null, Some m -> 
 
836
                              (m.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Static) 
 
837
                           | _ -> false
 
838
                       generateExpressionDefaultThis isKnownStatic ce.TargetObject
 
839
              -- "." -- ce.MethodName 
 
840
              +> generateTypeArgs ce.TypeArguments
 
841
              
 
842
        | :? CodeObjectCreateExpression as ce ->
 
843
              id
 
844
              -- "new " +> generateTypeRef ce.CreateType 
 
845
              -- "(" +> col sepArgs ce.Parameters generateExpression -- ")" 
 
846
              
 
847
        | :? CodePrimitiveExpression as ce -> 
 
848
              id +> generatePrimitiveExpr ty ce 
 
849
              
 
850
        | :? CodePropertyReferenceExpression as ce ->
 
851
              id 
 
852
              +> match ce.TargetObject with 
 
853
                   | :? CodeTypeReferenceExpression as ct ->
 
854
                         id +> generateTypeRefNet ct.Type
 
855
                   | _ -> 
 
856
                       let isKnownStatic = 
 
857
                           match ce.TargetObject, ctx.AllProps.TryFind ce.PropertyName with 
 
858
                           | null, Some m -> 
 
859
                              (m.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Static) 
 
860
                           | _ -> false
 
861
                       generateExpressionDefaultThis isKnownStatic ce.TargetObject
 
862
              -- "." -- ce.PropertyName 
 
863
              
 
864
        | :? CodePropertySetValueReferenceExpression as ce ->  
 
865
              id -- "value"
 
866
              
 
867
        // we move all lines of "snippets" by 100 columns so it isn't violating #light rules
 
868
        | :? CodeSnippetExpression as ce ->
 
869
              let strs = 
 
870
                ce.Value.Split([| '\r'; '\n' |], StringSplitOptions.RemoveEmptyEntries)
 
871
                |> Array.map (fun s -> String(' ',100) + s )
 
872
              colT sepNone strs (fun s -> id ++ s)
 
873
 
 
874
        | :? CodeThisReferenceExpression as ce ->  
 
875
              id -- "this"
 
876
              
 
877
        | :? CodeTypeOfExpression as ce ->  
 
878
              id -- "(typeof<" +> generateTypeRef ce.Type -- ">)"
 
879
              
 
880
        | :? CodeTypeReferenceExpression as ce ->  
 
881
              id +> generateTypeRef ce.Type 
 
882
              
 
883
        | :? CodeVariableReferenceExpression as ce ->            
 
884
              match ty with 
 
885
              | Some t when (convertFunc t) <> "" -> id -- "(" -- (convertFunc t) -- " " -! ce.VariableName -- ")"
 
886
              | _ -> id -! ce.VariableName
 
887
              
 
888
        | null ->
 
889
            id 
 
890
            
 
891
        | _ -> id 
 
892
               -- "(* Unknown expression type '" -- (c.GetType().Name) 
 
893
               -- "' please report this to the F# team. *)") ctx
 
894
    
 
895
    //---------------------------------------------------------------------------------------------
 
896
    // Generating code for statements
 
897
      
 
898
    and generateVariableDeclStmt (c:CodeVariableDeclarationStatement) =
 
899
      id
 
900
      +> (fun ctx -> { ctx with LocalVariableTypes = tryAddVariableType c.Name c.Type ctx.LocalVariableTypes } )
 
901
      ++ "let mutable (" -! c.Name -- ":" +> generateTypeRef c.Type -- ") = "
 
902
      +> if (c.InitExpression <> null) then 
 
903
           (generateExpressionTyped (tryGetSystemType (Some c.Type))) c.InitExpression 
 
904
         else 
 
905
           (generateDefaultValue c.Type);
 
906
    
 
907
    // REVIEW: Line pragmas don't work with the #light syntax
 
908
    let generateLinePragma (l:CodeLinePragma) = 
 
909
      if (l = null) then id else
 
910
        id 
 
911
        ++ "# " +> str l.LineNumber -- " \"" -- l.FileName -- "\""
 
912
        
 
913
    let rec generateCatchClause (c:CodeCatchClause) =
 
914
      id
 
915
      ++ "| :? " +> generateTypeRef c.CatchExceptionType 
 
916
      -- " as " -- c.LocalName -- " ->" +> incIndent
 
917
      +> generateStatements c.Statements +> decIndent
 
918
 
 
919
    and generateStatements (sts:CodeStatementCollection) = 
 
920
      let fix = 
 
921
        if (sts.Count = 0 || (sts.[sts.Count - 1] :? CodeVariableDeclarationStatement))
 
922
          then id ++ "()" else id
 
923
      col sepNone sts generateStatement +> fix      
 
924
 
 
925
    // Generates block of statements which can return a value
 
926
    and generateStatementBlock typ (statements:CodeStatementCollection) =        
 
927
      // determine if the block uses only "safe" return statements
 
928
      // that can be translated to functional returns without using exceptions
 
929
      let safeReturns = 
 
930
        statements 
 
931
        |> codeDomCallbackWithScope (fun rcall safeScope res o -> 
 
932
            match o with 
 
933
            | :? CodeMethodReturnStatement as ret -> safeScope && res
 
934
            | :? CodeTryCatchFinallyStatement as tfs -> rcall (safeScope && (tfs.CatchClauses.Count = 0)) res o
 
935
            | :? CodeStatementCollection -> rcall safeScope res o
 
936
            | _ -> rcall false res o ) true true
 
937
    
 
938
      id
 
939
      +> incIndent
 
940
      +> (fun ctx -> { ctx with CurrentMethodReturnType=typ; 
 
941
                                LocalVariableTypes = Map.empty; 
 
942
                                ReturnUsingException = not safeReturns })
 
943
      // if returning using exception - wrap inside try .. catch
 
944
      +> if (not safeReturns) then id ++ "try" +> incIndent else id
 
945
      +> generateStatements statements
 
946
      +> if (safeReturns) then id else
 
947
           match typ with 
 
948
           | Some t when t.BaseType <> "System.Void" -> 
 
949
               id ++ "failwith \"Code branch didn't return any value!\";"
 
950
               +> decIndent
 
951
               ++ "with" ++ "    | ReturnException" +> uniqid -- " v -> (v :?> " +> generateTypeRef t -- ")"
 
952
           | _ ->  
 
953
               id ++ "raise ReturnNoneException" +> uniqid 
 
954
               +> decIndent
 
955
               ++ "with" ++ "    | ReturnNoneException" +> uniqid -- " -> ()"
 
956
      +> (fun ctx -> {ctx with CurrentMethodReturnType=None; 
 
957
                               LocalVariableTypes = Map.empty; 
 
958
                               ReturnUsingException = false })
 
959
      +> decIndent
 
960
 
 
961
    and generateComment (c:CodeComment) =
 
962
      id 
 
963
      -- if c.DocComment then "/// " else "// " 
 
964
      -- (c.Text);
 
965
 
 
966
    and generateExpressionThenUpCast e (t: CodeTypeReference) = 
 
967
        if isKnownSealedType t then 
 
968
            generateExpression e
 
969
        else
 
970
            id -- "((" +> generateExpression e -- " :> obj) :?> " +> generateTypeRef t -- ")" 
 
971
          
 
972
    and generateStatement (c:CodeStatement) = 
 
973
      (generateLinePragma c.LinePragma) +>
 
974
      (match c with 
 
975
        | :? CodeAssignStatement as cs -> 
 
976
              match cs.Left with 
 
977
                | :? CodeIndexerExpression as ci ->
 
978
                    id ++ "" 
 
979
                    +> generateExpressionDefaultThis false ci.TargetObject -- ".set_Item(" 
 
980
                    +> col sepArgs ci.Indices generateExpression -- ", "
 
981
                    +> withCtxt (fun ctx -> generateExpressionTyped (tryGetExpressionType cs.Left ctx) cs.Right)
 
982
                    -- ")"
 
983
                | _ ->
 
984
                    id ++ "" +> generateExpression cs.Left 
 
985
                    -- " <- " 
 
986
                    +> withCtxt (fun ctx -> generateExpressionTyped (tryGetExpressionType cs.Left ctx) cs.Right)
 
987
                    
 
988
        | :? CodeAttachEventStatement as cs ->
 
989
              id ++ "" +> generateExpression (cs.Event :> CodeExpression) 
 
990
              -- ".AddHandler(" +> generateExpression cs.Listener -- ")"
 
991
              
 
992
        | :? CodeCommentStatement as cs -> 
 
993
              id ++ "" +> generateComment cs.Comment 
 
994
              
 
995
        | :? CodeConditionStatement as cs ->
 
996
              id 
 
997
              ++ "if " +> generateExpression cs.Condition -- " then"
 
998
              +> incIndent +> col sepNone cs.TrueStatements generateStatement +> decIndent
 
999
              +> if (cs.FalseStatements<>null && cs.FalseStatements.Count>0) then 
 
1000
                   id 
 
1001
                   ++ "else" +> incIndent 
 
1002
                   +> col sepNone cs.FalseStatements generateStatement +> decIndent else id                
 
1003
                   
 
1004
        | :? CodeExpressionStatement as cs -> 
 
1005
              id ++ "" +> generateExpression cs.Expression -- " |> ignore";
 
1006
              
 
1007
        | :? CodeIterationStatement as cs ->
 
1008
              id 
 
1009
              +> generateStatement cs.InitStatement
 
1010
              ++ "while " +> generateExpression cs.TestExpression -- " do"
 
1011
              +> incIndent
 
1012
              +> col sepNone cs.Statements generateStatement 
 
1013
              +> generateStatement cs.IncrementStatement
 
1014
              +> decIndent
 
1015
              
 
1016
        // Return - either throw "ReturnException" or just generate F# expression with the value
 
1017
        | :? CodeMethodReturnStatement as cs -> 
 
1018
              id
 
1019
              +> withCtxt (fun ctx -> 
 
1020
                   if (ctx.ReturnUsingException) then
 
1021
                       id 
 
1022
                       ++ "raise ("
 
1023
                       +> match ctx.CurrentMethodReturnType with
 
1024
                          | Some t when t.BaseType <> "System.Void" -> 
 
1025
                              id -- "ReturnException" +> uniqid -- "(" +> generateExpressionThenUpCast cs.Expression t -- ")"
 
1026
                          | _ -> 
 
1027
                              id -- "ReturnNoneException" +> uniqid
 
1028
                       -- ")"
 
1029
                   else 
 
1030
                       match ctx.CurrentMethodReturnType with
 
1031
                       | Some t when t.BaseType <> "System.Void" -> 
 
1032
                           id 
 
1033
                           ++ "" +> generateExpressionThenUpCast cs.Expression t
 
1034
                       | _ ->      id ++ "")
 
1035
                     
 
1036
        | :? CodeSnippetStatement as cs ->
 
1037
              let strs = cs.Value.Split([| '\r'; '\n' |], StringSplitOptions.RemoveEmptyEntries);
 
1038
              colT sepNone strs (fun s -> id ++ s)
 
1039
              
 
1040
        | :? CodeVariableDeclarationStatement as cs -> 
 
1041
              id +> generateVariableDeclStmt cs
 
1042
              
 
1043
        | :? CodeThrowExceptionStatement as cs ->            
 
1044
              id ++ "raise (" +> generateExpression cs.ToThrow -- ")"
 
1045
        
 
1046
        // try .. catch .. finaly is generated as try (try .. catch) finally      
 
1047
        | :? CodeTryCatchFinallyStatement as cs -> 
 
1048
              let hasCatch = (cs.CatchClauses<>null && cs.CatchClauses.Count>0) 
 
1049
              let hasFinally = (cs.FinallyStatements<>null && cs.FinallyStatements.Count>0) 
 
1050
              id 
 
1051
              ++ "try" +> incIndent
 
1052
              +> if (hasCatch && hasFinally) then id ++ "try" +> incIndent else id
 
1053
              +> generateStatements cs.TryStatements 
 
1054
              +> if (cs.CatchClauses<>null && cs.CatchClauses.Count>0) then 
 
1055
                   decIndent 
 
1056
                   ++ "with" +> incIndent 
 
1057
                   +> col sepNone cs.CatchClauses generateCatchClause
 
1058
                   +> decIndent else id;
 
1059
              +> if (cs.FinallyStatements<>null && cs.FinallyStatements.Count>0) then 
 
1060
                   decIndent
 
1061
                   ++ "finally" +> incIndent 
 
1062
                   +> col sepNone cs.FinallyStatements generateStatement
 
1063
                   +> decIndent else id;
 
1064
                   
 
1065
        | _ -> id 
 
1066
               -- "(* Unknown statement type '" -- (c.GetType().Name) 
 
1067
               -- "' please report this to the F# team. *)")
 
1068
 
 
1069
    //---------------------------------------------------------------------------------------------
 
1070
    // Support for class members (Custom attributes, paramters, etc..)
 
1071
        
 
1072
    let generateAttributeArg (c:CodeAttributeArgument) =
 
1073
      id
 
1074
      +> if (c.Name<> null && c.Name.Length>0) then 
 
1075
          id -- c.Name -- "=" else id
 
1076
      +> generateExpression c.Value;
 
1077
      
 
1078
    let generateCustomAttrDecl (c:CodeAttributeDeclaration) =
 
1079
      id
 
1080
      -- (getBaseTypeRefString c.Name)
 
1081
      +> if (c.Arguments.Count = 0) then id else
 
1082
           id -- "(" +> (col sepArgs c.Arguments generateAttributeArg) -- ")" 
 
1083
          
 
1084
    let generateCustomAttrDeclsList (c:CodeAttributeDeclaration list) =
 
1085
      if (c.Length = 0) then 
 
1086
          id 
 
1087
      else 
 
1088
          id ++ "[<" +> (colT sepNlnSemiSpace c generateCustomAttrDecl) -- ">]"
 
1089
          
 
1090
    let generateCustomAttrDeclsForType (c:Choice<CodeAttributeDeclaration,string> list) (a:Reflection.TypeAttributes) =
 
1091
      id 
 
1092
      +> if (c.Length = 0)
 
1093
            && (a &&& TypeAttributes.Abstract  = enum 0)
 
1094
            && (a &&& TypeAttributes.Sealed  = enum 0) then id 
 
1095
         else 
 
1096
           id ++ "[<" 
 
1097
                 +> (colT sepNlnSemiSpace [ for x in c do 
 
1098
                                                match x with 
 
1099
                                                | Choice1Of2 a -> yield generateCustomAttrDecl a
 
1100
                                                | Choice2Of2 s -> yield (id -- s)
 
1101
                                            if a &&& TypeAttributes.Abstract <> enum 0 then yield (id -- "AbstractClass" +> sepNlnSemiSpace)
 
1102
                                            if a &&& TypeAttributes.Sealed   <> enum 0 then yield (id -- "Sealed" +> sepNlnSemiSpace) ]
 
1103
                                          (fun c -> c) )                                           
 
1104
              -- ">]"
 
1105
          
 
1106
(*
 
1107
VisibilityMask Specifies type visibility information. 
 
1108
 NotPublic Specifies that the class is not public. 
 
1109
 Public Specifies that the class is public. 
 
1110
 NestedPublic Specifies that the class is nested with public visibility. 
 
1111
 NestedPrivate Specifies that the class is nested with private visibility. 
 
1112
 NestedFamily Specifies that the class is nested with family visibility, and is thus accessible only by methods within its own type and any subtypes. 
 
1113
 NestedAssembly Specifies that the class is nested with assembly visibility, and is thus accessible only by methods within its assembly. 
 
1114
 NestedFamANDAssem Specifies that the class is nested with assembly and family visibility, and is thus accessible only by methods lying in the intersection of its family and assembly. 
 
1115
 NestedFamORAssem Specifies that the class is nested with family or assembly visibility, and is thus accessible only by methods lying in the union of its family and assembly. 
 
1116
 LayoutMask Specifies class layout information. 
 
1117
 AutoLayout Specifies that class fields are automatically laid out by the common language runtime. 
 
1118
 SequentialLayout Specifies that class fields are laid out sequentially, in the order that the fields were emitted to the metadata. 
 
1119
 ExplicitLayout Specifies that class fields are laid out at the specified offsets. 
 
1120
 ClassSemanticsMask Specifies class semantics information; the current class is contextful (else agile). 
 
1121
 Class Specifies that the type is a class. 
 
1122
 Interface Specifies that the type is an interface. 
 
1123
    DONE: Abstract Specifies that the type is abstract. 
 
1124
    DONE: Sealed Specifies that the class is concrete and cannot be extended. 
 
1125
 SpecialName Specifies that the class is special in a way denoted by the name. 
 
1126
 Import Specifies that the class or interface is imported from another module. 
 
1127
 Serializable Specifies that the class can be serialized. 
 
1128
 StringFormatMask Used to retrieve string information for native interoperability. 
 
1129
 AnsiClass LPTSTR is interpreted as ANSI. 
 
1130
 UnicodeClass LPTSTR is interpreted as UNICODE. 
 
1131
 AutoClass LPTSTR is interpreted automatically. 
 
1132
 CustomFormatClass LPSTR is interpreted by some implementation-specific means, which includes the possibility of throwing a NotSupportedException. 
 
1133
 CustomFormatMask Used to retrieve non-standard encoding information for native interop. The meaning of the values of these 2 bits is unspecified. 
 
1134
 BeforeFieldInit Specifies that calling static methods of the type does not force the system to initialize the type. 
 
1135
 ReservedMask Attributes reserved for runtime use. 
 
1136
 RTSpecialName Runtime should check name encoding. 
 
1137
 HasSecurity 
 
1138
*)
 
1139
 
 
1140
    let generateCustomAttrDecls (c:CodeAttributeDeclarationCollection) = 
 
1141
      generateCustomAttrDeclsList (c |> Seq.cast |> Seq.toList)
 
1142
      
 
1143
    // NOTE: may contain custom attributes - this isn't supported
 
1144
    let generateParamDecl (c:CodeParameterDeclarationExpression) =
 
1145
      let dir = if (c.Direction <> FieldDirection.In) then " byref" else ""
 
1146
      id 
 
1147
      -! c.Name -- ":" +> generateTypeRef c.Type -- dir;
 
1148
 
 
1149
    // NOTE: may contain custom attributes - this isn't supported
 
1150
    let generateAbstractParamDecl (c:CodeParameterDeclarationExpression) =
 
1151
      let dir = if (c.Direction <> FieldDirection.In) then " byref" else ""
 
1152
      id +> generateTypeRef c.Type -- dir
 
1153
 
 
1154
    // Find all overloads of the method, so we can produce [<OverloadID>]
 
1155
    let getMethodOverloads (membs:CodeTypeMemberCollection) = 
 
1156
      let getMethodOverload map (n:CodeMemberMethod) = 
 
1157
        let n = (n.Name, getTypeRefSimple n.PrivateImplementationType)
 
1158
        match Map.tryFind n map with 
 
1159
          | Some v -> v 
 
1160
          | None -> 0
 
1161
      let incMethodOverload (n:CodeMemberMethod) map = 
 
1162
        let n = (n.Name, getTypeRefSimple n.PrivateImplementationType)
 
1163
        match Map.tryFind n map with 
 
1164
          | Some v -> Map.add n (v+1) map
 
1165
          | None -> Map.add n 1 map          
 
1166
      let m,a = 
 
1167
        membs 
 
1168
        |> codeDomCallBackNoScope 
 
1169
            (fun rcall (res,mlst) o -> 
 
1170
                match o with 
 
1171
                  | :? CodeMemberMethod as meth when meth.GetType() = (typeof<CodeMemberMethod>) -> 
 
1172
                      // we have found another method
 
1173
                      (incMethodOverload meth res, 
 
1174
                       ( meth, 
 
1175
                         getMethodOverload res meth,
 
1176
                         getTypeRefSimple meth.PrivateImplementationType
 
1177
                       )::mlst)
 
1178
                  | :? CodeTypeMemberCollection -> 
 
1179
                       // recursively walk through member collection
 
1180
                       rcall (res,mlst) o
 
1181
                  | _ -> (res,mlst))
 
1182
            (Map.empty, [])
 
1183
      getMethodOverload m, a
 
1184
      
 
1185
    //---------------------------------------------------------------------------------------------
 
1186
    // Fields, properties, constructors, methods
 
1187
    
 
1188
    /// fields 
 
1189
    let generateField (c:CodeMemberField) =    
 
1190
      id
 
1191
      +> generateCustomAttrDecls c.CustomAttributes
 
1192
      +> if ((c.Attributes &&& MemberAttributes.ScopeMask) = MemberAttributes.Static) then
 
1193
            id
 
1194
            ++ "[<DefaultValue(false)>]"
 
1195
            ++ "static val mutable private " -! c.Name -- ":" +> generateTypeRef c.Type
 
1196
            //++ (match c.InitExpression with
 
1197
                 
 
1198
         elif ((c.Attributes &&& MemberAttributes.ScopeMask) = MemberAttributes.Const) then
 
1199
            id
 
1200
            ++ "static member " -! c.Name -- " = " +> generateExpression c.InitExpression // should have initial value!
 
1201
         else
 
1202
             id ++ "[<DefaultValue(false)>]"
 
1203
                ++ "val mutable " -! c.Name -- ":" +> generateTypeRef c.Type
 
1204
    
 
1205
    /// Abstract property in the interface 
 
1206
    let generateInterfaceMemberProperty (c:CodeMemberProperty) =    
 
1207
      id 
 
1208
      ++ "abstract " -- c.Name -- " : " 
 
1209
      +> (if c.Parameters.Count  > 0 then col sepStar c.Parameters generateAbstractParamDecl -- " -> " else id) 
 
1210
      +> generateTypeRef c.Type -- " with " -- (if c.HasGet && not c.HasSet then "get" elif c.HasGet && c.HasSet then "get,set" else "set")
 
1211
 
 
1212
    // REVIEW: this is not correct, it should follow same abstract/default/override logic
 
1213
    // as methods. Unfortunately it isn't possible to declare "abstract" property with "default" implementation
 
1214
    let generateClassProperty (typ:MemberGenerateType)  (p:CodeMemberProperty) =    
 
1215
    
 
1216
      (if typ = MemberGenerateType.InsideStruct ||
 
1217
          typ = MemberGenerateType.InsideClass || // refuse to generate abstract methods
 
1218
          p.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Override ||
 
1219
          p.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Static 
 
1220
       then id
 
1221
       else (id 
 
1222
             ++ ""
 
1223
             +> generateInterfaceMemberProperty p))
 
1224
      +> generateCustomAttrDecls p.CustomAttributes
 
1225
      ++ if typ = MemberGenerateType.InsideStruct then "member this."
 
1226
         elif typ = MemberGenerateType.InsideClass then "member this."
 
1227
         elif (p.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Override) then "override  this." 
 
1228
         elif (p.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Static) then "static member " 
 
1229
         else "default this."
 
1230
      -- p.Name  
 
1231
 
 
1232
      +> if (not p.HasGet) then id else 
 
1233
         incIndent
 
1234
         ++ "with get("
 
1235
         +> col sepArgs p.Parameters generateParamDecl
 
1236
         -- ") : " +> generateTypeRef p.Type -- " =" 
 
1237
         +> generateStatementBlock (Some p.Type) p.GetStatements 
 
1238
         +> decIndent
 
1239
      +> if (not p.HasSet) then id else 
 
1240
         incIndent
 
1241
         ++ (if p.HasGet then "and" else "with") -- " set(" 
 
1242
         +> col sepNone p.Parameters (fun p -> (generateParamDecl p) -- ", ")
 
1243
         -- "value:" +> generateTypeRef p.Type 
 
1244
         -- ") : unit =" 
 
1245
         +> generateStatementBlock None p.SetStatements 
 
1246
         +> decIndent
 
1247
    
 
1248
    // The argument 'c' can be null when generating default ctor 
 
1249
    // (which is not generated by the compiler as in C#)
 
1250
    let generateConstructor (c:CodeConstructor) =    
 
1251
      // Find all (non-static) fields
 
1252
      withCtxt (fun ctx -> 
 
1253
          let fields = 
 
1254
            ctx.CurrentType.Members
 
1255
              |> codeDomFlatFilter (fun o -> 
 
1256
                   match o with 
 
1257
                     | :? CodeMemberField as fld -> 
 
1258
                       let keep = 
 
1259
                         (fld.Attributes &&& MemberAttributes.ScopeMask <> MemberAttributes.Static) &&
 
1260
                         (fld.Attributes &&& MemberAttributes.ScopeMask <> MemberAttributes.Const)  &&
 
1261
                         (match fld.InitExpression with null -> false | _ -> true)
 
1262
 
 
1263
                       (keep, false) 
 
1264
                     | _ -> 
 
1265
                       (false, false) )
 
1266
              |> List.map ( fun f -> f :?> CodeMemberField )
 
1267
          id
 
1268
          +> (if c <> null then generateCustomAttrDecls c.CustomAttributes else id)
 
1269
          ++ "new(" 
 
1270
          +> if (c <> null) then (col sepArgs c.Parameters generateParamDecl) else id
 
1271
          -- ") as this ="
 
1272
          +> incIndent
 
1273
          ++ "{"
 
1274
          +> incIndent
 
1275
          // Calling base constructor?
 
1276
          +> if (c = null || c.BaseConstructorArgs = null || c.BaseConstructorArgs.Count = 0) then id else
 
1277
                 let (b, i) = ctx.BaseTypes
 
1278
                 match b with 
 
1279
                   | None -> failwith "Calling constructor of nonexisting base?"
 
1280
                   | Some t -> 
 
1281
                      id 
 
1282
                      ++ "inherit " +> generateTypeRef t -- "("
 
1283
                      +> col sepArgs c.BaseConstructorArgs generateExpression
 
1284
                      --");"; 
 
1285
          // Generate events
 
1286
          +> decIndent
 
1287
          ++ "}"
 
1288
          +> if ((c <> null && c.Statements.Count > 0) || not fields.IsEmpty || not ctx.DeclaredEvents.IsEmpty) then
 
1289
               id
 
1290
               -- " then"
 
1291
               +> incIndent
 
1292
               +> incIndent
 
1293
               // Initialize events
 
1294
               +> colT sepNone ctx.DeclaredEvents ( fun e -> 
 
1295
                           id 
 
1296
                           ++ "let t_event_" -- e.Name -- " = new DelegateEvent<" +> generateTypeRef e.Type -- ">();"
 
1297
                           ++ "this._event_" -- e.Name -- " <- t_event_" -- e.Name -- ".Publish;"
 
1298
                           ++ "this._invoke_" -- e.Name -- " <- t_event_" -- e.Name -- ".Trigger;" ) 
 
1299
               // Initialize fields
 
1300
               +> colT sepNone fields (fun fld -> 
 
1301
                        id ++ "this." -- fld.Name -- " <- " +> generateExpression fld.InitExpression-- ";" )
 
1302
               // Run other initialization code
 
1303
               +> (if c <> null && c.Statements.Count > 0 then 
 
1304
                     id
 
1305
                     ++ "begin"
 
1306
                     +> generateStatementBlock (None) c.Statements 
 
1307
                     ++ "end"
 
1308
                   else 
 
1309
                      id)
 
1310
               +> decIndent
 
1311
               +> decIndent
 
1312
             else 
 
1313
               id
 
1314
          +> decIndent)
 
1315
 
 
1316
    /// Abstract method in the interface
 
1317
    let generateInterfaceMemberMethod (c:CodeMemberMethod, overloadId:int) =
 
1318
      let custAttrs = (c.CustomAttributes |> Seq.cast |> Seq.toList)
 
1319
 
 
1320
      let tyargs, genTyArgs = processTypeArgs c.TypeParameters       
 
1321
      usingTyParams tyargs 
 
1322
        (id
 
1323
        +> col sepNone c.Comments generateStatement
 
1324
        +> generateCustomAttrDeclsList custAttrs
 
1325
        ++ "abstract "
 
1326
        -- c.Name 
 
1327
        +> genTyArgs
 
1328
        -- " : "
 
1329
        +> if (c.Parameters.Count > 0) then
 
1330
             id +> col sepStar c.Parameters generateAbstractParamDecl
 
1331
           else
 
1332
             id -- "unit"
 
1333
        -- " -> "
 
1334
        +> generateTypeRef c.ReturnType)
 
1335
      
 
1336
    /// By default all CodeDOM generated methods are 'virtual' which means that 
 
1337
    /// we have to generate "abstract and default" (unless we're in struct or
 
1338
    /// we're implementing an interface, or the method is overriden)
 
1339
    /// (NOTE: the same logic isn't properly implemented for properties)
 
1340
    let generateMethod (typ:MemberGenerateType) (c:CodeMemberMethod) genAttrFunc =    
 
1341
      
 
1342
      let prefx, mnm =
 
1343
        if (typ = MemberGenerateType.InsideInterface) then
 
1344
          id, "member this."
 
1345
        elif (typ = MemberGenerateType.InsideStruct) then
 
1346
          id, "member this."
 
1347
        elif (c.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Static) then 
 
1348
          id, "static member "
 
1349
        elif (c :? CodeEntryPointMethod) then
 
1350
          id, "static member "
 
1351
        elif (c.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Abstract) then 
 
1352
          // refuse to generate abstract methods
 
1353
          if typ = MemberGenerateType.InsideClass then 
 
1354
              id, "member this."
 
1355
          else 
 
1356
              (id +> generateInterfaceMemberMethod (c, -1)), ""
 
1357
        elif (c.Attributes &&& MemberAttributes.ScopeMask = MemberAttributes.Override) then 
 
1358
          id, "override this." 
 
1359
        else
 
1360
          (id +> generateInterfaceMemberMethod (c, -1)),
 
1361
          "default this."
 
1362
 
 
1363
      //REVIEW: This is mutating the CodeMemberMethod which is a little questionable
 
1364
      if c.Name = "" then c.Name <- freshName ()
 
1365
      if (mnm = "") then prefx else
 
1366
      let tyargs, genTyArgs = processTypeArgs c.TypeParameters       
 
1367
      usingTyParams tyargs 
 
1368
        (prefx
 
1369
        +> genAttrFunc
 
1370
        ++ mnm -- c.Name +> genTyArgs -- " "
 
1371
        -- " (" +> col sepArgs c.Parameters generateParamDecl -- ")"
 
1372
        -- " ="
 
1373
        
 
1374
(*
 
1375
        // We need to create mutable copy of all arguments except for "byref" arguments which are mutable
 
1376
        +> incIndent
 
1377
        +> col sepNone c.Parameters (fun (c:CodeParameterDeclarationExpression) ->  
 
1378
             if (c.Direction <> FieldDirection.In) then id else
 
1379
               id ++ "let mutable " -- c.Name -- " = " -- c.Name ) 
 
1380
        +> decIndent     
 
1381
*)
 
1382
        +> generateStatementBlock (Some c.ReturnType) c.Statements)
 
1383
 
 
1384
    /// Generates method code
 
1385
    /// Generates comments and than calls 'generatMethod'
 
1386
    let generateClassMemberMethod (typ:MemberGenerateType) (c:CodeMemberMethod, overloadId:int) =
 
1387
      let custAttrs = (c.CustomAttributes |> Seq.cast |> Seq.toList)
 
1388
      id
 
1389
      +> col sepNone c.Comments generateStatement
 
1390
      +> generateMethod typ c (generateCustomAttrDeclsList custAttrs)
 
1391
    
 
1392
    let generateEntryPointMethod (typ:MemberGenerateType) (c:CodeEntryPointMethod)  = 
 
1393
      id
 
1394
      +> (fun ctx -> {ctx with MainMethodForCurrentNamespace = Some (c, ctx.CurrentType)})
 
1395
      +> (generateClassMemberMethod typ ((c :> CodeMemberMethod), -1))
 
1396
    
 
1397
    let generateEvent (c:CodeMemberEvent) = 
 
1398
      id
 
1399
      +> generateCustomAttrDecls c.CustomAttributes
 
1400
      ++ "[<CLIEvent>]"
 
1401
      ++ "member this." -- c.Name -- " ="
 
1402
      +> incIndent
 
1403
      ++ "this._event_" -- c.Name
 
1404
      +> decIndent
 
1405
    
 
1406
    let generateEventField (c:CodeMemberEvent) =
 
1407
      id
 
1408
      +> (fun ctx -> { ctx with DeclaredEvents = c::ctx.DeclaredEvents })
 
1409
      ++ "[<DefaultValue(false)>]"
 
1410
      ++ "val mutable _event_" -- c.Name -- " : IDelegateEvent<" +> generateTypeRef c.Type -- ">;"
 
1411
      ++ "[<DefaultValue(false)>]"
 
1412
      ++ "val mutable _invoke_" -- c.Name -- " : obj[] -> unit;";
 
1413
    
 
1414
 
 
1415
    let generateCodeSnippetMember (c:CodeSnippetTypeMember) =
 
1416
      
 
1417
      // Remove additional spaces to make sure that the code aligns with the rest
 
1418
      // CONSIDER: what to do with '\t' ?
 
1419
      let countSpaces (s:string) =
 
1420
        let rec countSpacesAux (s:string) i n = 
 
1421
          if i >= s.Length then n
 
1422
          elif s.[i] = ' ' then countSpacesAux s (i + 1) (n + 1)
 
1423
          else n
 
1424
        countSpacesAux s 0 0
 
1425
              
 
1426
      let lines = c.Text.Split([| '\n'; '\r' |], StringSplitOptions.RemoveEmptyEntries)
 
1427
      if lines.Length > 0 then 
 
1428
          let spaces = Array.foldBack (countSpaces >> min) lines Int32.MaxValue
 
1429
          let lines = lines |> Array.map (fun s -> s.[spaces..])
 
1430
          
 
1431
          // ASP.NET doesn�t use any comments or custom attributes, 
 
1432
          // but I assume this would be the right order
 
1433
          id 
 
1434
          +> col sepNone c.Comments generateStatement
 
1435
          +> generateLinePragma c.LinePragma
 
1436
          +> generateCustomAttrDecls c.CustomAttributes
 
1437
          +> colT sepNone lines ((++) id)
 
1438
      else 
 
1439
          id
 
1440
 
 
1441
            
 
1442
    //---------------------------------------------------------------------------------------------
 
1443
    // Interfaces and classes and other types
 
1444
 
 
1445
    let generateInterfaceImplementation (ifcnfo:KeyValuePair<_, _>) =
 
1446
      let name = ifcnfo.Key
 
1447
      let membs = ifcnfo.Value
 
1448
      id 
 
1449
      ++ "interface " -- name -- " with"
 
1450
      +> incIndent
 
1451
      +> colT sepNln membs (generateClassMemberMethod MemberGenerateType.InsideInterface)
 
1452
      +> decIndent
 
1453
 
 
1454
    let generateClassMember typ (c:CodeTypeMember) =
 
1455
      match c with 
 
1456
      | :? CodeTypeDeclaration -> id 
 
1457
      | :? CodeMemberField 
 
1458
      | :? CodeMemberEvent 
 
1459
      | :? CodeConstructor 
 
1460
      | :? CodeMemberProperty ->
 
1461
            id
 
1462
            +> col sepNone c.Comments generateStatement
 
1463
            +> match c with 
 
1464
                 | :? CodeMemberField as cm -> generateField cm
 
1465
                 | :? CodeMemberEvent as cm -> generateEvent cm
 
1466
                 | :? CodeConstructor as cm -> generateConstructor cm
 
1467
                 | :? CodeMemberProperty as cm -> generateClassProperty typ cm
 
1468
                 | _ -> failwithf "unimplemented CodeTypeMember '%A'" c
 
1469
      | _ ->
 
1470
            id ++ "(* Member of type '" +> str (c.GetType().Name) --  "' is not supported by the CodeDOM provider and was omitted *)" 
 
1471
 
 
1472
      
 
1473
    let generateClassOrStruct structOrCls (scope:string list) (c:CodeTypeDeclaration) ctx =
 
1474
      // affects members
 
1475
      let typ = 
 
1476
        if (structOrCls = "struct") then MemberGenerateType.InsideStruct 
 
1477
          else MemberGenerateType.InsideClass
 
1478
        
 
1479
      // Find all constructors
 
1480
      let ctors = 
 
1481
         c |> codeDomFlatFilter (fun o -> 
 
1482
            match o with 
 
1483
              | :? CodeTypeDeclaration as dc -> (false, dc = c)
 
1484
              | :? CodeConstructor as c -> (true, true)
 
1485
              | _ -> (false, true) ) 
 
1486
      let anyCtor = (ctors.Length > 0)
 
1487
      let useImplicitCtor = (ctors.Length <= 1)
 
1488
      
 
1489
      // Find base classes
 
1490
      let (baseClass, interfaces) = resolveHierarchy c ctx
 
1491
      
 
1492
      // Find fields and their types
 
1493
      let (ft, pt, flds, props, meths, events) = 
 
1494
          c.Members |> codeDomCallBackNoScope (fun rcall ((ft, pt,flds, props, meths, events) as acc) o -> 
 
1495
              match o with 
 
1496
                | :? CodeMemberField as fld -> (Map.add fld.Name fld.Type ft, pt, Map.add fld.Name  fld flds, props, meths, events)
 
1497
                | :? CodeMemberProperty as prop -> (ft, Map.add prop.Name prop.Type pt, flds, Map.add prop.Name prop props, meths, events)
 
1498
                | :? CodeMemberMethod as meth -> (ft, pt, flds, props, Map.add meth.Name meth meths, events)
 
1499
                | :? CodeMemberEvent as ev -> (ft, pt, flds, props, meths, Map.add ev.Name ev events)
 
1500
                | :? CodeTypeMemberCollection -> rcall acc o
 
1501
                | _ -> acc; ) (Map.empty, Map.empty, Map.empty, Map.empty, Map.empty, Map.empty)
 
1502
                          
 
1503
      // Find all overloads of the method, so we can produce [<OverloadID>]
 
1504
      let (getOverload, allmeths) = getMethodOverloads(c.Members)
 
1505
      
 
1506
      // Get tripple with method info, overload id and name of the interface where
 
1507
      // it belongs (if it's "PrivateImplementationType")
 
1508
      let allmeths = allmeths |> List.map ( fun (cm, ovIdx, intrfcName) -> 
 
1509
        match getOverload cm with | 1 -> (cm, -1, intrfcName) | _ -> (cm, ovIdx, intrfcName) )
 
1510
        
 
1511
      // Split between methods of the class
 
1512
      // and methods that implemnet some interface
 
1513
      let ifcTable = new Dictionary<string, ResizeArray<CodeMemberMethod*int>>()
 
1514
      let allmeths = 
 
1515
        allmeths |> mapFilter (fun (m, idx, ifn) -> 
 
1516
          match m.PrivateImplementationType, m.ImplementationTypes.Count with
 
1517
          | null, 0 -> Some((m,idx))
 
1518
          | _ , 0 -> 
 
1519
            let b,v = ifcTable.TryGetValue(ifn)
 
1520
            let v = 
 
1521
              if (not b) then 
 
1522
                let rs = new ResizeArray<CodeMemberMethod*int>()
 
1523
                ifcTable.Add(ifn, rs)
 
1524
                rs 
 
1525
              else v
 
1526
            v.Add((m,idx))
 
1527
            None
 
1528
          | null, n -> 
 
1529
            for implementedInterface in m.ImplementationTypes do
 
1530
                let b,v = ifcTable.TryGetValue(getTypeRefSimple implementedInterface)
 
1531
                let v =
 
1532
                  if (not b) then
 
1533
                    let rs = new ResizeArray<CodeMemberMethod*int>()
 
1534
                    ifcTable.Add(getTypeRefSimple implementedInterface, rs)
 
1535
                    rs
 
1536
                  else v
 
1537
                v.Add((m, idx))
 
1538
            Some((m,idx))
 
1539
          | _, _ -> failwith "CodeMethodMember must not have both ImplementationTypes and PrivateImplementationType set.")
 
1540
 
 
1541
 
 
1542
      // NOTE: we ignore class visibility and also IsPartial property
 
1543
      // Declare type arguments and generate class 
 
1544
      let tyargs, genTyArgs = processTypeArgs c.TypeParameters       
 
1545
      (usingTyParams tyargs 
 
1546
        (id  
 
1547
        +> (fun ctx -> { ctx with BaseTypes = (baseClass, interfaces); FieldTypes = ft; PropertyTypes = pt; AllFields=flds; AllProps=props; AllMeths=meths; AllEvents=events  })   
 
1548
        +> (if c.IsPartial then id -- " (* partial *)" else id)    
 
1549
        +> col sepNone scope (fun s -> id -- s -- "_") -- c.Name 
 
1550
        +> genTyArgs
 
1551
        // Generate implicit constructor args
 
1552
        +> (if useImplicitCtor then 
 
1553
                let parameters = 
 
1554
                    match ctors with 
 
1555
                    | [ :? CodeConstructor as ctor ] -> [ for p in ctor.Parameters -> p ] 
 
1556
                    | _ -> [ ]
 
1557
                id -- "(" +> col sepArgs parameters generateParamDecl -- ")"
 
1558
            else 
 
1559
                id)
 
1560
        -- " = " 
 
1561
        +> incIndent
 
1562
        +> (match baseClass with
 
1563
             | Some bc -> 
 
1564
                 if useImplicitCtor then 
 
1565
                     match ctors with 
 
1566
                     | [ :? CodeConstructor as ctor ] when ctor.BaseConstructorArgs <> null || ctor.BaseConstructorArgs.Count <> 0 -> 
 
1567
                       id 
 
1568
                       ++ "inherit " +> generateTypeRef bc -- "("
 
1569
                       +> col sepArgs ctor.BaseConstructorArgs generateExpression
 
1570
                       --")"
 
1571
                     | _ ->
 
1572
                         id ++ "inherit " +> generateTypeRef bc -- "()" 
 
1573
                 else 
 
1574
                     id ++ "inherit " +> generateTypeRef bc -- " "
 
1575
             | _ -> id)
 
1576
        
 
1577
        // Filter and generate members
 
1578
        +> colFilterT<CodeMemberEvent>     sepNln c.Members generateEventField
 
1579
        +> colFilter<CodeMemberField>     sepNln c.Members (generateClassMember typ)
 
1580
        +> colFilter<CodeTypeConstructor> sepNln c.Members (generateClassMember typ)
 
1581
        +> colFilter<CodeMemberEvent>     sepNln c.Members (generateClassMember typ)
 
1582
        
 
1583
        // Generate default empty constructor for classes 
 
1584
        // without constructors (but not for structs!)
 
1585
        +> if (not useImplicitCtor && anyCtor) then
 
1586
             colFilter<CodeConstructor> sepNln c.Members (generateClassMember typ)
 
1587
           elif (not useImplicitCtor && structOrCls = "class" && not c.IsPartial) then
 
1588
             generateConstructor null
 
1589
           else
 
1590
            id 
 
1591
            
 
1592
        // User code
 
1593
        +> colFilterT<CodeSnippetTypeMember> sepNln c.Members generateCodeSnippetMember
 
1594
        // Properties, methods, interface implementations
 
1595
        +> colFilter<CodeMemberProperty> sepNln c.Members (generateClassMember typ)
 
1596
        +> colT sepNln allmeths (generateClassMemberMethod typ)
 
1597
        +> colT sepNln ifcTable generateInterfaceImplementation
 
1598
        +> colFilterT<CodeEntryPointMethod> sepNln c.Members (generateEntryPointMethod typ)
 
1599
        +> decIndent)) ctx
 
1600
        
 
1601
    let generateInterface (scope:string list) (c:CodeTypeDeclaration) =
 
1602
      // handle overloads
 
1603
      let (getOverload, allmeths) = getMethodOverloads c.Members 
 
1604
      let allmeths = allmeths |> List.map ( fun (cm, ovIdx, _) -> 
 
1605
        match getOverload cm with | 1 -> (cm, -1) | _ -> (cm, ovIdx) )
 
1606
 
 
1607
      let castToProp (a:CodeTypeMember) = (a :?> CodeMemberProperty)        
 
1608
 
 
1609
      // NOTE: visibility is ignored
 
1610
      let tyargs, genTyArgs = processTypeArgs c.TypeParameters       
 
1611
      usingTyParams tyargs 
 
1612
        (id  
 
1613
        +> col sepNone scope (fun s -> id -- s -- "_") -- c.Name 
 
1614
        +> genTyArgs
 
1615
        -- " = "
 
1616
        +> incIndent
 
1617
        +> col sepNln c.BaseTypes (fun (cr:CodeTypeReference) -> id ++ "inherit " +> generateTypeRef cr)
 
1618
        +> colFilter<CodeMemberProperty> sepNln c.Members (castToProp >> generateInterfaceMemberProperty)
 
1619
        +> colT sepNln allmeths generateInterfaceMemberMethod
 
1620
        +> decIndent)
 
1621
      
 
1622
    let generateDelegate (scope:string list) (c:CodeTypeDelegate) =
 
1623
      let tyargs, genTyArgs = processTypeArgs c.TypeParameters       
 
1624
      usingTyParams tyargs 
 
1625
        (id
 
1626
        +> col sepNone scope (fun s -> id -- s -- "_") -- c.Name 
 
1627
        +> genTyArgs
 
1628
        -- " = delegate of "
 
1629
        +> if (c.Parameters.Count = 0) then
 
1630
             id -- "unit"
 
1631
           else
 
1632
             col sepStar c.Parameters (fun (p:CodeParameterDeclarationExpression) ->
 
1633
               id +> generateTypeRef p.Type )
 
1634
        -- " -> "
 
1635
        +> match c.ReturnType with 
 
1636
             | null -> id -- "unit"
 
1637
             | rt -> generateTypeRef rt)
 
1638
      
 
1639
    let generateEnumField (index:int) (c:CodeMemberField) =    
 
1640
      id 
 
1641
      ++ "| " -- c.Name -- " = " 
 
1642
      +> match c.InitExpression with
 
1643
           | null -> str index
 
1644
           | :? CodePrimitiveExpression as p -> generatePrimitiveExpr None p
 
1645
           | _ -> failwith "Invalid enum !";
 
1646
                     
 
1647
    let generateEnum (scope:string list) (c:CodeTypeDeclaration) =
 
1648
      let counter = createCounter()
 
1649
      id     
 
1650
      +> col sepNone scope (fun s -> id -- s -- "_") -- c.Name 
 
1651
      -- " =" 
 
1652
      +> incIndent
 
1653
      +> col sepNone c.Members (fun c -> generateEnumField (counter()) c)
 
1654
      +> decIndent
 
1655
    
 
1656
    let generateTypeDecl index (scope:string list, c:CodeTypeDeclaration) =      
 
1657
      let attribs = 
 
1658
          [ for a in c.CustomAttributes do yield Choice1Of2 a 
 
1659
            match c with 
 
1660
            | :? CodeTypeDelegate as cd -> ()
 
1661
            | c when c.IsClass -> ()
 
1662
            | c when c.IsInterface -> yield Choice2Of2 "Interface"
 
1663
            | c when c.IsEnum -> ()
 
1664
            | c when c.IsStruct -> yield Choice2Of2 "Struct"
 
1665
            | _ -> () ]
 
1666
 
 
1667
      let genAttribs = generateCustomAttrDeclsForType attribs c.TypeAttributes
 
1668
 
 
1669
      id
 
1670
      // Attributes go before 'type' for the first type declaration and after 'and' for others
 
1671
      +> (if index <> 0 then id else genAttribs)
 
1672
      +> col sepNone c.Comments generateStatement 
 
1673
      ++ if (index = 0) then "type " else "and "
 
1674
      +> incIndent
 
1675
      +> (if index = 0 then id else genAttribs)
 
1676
      +> (fun ctx -> { ctx with CurrentType = c })
 
1677
      +> match c with 
 
1678
           | :? CodeTypeDelegate as cd -> generateDelegate scope cd
 
1679
           | c when c.IsClass -> generateClassOrStruct "class" scope c
 
1680
           | c when c.IsInterface -> generateInterface scope c
 
1681
           | c when c.IsEnum -> generateEnum scope c
 
1682
           | c when c.IsStruct -> generateClassOrStruct "struct" scope c
 
1683
           | _ -> 
 
1684
            // NOTE: I believe this is full match..
 
1685
            id ++ "(* Type '" -- (c.Name) --  "' is not supported by the CodeDOM provider and was omitted. *)"
 
1686
      +> decIndent
 
1687
      +> (fun ctx -> { ctx with DeclaredEvents = []; CurrentType = null; BaseTypes = (None, []); FieldTypes = Map.empty; PropertyTypes = Map.empty; })
 
1688
      
 
1689
    /// Generates a main method.
 
1690
    let generateMainMethod (c:CodeEntryPointMethod, t:CodeTypeDeclaration) (ns:CodeNamespace) =
 
1691
      let retType = getTypeRefSimple c.ReturnType 
 
1692
      let custAttrs = 
 
1693
        CodeAttributeDeclaration("EntryPoint", [||]) :: (c.CustomAttributes |> Seq.cast |> Seq.toList)
 
1694
      
 
1695
      if ((c.Parameters.Count = 0) || (c.Parameters.Count = 1 && (getTypeRefSimple c.Parameters.[0].Type) = "string[]" ))
 
1696
         && (retType = "int" || retType = "unit")
 
1697
      then
 
1698
        id
 
1699
        ++ "[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]"
 
1700
        ++ "module __EntryPoint ="
 
1701
        +> incIndent
 
1702
        +>   (generateCustomAttrDeclsList custAttrs)  
 
1703
        ++   "let Main (args:string[]) ="
 
1704
        +> incIndent
 
1705
        // REVIEW: Do we need to pass this through the "rename" table?  Could use '(generateTypeRef t)', but we don't have a CodeTypeReference
 
1706
        ++ t.Name -- "." -- (c.Name) 
 
1707
        +> if c.Parameters.Count = 1 
 
1708
           then id -- "(args)"
 
1709
           else id -- "()"
 
1710
        // F# only supports main methods returning int.  If we're asked to emit one that returns unit, just return 1.
 
1711
        +> if retType = "unit" then id ++ "0" else id
 
1712
        +> decIndent 
 
1713
        +> decIndent
 
1714
      else
 
1715
        id ++ "(* Could not generate entry point for method '" -- (c.Name) -- "'. *)"
 
1716
      
 
1717
    //---------------------------------------------------------------------------------------------
 
1718
    // Namespaces and compilation units
 
1719
    
 
1720
    /// Returns CodeNamespace, list of classes with scope (which includes class names 
 
1721
    /// of containing classes and sequence of class renames)
 
1722
    let preprocessNamespace (c:CodeNamespace) =
 
1723
        
 
1724
        // Extract flat class structure
 
1725
        let flatClasses = 
 
1726
            c 
 
1727
            |> codeDomCallbackWithScope (fun rcall scope acc o -> 
 
1728
                  match o with 
 
1729
                    | :? CodeTypeDeclaration as dc -> 
 
1730
                        //sprintf "preprocessNamespace: rcall for type c.Name = %s\n" dc.Name |> System.Windows.Forms.MessageBox.Show |> ignore
 
1731
                        rcall (dc.Name::scope) ((scope, dc)::acc) (box dc.Members)
 
1732
                    | _ -> rcall scope acc o) [] [];
 
1733
        let flatClasses = flatClasses |> List.rev
 
1734
        
 
1735
        // Get all renamed classes - this changes file structure, but at least it works
 
1736
        let addNameWithScope n (scope:string list) acc = 
 
1737
            let scn = String.Join("_",Array.ofList scope) + "_" + n
 
1738
            let (_, res) = 
 
1739
                scope |> List.fold ( fun (prefix,st) e ->
 
1740
                  let npref = e + prefix
 
1741
                  let nmap = Map.add (npref + n) scn st 
 
1742
                  ("." + npref, nmap) ) (".", Map.add n scn acc)
 
1743
            res                
 
1744
 
 
1745
        //sprintf "c.Name = %s, #flatClasses = %d\n" c.Name flatClasses.Length |> System.Windows.Forms.MessageBox.Show |> ignore
 
1746
 
 
1747
        let renames = 
 
1748
            flatClasses 
 
1749
            |> List.fold ( fun acc ((scope:string list), ty) ->
 
1750
                  if (scope.Length = 0) then acc 
 
1751
                  else addNameWithScope ty.Name scope acc ) Map.empty
 
1752
 
 
1753
        //if (renames |> Seq.length) > 0 then
 
1754
        //    sprintf "#renames = %d\n" (renames |> Seq.length) |> System.Windows.Forms.MessageBox.Show |> ignore
 
1755
 
 
1756
        (c, flatClasses, renames |> Map.toSeq);        
 
1757
        
 
1758
    let generateImport (c:CodeNamespaceImport) = 
 
1759
      id  ++ "open " -- c.Namespace
 
1760
      
 
1761
    /// Generates namespace code - takes output from 'preprocessNamespace'
 
1762
    let generateNamespaceInternal (c:CodeNamespace, extraImports:seq<CodeNamespaceImport>, flatClasses, containing) =
 
1763
      let counter = createCounter()
 
1764
      let ifcSet = 
 
1765
        flatClasses 
 
1766
          |> List.fold (fun st (scope, (c:CodeTypeDeclaration)) -> 
 
1767
                if (c.IsInterface) then 
 
1768
                  let st = Set.add c.Name st 
 
1769
                  Set.add (String.concat "." (scope@[c.Name])) st
 
1770
                else st) Set.empty
 
1771
      
 
1772
      id
 
1773
      +> ( fun ctx -> { ctx with CurrentNamespace = c.Name; DeclaredInterfaces = ifcSet } )
 
1774
      +> col sepNone c.Comments generateStatement
 
1775
      +> ((if String.IsNullOrEmpty c.Name then id ++ "namespace global" else id ++ "namespace " -! c.Name) (* +> incIndent *) ) 
 
1776
(*
 
1777
      ++ "#nowarn \"49\" // uppercase argument names"
 
1778
      ++ "#nowarn \"67\" // this type test or downcast will always hold"
 
1779
      ++ "#nowarn \"66\" // this upcast is unnecessary - the types are identical"
 
1780
      ++ "#nowarn \"58\" // possible incorrect indentation.." // (when using CodeSnippets ie. in ASP.NET)
 
1781
      ++ "#nowarn \"57\" // do not use create_DelegateEvent"
 
1782
      ++ "#nowarn \"51\" // address-of operator can occur in the code"
 
1783
      ++ "#nowarn \"1183\" // unused 'this' reference"
 
1784
      +> colT sepNone containing (fun s -> id ++ "open " -- s)
 
1785
*)
 
1786
      +> col sepNone extraImports generateImport
 
1787
      +> col sepNone c.Imports generateImport
 
1788
      ++ ""              
 
1789
(*
 
1790
      ++ "exception ReturnException" +> uniqid -- " of obj"
 
1791
      ++ "exception ReturnNoneException" +> uniqid 
 
1792
 
 
1793
      ++ "[<AutoOpen>]"
 
1794
      ++ "module FuncConvertFinalOverload" +> uniqid -- " ="
 
1795
      ++ "  // This extension member adds to the FuncConvert type and is the last resort member in the method overloading rules. "
 
1796
      ++ "  type global.Microsoft.FSharp.Core.FuncConvert with"
 
1797
      ++ "      /// A utility function to convert function values from tupled to curried form"
 
1798
      ++ "      static member FuncFromTupled (f:'T -> 'Res) = f"
 
1799
      ++ ""
 
1800
*)
 
1801
      +> colT sepNln flatClasses (fun c -> generateTypeDecl (counter()) c)
 
1802
      +> withCtxt (fun ctx -> match ctx.MainMethodForCurrentNamespace with None -> id | Some mainMethod -> (generateMainMethod mainMethod c))
 
1803
      +> if (c.Name<>null && c.Name.Length>0) then decIndent else id
 
1804
      +> ( fun ctx -> { ctx with CurrentNamespace = ""; MainMethodForCurrentNamespace = None } )
 
1805
    
 
1806
    
 
1807
    /// Generate code for namespace without compilation unit  
 
1808
    let generateNamespace (c:CodeNamespace) = 
 
1809
        let (cn, b, _) = preprocessNamespace c
 
1810
        generateNamespaceInternal (cn, [], b, [])
 
1811
        
 
1812
    /// Generate code for type declaration (not included in namespace)                 
 
1813
    let generateTypeDeclOnly (c:CodeTypeDeclaration) =
 
1814
        let ns = new CodeNamespace()
 
1815
        ns.Types.Add(c) |> ignore
 
1816
        let ((_, flatClasses, _), containing) = (preprocessNamespace ns, [])
 
1817
        let counter = createCounter()
 
1818
        id
 
1819
        ++ ""              
 
1820
        ++ "exception ReturnException" +> uniqid -- " of obj"
 
1821
        ++ "exception ReturnNoneException" +> uniqid 
 
1822
        ++ ""
 
1823
        +> colT sepNln flatClasses (fun c -> generateTypeDecl (counter()) c)
 
1824
 
 
1825
    /// Generate code for compile unit (file)                
 
1826
    let generateCompileUnit (c:CodeCompileUnit) =
 
1827
      
 
1828
      // Generate code for the compilation unit
 
1829
      match c with 
 
1830
        | :? CodeSnippetCompileUnit as cs -> 
 
1831
          id +> generateLinePragma cs.LinePragma ++ cs.Value
 
1832
        | _ -> 
 
1833
          let preprocNs = c.Namespaces |> Seq.cast |> Seq.map preprocessNamespace
 
1834
          let renames = preprocNs |> Seq.collect (fun (_, _, renames) -> renames) 
 
1835
          let getContainingNamespaces (c:CodeNamespace) nslist =
 
1836
            nslist |> List.filter ( fun (n:string) -> c.Name.StartsWith(n) )
 
1837
          let (namespacesWithPrev, _) = 
 
1838
            (([], []),preprocNs) ||> Seq.fold (fun (res, tmpNames) (c, cls, renames) ->
 
1839
              (((c, cls, renames), getContainingNamespaces c tmpNames)::res, c.Name::tmpNames) ) 
 
1840
          let namespacesWithPrev = namespacesWithPrev |> Seq.toList |> List.rev
 
1841
 
 
1842
          // Move a set of 'open' declarations with no namespace into the first real namespace
 
1843
          let namespacesWithPrev = 
 
1844
              match namespacesWithPrev with 
 
1845
              | ((cn1, flatClasses1, renames1), containing1) :: 
 
1846
                ((cn2, flatClasses2, renames2), containing2) :: 
 
1847
                rest
 
1848
                  when System.String.IsNullOrEmpty cn1.Name && flatClasses1.IsEmpty -> 
 
1849
                    (cn2, [ for cni in cn1.Imports -> cni ], flatClasses2, containing2) ::
 
1850
                    (rest |> List.map (fun ((a,b,_),d) -> (a,[ ],b,d))) 
 
1851
              | rest ->
 
1852
                    rest |> List.map (fun ((a,b,_),d) -> (a,[ ],b,d)) 
 
1853
 
 
1854
          (fun ctx -> { ctx with TypeRenames = Map.ofSeq renames; } )        
 
1855
          ++ "//------------------------------------------------------------------------------"
 
1856
          ++ "// <autogenerated>"
 
1857
          ++ "//     This code was generated by a tool."
 
1858
          ++ "//     Runtime Version: " +> (str System.Environment.Version)
 
1859
          ++ "//"
 
1860
          ++ "//     Changes to this file may cause incorrect behavior and will be lost if "
 
1861
          ++ "//     the code is regenerated."
 
1862
          ++ "// </autogenerated>"
 
1863
          ++ "//------------------------------------------------------------------------------"
 
1864
          ++ ""
 
1865
          +> colT sepNln namespacesWithPrev generateNamespaceInternal
 
1866
 
 
1867
    //---------------------------------------------------------------------------------------------