1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135:

open System open FParsec open TypeShape open TypeShape_Utils type Parser < ' T > = Parser < ' T , unit > let inline delay ( f : unit -> ' T ) : Parser < ' T > = fun _ -> Reply ( f ()) let spaced p = between spaces spaces p let ( <*> ) ( f : Parser < ' T -> ' S > ) ( t : Parser < ' T > ) : Parser < ' S > = parse { let! tv = t let! fv = f return fv tv } /// Generates a parser for supplied type let rec genParser < ' T > () : Parser < ' T > = let ctx = new RecTypeManager () genParserCached < ' T > ctx and private genParserCached < ' T > ( ctx : RecTypeManager ) : Parser < ' T > = match ctx . TryFind < Parser < ' T > > () with | Some p -> p | None -> // create a delayed uninitialized instance for recursive type definitions let _ = ctx . CreateUninitialized < Parser < ' T > > ( fun c s -> c . Value s ) let p = genParserAux < ' T > ctx ctx . Complete ( spaced p ) and private genParserAux < ' T > ( ctx : RecTypeManager ) : Parser < ' T > = let token str = spaced ( pstring str ) > > % () let paren p = between ( pchar '(' ) ( pchar ')' ) ( spaced p ) let wrap ( p : Parser < ' a > ) = unbox < Parser < ' T > > ( spaced p ) let mkMemberParser ( shape : IShapeWriteMember < ' Class > ) = shape . Accept { new IWriteMemberVisitor < ' Class , Parser < ' Class -> ' Class > > with member __ . Visit ( shape : ShapeWriteMember < ' Class , ' Field > ) = let fp = genParserCached < ' Field > ctx fp |>> fun f dt -> shape . Inject dt f } let combineMemberParsers ( init : Parser < ' Class > ) ( injectors : Parser < ' Class -> ' Class > []) ( separator : Parser < ' Sep > ) = match Array . toList injectors with | [] -> init | hd :: tl -> List . fold ( fun acc i -> ( separator > > . i ) <*> acc ) ( hd <*> init ) tl match shapeof < ' T > with | Shape . Unit -> wrap ( paren spaces ) | Shape . Bool -> wrap ( stringReturn "true" true <|> stringReturn "false" false ) | Shape . Byte -> wrap ( puint8 ) | Shape . Int32 -> wrap ( pint32 ) | Shape . Int64 -> wrap ( pint64 ) | Shape . String -> wrap ( between ( pchar '\"' ) ( pchar '\"' ) ( manySatisfy (( <> ) '\"' ))) | Shape . FSharpOption s -> s . Accept { new IFSharpOptionVisitor < Parser < ' T > > with member __ . Visit < ' t > () = let tp = genParserCached < ' t > ctx |>> Some let nP = stringReturn "None" None let vp = attempt ( paren tp ) <|> tp let sP = token "Some" > > . vp wrap ( nP <|> sP ) } | Shape . FSharpList s -> s . Accept { new IFSharpListVisitor < Parser < ' T > > with member __ . Visit < ' t > () = let tp = genParserCached < ' t > ctx let sep = pchar ';' let lp = between ( pchar '[' ) ( pchar ']' ) ( sepBy tp sep ) wrap lp } | Shape . Array s when s . Rank = 1 -> s . Accept { new IArrayVisitor < Parser < ' T > > with member __ . Visit < ' t > _ = let tp = genParserCached < ' t > ctx let sep = pchar ';' let lp = between ( pstring "[|" ) ( pstring "|]" ) ( sepBy tp sep ) wrap ( lp |>> Array . ofList ) } | Shape . Tuple ( :? ShapeTuple < ' T > as shape ) -> let init = delay shape . CreateUninitialized let eps = shape . Elements |> Array . map mkMemberParser let composed = combineMemberParsers init eps ( pchar ',' ) paren composed | Shape . FSharpRecord ( :? ShapeFSharpRecord < ' T > as shape ) -> let init = delay shape . CreateUninitialized let fps = shape . Fields |> Array . map ( fun f -> token f . Label > > . pchar '=' > > . mkMemberParser f ) let composed = combineMemberParsers init fps ( pchar ';' ) between ( pchar '{' ) ( pchar '}' ) composed | Shape . FSharpUnion ( :? ShapeFSharpUnion < ' T > as shape ) -> let mkUnionCaseParser ( case : ShapeFSharpUnionCase < ' T > ) = let caseName = pstring case . CaseInfo . Name let init = delay case . CreateUninitialized match case . Fields |> Array . map mkMemberParser with | [||] -> caseName > > . init | fps -> let composed = combineMemberParsers init fps ( pchar ',' ) let valueP = if fps . Length = 1 then paren composed <|> composed else paren composed caseName > > . spaces > > . valueP shape . UnionCases |> Array . map mkUnionCaseParser |> choice | _ -> failwithf "unsupported type ' %O '" typeof < ' T > /// Generates a string parser for given type let mkParser < ' T > () : string -> ' T = let fp = genParser < ' T > () . >> eof fun inp -> match run fp inp with | Success ( r ,_,_) -> r | Failure ( msg ,_,_) -> failwithf "Parse error: %s " msg