/compiler/3.0/Sep2012/src/fsharp/tainted.fs

namespace Microsoft.FSharp.Compiler

open System

open Microsoft.FSharp.Compiler.Range

open Microsoft.FSharp.Core.CompilerServices

open Microsoft.FSharp.Compiler.AbstractIL.IL

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library 

open System.Reflection

open System.Collections.Generic

open ErrorLogger



type internal TypeProviderError

    (

        errNum : int,

        tpDesignation : string,

        m:Microsoft.FSharp.Compiler.Range.range,

        errors : string list,

        typeNameContext : string option,

        methodNameContext : string option

    ) =



    inherit System.Exception()



    new((errNum, msg : string), tpDesignation,m) = 

        TypeProviderError(errNum, tpDesignation, m, [msg])

    

    new(errNum, tpDesignation, m, messages : seq<string>) =         

        TypeProviderError(errNum, tpDesignation, m, List.ofSeq messages, None, None)



    member this.Number = errNum

    member this.Range = m



    override this.Message = 

        match errors with

        | [text] -> text

        | inner -> 

            // imitates old-fashioned behavior with merged text

            // usually should not fall into this case (only if someone takes Message directly instead of using Iter)

            inner            

            |> String.concat Environment.NewLine



    member this.MapText(f, tpDesignation, m) = 

        let (errNum : int), _ = f ""

        new TypeProviderError(errNum, tpDesignation, m,  (Seq.map (f >> snd) errors))



    member this.WithContext(typeNameContext:string, methodNameContext:string) = 

        new TypeProviderError(errNum, tpDesignation, m, errors, Some typeNameContext, Some methodNameContext)



    // .Message is just the error, whereas .ContextualErrorMessage has contextual prefix information

    // for example if InvokeCode in provided method is not set or has value that cannot be translated -then initial TPE will be wrapped in

    // TPE having type\method name as contextual information

    // without context: Type Provider 'TP' has reported the error: MSG

    // with context: Type Provider 'TP' has reported the error in method M of type T: MSG

    member this.ContextualErrorMessage= 

        match typeNameContext, methodNameContext with

        | Some tc, Some mc ->

            let _,msgWithPrefix = FSComp.SR.etProviderErrorWithContext(tpDesignation, tc, mc, this.Message)

            msgWithPrefix

        | _ ->

            let _,msgWithPrefix = FSComp.SR.etProviderError(tpDesignation, this.Message)

            msgWithPrefix

    

    /// provides uniform way to handle plain and composite instances of TypeProviderError

    member this.Iter f = 

        match errors with

        | [_] -> f this

        | errors ->

            for msg in errors do

                f (new TypeProviderError(errNum, tpDesignation, m, [msg], typeNameContext, methodNameContext))



type TaintedContext = { TypeProvider : ITypeProvider; TypeProviderAssemblyRef : ILScopeRef }



[<NoEquality>][<NoComparison>] 

type internal Tainted<'T> (context : TaintedContext, value : 'T) =

    do

        match box context.TypeProvider with 

        | null -> 

            assert false

            failwith "null ITypeProvider in Tainted constructor"

        | _ -> ()



    member this.TypeProviderDesignation = 

        context.TypeProvider.GetType().FullName



    member this.TypeProviderAssemblyRef = 

        context.TypeProviderAssemblyRef



    member this.Protect f  (range:range) =

        try 

            f value

        with

            |   :? TypeProviderError -> reraise()

            |   :? AggregateException as ae ->

                    let errNum,_ = FSComp.SR.etProviderError("", "")

                    let messages = [for e in ae.InnerExceptions -> e.Message]

                    raise <| TypeProviderError(errNum, this.TypeProviderDesignation, range, messages)

            |   e -> 

                    let errNum,_ = FSComp.SR.etProviderError("", "")

                    raise <| TypeProviderError((errNum, e.Message), this.TypeProviderDesignation, range)



    member this.TypeProvider = Tainted<_>(context, context.TypeProvider)



    member this.PApply(f,range:range) = 

        let u = this.Protect f range

        Tainted(context, u)



    member this.PApply2(f,range:range) = 

        let u1,u2 = this.Protect f range

        Tainted(context, u1), Tainted(context, u2)



    member this.PApply3(f,range:range) = 

        let u1,u2,u3 = this.Protect f range

        Tainted(context, u1), Tainted(context, u2), Tainted(context, u3)



    member this.PApply4(f,range:range) = 

        let u1,u2,u3,u4 = this.Protect f range

        Tainted(context, u1), Tainted(context, u2), Tainted(context, u3), Tainted(context, u4)



    member this.PApplyNoFailure f = this.PApply (f, range0)



    member this.PApplyWithProvider(f,range:range) = 

        let u = this.Protect (fun x -> f (x,context.TypeProvider)) range

        Tainted(context, u)



    member this.PApplyArray(f,methodName,range:range) =        

        let a = this.Protect f range

        match a with 

        |   null -> raise <| TypeProviderError(FSComp.SR.etProviderReturnedNull(methodName), this.TypeProviderDesignation, range)

        |   _ -> a |> Array.map (fun u -> Tainted(context,u))





    member this.PApplyOption(f,range:range) =        

        let a = this.Protect f range

        match a with 

        | None ->  None

        | Some x -> Some (Tainted(context,x))



    member this.PUntaint(f,range:range) = this.Protect f range

    member this.PUntaintNoFailure f = this.PUntaint(f, range0)

    /// Access the target object directly. Use with extreme caution.

    member this.AccessObjectDirectly = value



    static member CreateAll(providerSpecs : (ITypeProvider * ILScopeRef) list) =

        [for (tp,nm) in providerSpecs do

             yield Tainted<_>({ TypeProvider=tp; TypeProviderAssemblyRef=nm },tp) ] 



    member this.OfType<'U> () =

        match box value with

        |   :? 'U as u -> Some (Tainted(context,u))

        |   _ -> None



    member this.Coerce<'U> (range:range) =

        Tainted(context, this.Protect(fun value -> box value :?> 'U) range)



module internal Tainted =

    let (|Null|_|) (p:Tainted<'T>) =

        if p.PUntaintNoFailure(fun p -> match p with null -> true | _ -> false) then Some() else None



    let Eq (p:Tainted<'T>) (v:'T) = p.PUntaintNoFailure((fun pv -> pv = v))



    let EqTainted (t1:Tainted<'T>) (t2:Tainted<'T>) = 

        t1.PUntaintNoFailure(fun t1 -> t1 === t2.AccessObjectDirectly)



    let GetHashCodeTainted (t:Tainted<'T>) = t.PUntaintNoFailure(fun t -> hash t)