CodeGen1.fsx

   
open System

type Temp(d,fmt,build) = 
    member val Build = build with get,set
    member x.Dictionary : System.Collections.Generic.Dictionary<string, obj> = d
    member x.Formatters : ResizeArray<obj -> string option> = fmt
    member x.Content() = x.Build x 
    new() = Temp(System.Collections.Generic.Dictionary<string, obj>(), ResizeArray(), fun _ -> Some "")
    new(f) = Temp(System.Collections.Generic.Dictionary<string, obj>(), ResizeArray(), f)
    new(str) = Temp(System.Collections.Generic.Dictionary<string, obj>(), ResizeArray(), fun _ -> Some str)
    member x.Duplicate() = Temp(System.Collections.Generic.Dictionary(x.Dictionary), ResizeArray(x.Formatters), x.Build)
    member x.TryGet(name) = 
        let scc,v = x.Dictionary.TryGetValue(name)
        if scc then Some v else None
    member x.Format(o : obj) = 
        match x.Formatters |> Seq.tryPick (fun f -> f o) with
        | Some v -> v
        | None ->
            match o with
            | :? string as str -> str
            | :? Temp as cc ->
                let cc = 
                    if x.Dictionary.Count > 0 then 
                        let cc = cc.Duplicate()
                        for kvp in x.Dictionary do 
                            if cc.Dictionary.ContainsKey(kvp.Key) |> not then
                                cc.Dictionary.Add(kvp.Key, kvp.Value)
                        cc
                    else
                        cc
                match cc.Content() with | Some v -> v | None -> ""
            | x -> x.ToString()
    member x.GetString(name) = x.TryGet(name) |> Option.map x.Format
    member x.GetTemplate(name) = x.TryGet(name) |> Option.map x.Format


module TempOperators =

    let (|Template|_|) name (cc : Temp) = 
        match cc.TryGet(name) with
        | Some (:? Temp as x) -> Some x
        | _ -> None
        
    let (|AsString|_|) name (cc : Temp) = 
        match cc.TryGet(name) with
        | Some (x) -> cc.Format x |> Some
        | _ -> None 

    let (|AsStringOrDefault|) name def (cc : Temp) = 
        match cc.TryGet(name) with
        | Some (x) -> cc.Format x
        | _ -> def
        
    let (|AsStringOrEmpty|) name (cc : Temp) = 
        match cc.TryGet(name) with
        | Some (x) -> cc.Format x
        | _ -> ""

    let (|IsDefined|_|) name (cc : Temp) = 
        match cc.TryGet(name) with
        | Some (x) -> Some ()
        | _ -> None
        
    let (|Element|_|) name (cc : Temp) = cc.TryGet(name)

    let (|ValidTemplate|_|) name (cc : Temp) = 
        match cc.TryGet(name) with
        | Some (:? Temp as x) when x.Content().IsSome -> Some x
        | _ -> None


    let (|TemplateContent|_|) name (cc : Temp) = 
        match cc.TryGet(name) with
        | Some (:? Temp as x) ->
            let c = x.Content()
            if c.IsSome then Some c.Value else None
        | _ -> None

    let (|ContentOrEmpty|) (cc : Temp) = 
        match cc.Content() with
        | Some v -> v
        | _ -> ""

    let (=>) (name : string) (value : #obj) = name,box value

    let (!~) x =
        let cc = Temp()
        for (k,v) in x do cc.Dictionary.[k] <- v
        cc

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module Temp =
    open TempOperators
    let define name value (cc:Temp) =
        let cc = cc.Duplicate()
        cc.Dictionary.[name] <- value
        cc
    let defineAll kvps (cc : Temp) = 
        let cc = cc.Duplicate()
        for (k,v) in kvps do
            cc.Dictionary.[k] <- v
        cc
    let addIgnore name value (cc : Temp) = 
        let cc = cc.Duplicate()
        if cc.Dictionary.ContainsKey name then
            ()
        else
            cc.Dictionary.[name] <- value
        cc
    let addIgnoreAll kvps (cc : Temp) = 
        let cc = cc.Duplicate()
        for (k,v) in kvps do
            if cc.Dictionary.ContainsKey k then
                ()
            else
                cc.Dictionary.[k] <- v
        cc
        
    let toStringOrDefault def (cc : Temp) = 
        match cc.Content() with
        | Some v -> v
        | None -> def
    let toString (cc : Temp) = toStringOrDefault "" cc
    let toStringOption (cc : Temp) = 
        match cc.Content() with
        | Some v -> Some v
        | None -> None
    let empty<'a> = Temp()
    let text(txt : string) = Temp(txt)
    let ofBuildOption (f : Temp -> string option) = Temp(f)
    let ofBuild (f : Temp -> string) = Temp(f >> Some)
    let withBuild (f : Temp -> string option) (cc:Temp) = 
        let cc = cc.Duplicate()
        cc.Build <- f
        cc
    let formatter fmt (cc : Temp) = 
        let cc = cc.Duplicate()
        cc.Formatters.Add(fmt)
        cc
    let onContent f (cc : Temp) = 
        let x = cc.Duplicate()
        x.Build <- cc.Build >> Option.map f
        x
    let indent cc = onContent (fun str -> "    " + str.Replace("\n", "\n    ")) cc
    let onMultiline f cc = onContent (fun str -> if str.Contains("\n") then f str else str) cc
    let indentOnMultiline cc = onMultiline (fun str -> "    " + str.Replace("\n", "\n    ")) cc
    let surround a b cc = onContent (fun str -> a + str + b) cc
    let appendString str cc = onContent (fun x -> x + str) cc
    let quote cc = surround "\"" "\"" cc
    let singleQuote cc = surround "\'" "\'" cc
    let angleBracket cc = surround "<" ">" cc
    let roundBracket cc = surround "(" ")" cc
    let curlyBrace cc = surround "{" "}" cc
    let squareBracket cc = surround "[" "]" cc
    let sepAll sep (cc : Temp list) = 
        let build (x : Temp) (cc : Temp) = cc |> addIgnoreAll(x.Dictionary |> Seq.map(fun kvp -> kvp.Key,kvp.Value)) |> toString
        Temp(fun x -> cc |> List.map (build x) |> String.concat sep |> Some)
    let sep sep (cc : Temp list) = 
        let build (x : Temp) (cc : Temp) = 
            cc |> addIgnoreAll(x.Dictionary |> Seq.map(fun kvp -> kvp.Key,kvp.Value)) |> toStringOption
        Temp(fun x -> cc |> List.choose (build x) |> String.concat sep |> Some)
    let concat (cc : Temp list) = sep "" cc
    let lines (cc : Temp list) = sep "\r\n" cc
    let filterValid (l : Temp list) = l |> List.choose (fun x -> if x.Content().IsSome then Some x else None)

    let replaceMarker name = ofBuild (function AsStringOrEmpty name x -> x)
    let replaceMarkerAnd name f = ofBuild (function AsStringOrEmpty name x -> f x)
open TempOperators

let innert = Temp.text "asdf"

innert.Format innert

let t = 
    [
        yield Temp.text "Hello "
        yield Temp.ofBuild (function AsString "Name" x -> printfn "name : %A" x; x |> Temp.text |> Temp.quote |> Temp.toString | _ -> "")
        yield Temp.replaceMarker "sd"
        yield Temp.text "!"
    ]
    |> Temp.concat


let do_ expr =
    [
        Temp.text "do"
        Temp.ofBuild
            (fun _ ->
                expr 
                |> Temp.onContent 
                     (fun str -> 
                         if str.Contains("\n") then 
                             "\r\n" + str
                         else " " + str)
                |> Temp.indentOnMultiline
                |> Temp.toString)
    ] |> Temp.concat
    
    
let let_ name value = 
    [
        name |> Temp.onContent (fun name -> "let " + name + " =")
        Temp.ofBuild
            (fun _ ->
                value 
                |> Temp.onContent 
                     (fun str -> 
                         if str.Contains("\n") then 
                             "\r\n" + str
                         else " " + str)
                |> Temp.indentOnMultiline
                |> Temp.toString)
    ] |> Temp.concat

let tuple items = items |> Temp.sep ", " |> Temp.roundBracket

let list items = items |> Temp.sep "; " |> Temp.squareBracket

let listMultiline items = 
    [
        Temp.text "[ " 
        items |> Temp.sep "\r\n  "
        Temp.text " ]"
    ] |> Temp.concat

let array items = items |> Temp.sep "; " |> Temp.surround "[|" "|]"

let arrayMultiline items = 
    [
        Temp.text "[| " 
        items |> Temp.sep "\r\n   "
        Temp.text " |]"
    ] |> Temp.concat


let call name args = 
    Temp.ofBuild
        (fun t ->
            let name = name |> Temp.toString
            let args = args |> List.map Temp.toString
            if args.Length = 1 && args.[0].StartsWith "(" then
                name +  args.[0]
            else
                name + " " + (args |> String.concat " ")
        )

let fun_ args body = 
    [
        Temp.text "fun "
        args |> Temp.sep " "
        Temp.text " ->"
        Temp.ofBuild(fun _ ->
            body 
            |> Temp.onContent 
                 (fun str -> 
                     if str.Contains("\n") then 
                         "\r\n" + str
                     else " " + str)
            |> Temp.indentOnMultiline
            |> Temp.toString
        )
    ] |> Temp.concat

let callMethod instance name args = 
    let name = 
        [
            instance
            Temp.text "."
            name
        ] |> Temp.concat
    call name args


let inline(!@) txt = txt |> string |> Temp.text
let inline (!&) lines = lines |> Temp.sep "\r\n"

let bracket x = 
    x
    |> Temp.onContent 
         (fun str -> 
             if str.Contains("\n") then 
                 "( " + str.Replace("\r\n","\r\n  ") + " )"
             else "(" + str + ")")
    

callMethod !@"crap" !@"poo" [tuple [!@1; !@2]] |> Temp.toString |> printfn "%s"



call !@"add" [!@1; !@2] |> Temp.toString
call !@"add" [tuple [!@1; !@2]] |> Temp.toString

let (!%) x = bracket x

!% !@ 1 |> Temp.toString



list [!@1; !@2; !@3; !@4] |> Temp.toString
listMultiline [!@1; !@2; !@3; !@4] |> Temp.toString |> printfn "%s"

array [!@1; !@2; !@3; !@4] |> Temp.toString
arrayMultiline [!@1; !@2; !@3; !@4] |> Temp.toString |> printfn "%s"



fun_    [!@"a"; !@"b"]  !&[
            let_ !@"a" !@12
            let_ !@"b" !@13
            do_ !@"printfn \"hi\""
            let_ (tuple [!@"a"; !@"b"]) !@"1,2"
            Temp.text "a + b"
        ] 
|> bracket |> Temp.toString |> printfn "%s"

type ParseTemp = 
    | ParseText of string
    | ParseBlock of ParseTemp list

let parseTempString s = 
    let chars = s |> Seq.toArray
    let rec mainLoop i (text : Text.StringBuilder) acc =
        if i >= chars.Length - 1 then
            if text.Length = 0 then
                acc |> List.rev
            else
                ParseText (text.ToString()) :: acc |> List.rev
        else
            if chars.[i] = '{' && chars.[i + 1] = '{' then
                if chars.[i+2] = '{' then
                    text.Append("{{") |> ignore
                    mainLoop (i + 3) text acc
                else
                    let block, i = blockLoop (i + 2) (Text.StringBuilder()) []
                    let txt = text.ToString() |> ParseText
                    text.Clear() |> ignore
                    mainLoop i text (block :: txt :: acc)
            else
                text.Append chars.[i] |> ignore
                mainLoop (i + 1) text acc

    and blockLoop i (block : Text.StringBuilder) acc = 
        if i >= chars.Length - 1 then
            failwith "Unfinished block at the end of string"
        else
            if chars.[i] = '{' && chars.[i + 1] = '{' then
                if chars.[i+2] = '{' then
                    block.Append("{{") |> ignore
                    blockLoop (i + 3) block acc
                else
                    let block2, i = blockLoop (i + 2) (Text.StringBuilder()) []
                    let txt = block.ToString() |> ParseText
                    block.Clear() |> ignore
                    blockLoop i block (block2 :: txt :: acc)
            elif chars.[i] = '}' && chars.[i + 1] = '}' then
                if i + 2 = chars.Length || chars.[i+2] <> '}' then
                    let txt = block.ToString() |> ParseText
                    (txt :: acc |> List.rev |> ParseBlock), i + 2
                else
                    block.Append("}}") |> ignore
                    blockLoop (i + 3) block acc
            else
                block.Append chars.[i] |> ignore
                blockLoop (i + 1) block acc
    mainLoop 0 (Text.StringBuilder()) []


let s = """fun {{args}} -> {{body}}"""

let rec parseBlockString = function ParseText txt -> txt | ParseBlock l -> l |> List.map parseBlockString |> String.concat ""


parseTempString s
|> List.map 
    (function
     | ParseText txt -> txt |> Temp.text
     | x -> parseBlockString x |> Temp.replaceMarker)
|> Temp.concat 
|> Temp.define "args" !@"a b"
|> Temp.define "body" !@"a + b"
|> Temp.toString
|> printfn "%s"


        
[
    let_ (Temp.text "crap") !&[
            let_ !@"a" !@12
            let_ !@"b" !@13
            do_ !@"printfn \"hi\""
            let_ (tuple [!@"a"; !@"b"]) !@"1,2"
            Temp.text "a + b"
        ]
]
|> Temp.sep "\r\n"
|> Temp.toString


t
|> Temp.define "Name" "poo"
//|> Temp.define "sd" innert 
|> Temp.toString

let q = 
    [
        Temp.text "Crap "
        Temp.ofBuild (function AsStringOrEmpty "Name" x -> x |> Temp.text |> Temp.quote |> Temp.toString )
        Temp.text "?"
        t
    ]
    |> Temp.sep "\r\n"
    |> Temp.indent
    |> Temp.indent

q.Content()
q
|> Temp.define "Name" "POO"
|> Temp.toString
|> printfn "%s"

t 
|> Temp.define "Name" "POO"
|> Temp.toString