Parser that folds over stream with a state record

foldparser.fsx

#r "../../../packages/fparsec/lib/net40-client/fparseccs.dll"
#r "../../../packages/fparsec/lib/net40-client/fparsec.dll"
open System

Environment.CurrentDirectory <- __SOURCE_DIRECTORY__

open FParsec
open FParsec.Primitives

let (^) = (<|)

let [<Literal>] Solfolguid = "2150E333-8FDC-42A3-9474-1A3956D46DE8"
let solutionFolderGuid = Guid "2150E333-8FDC-42A3-9474-1A3956D46DE8"

let (|InvariantEqual|_|) (str:string) arg =
  if String.Compare(str, arg, StringComparison.OrdinalIgnoreCase) = 0
  then Some () else None

type PlatformType =
    | X86 |  X64 | AnyCPU

    override self.ToString () = self |> function
        | X86     -> "X86"
        | X64     -> "X64"
        | AnyCPU  -> "AnyCPU"

    static member Parse text = text |> function
        | InvariantEqual "X86"     -> X86
        | InvariantEqual "X64"     -> X64
        | InvariantEqual "Any CPU"
        | InvariantEqual "AnyCPU"  -> AnyCPU
        | _ ->
            failwithf "Could not parse '%s' into a `PlatformType`" text

type SolutionItem = { Name:string; Path:string }

type SolutionFolder = 
    {   ProjectTypeGuid     : Guid  // {2150E333-8FDC-42A3-9474-1A3956D46DE8}
        Name                : string
        Path                : string
        Guid                : Guid
        SolutionItems       : SolutionItem list
    }

type Project =
    {   ProjectTypeGuid     : Guid
        Name                : string
        Path                : string
        Guid                : Guid
        Dependecies         : Guid list
    }

type SolutionConfiguration = { Name:string; Platform:PlatformType }

type BuildProperty = 
    | ActiveCfg | Build0
    static member Parse text = text |> function
        | InvariantEqual "ActiveCfg" -> ActiveCfg
        | InvariantEqual "Build.0" -> Build0
        | _ ->
            failwithf "Could not parse '%s' into a `PlatformType`" text


type ProjectConfiguration =
    {   ProjectGuid   : Guid
        ConfigName    : string
        BuildProperty : BuildProperty
        Platform      : PlatformType
    }

type SolutionProperty = { Name:string; Value:string }

type NestedProject = { Project : Guid; Parent : Guid }

type Solution = 
    {   Header : string
        Folders : SolutionFolder list
        Projects : Project List
        SolutionConfigurationPlatforms : SolutionConfiguration list
        ProjectConfigurationPlatforms : ProjectConfiguration list
        SolutionProperties : SolutionProperty list
        NestedProjects : NestedProject list
    }
    static member Empty = 
        {   Header  = ""
            Folders = []
            Projects = []
            SolutionConfigurationPlatforms = []
            ProjectConfigurationPlatforms = []
            SolutionProperties = []
            NestedProjects = []
        }

type UserState = unit
type Parser<'t> = Parser<'t, UserState>

let ``{`` : Parser<_> = pchar '{'
let ``}`` : Parser<_> = pchar '}'
let ``"`` : Parser<_> = pchar '"'
let ``(`` : Parser<_> = pchar '('
let ``)`` : Parser<_> = pchar ')'
let ``|`` : Parser<_> = skipChar '|'
let ``.`` : Parser<_> = pchar '.'

let isGuid c = isHex c || c = '-'

let pEq     : Parser<_> = pchar '='
let skipEqs : Parser<_> =  spaces >>. pchar '=' >>. spaces
let skipCom : Parser<_> =  spaces >>. pchar ',' >>. spaces

let notspace: Parser<_> = many1Satisfy ^ isNoneOf [ '\t'; ' '; '\n'; '\r'; '\u0085';'\u2028';'\u2029' ]

let pSection : Parser<_> = pstring "Section"
let pProject : Parser<_> = pstring "Project"
let pEndProject : Parser<_> = pstring "EndProject" .>> notFollowedBy pSection
let pGlobal : Parser<_> = pstring "Global"
let pEndGlobal : Parser<_> = pstring "EndGlobal" .>> notFollowedBy pSection
let pProjectSection : Parser<_> = pstring "ProjectSection"
let pEndProjectSection : Parser<_> = pstring "EndProjectSection" 
let pGlobalSection : Parser<_> = pstring "GlobalSection"
let pEndGlobalSection : Parser<_> = pstring "EndGlobalSection"

let pSolutionHeader = manyCharsTill anyChar ^ lookAhead ^ pProject <|> pGlobal

let pGuid: Parser<Guid> = 
    let psr = (between ``{`` ``}`` ^ manySatisfy isGuid) 
    fun stream  ->
        let (reply: _ Reply) = psr stream
        if  reply.Status <> Ok then Reply(Error,reply.Error) else
        try Guid.Parse reply.Result |> Reply 
        with ex -> Reply(Error,expected ex.Message)

let quoteGuid = ``"`` >>. pGuid .>> ``"``

let projGuid: Parser<Guid> = ``(`` >>. quoteGuid .>> ``)``

let quoted: Parser<_> = between ``"`` ``"`` ^ manyCharsTill anyChar ^ lookAhead ``"``

let projectHeading =  skipEqs >>. (quoted .>> skipCom) .>>. (quoted .>> skipCom) .>>. quoteGuid .>> spaces

let pitem = spaces >>. notspace .>> skipEqs .>>. notspace .>> spaces

let dependency = spaces >>. pGuid .>> skipRestOfLine true .>> spaces


let pSolutionConfigLine =
    spaces >>. manyCharsTill anyChar ``|`` .>>. (manyCharsTill anyChar  pEq)  .>> skipRestOfLine true
    |>> fun (name, plat) -> 
    {   SolutionConfiguration.Name = name
        Platform = plat.Trim() |> PlatformType.Parse }


let pProjectConfigLine =
    (spaces >>. pGuid .>> ``.``)
    .>>. (many1CharsTill anyChar ``|``)
    .>>. (many1CharsTill anyChar ``.``)
    .>>. (many1CharsTill anyChar ^ (spaces .>> pEq)) .>> skipRestOfLine true
    |>> fun (((guid,name),plat),prop) ->
        {   ProjectGuid = guid
            ConfigName = name
            BuildProperty = BuildProperty.Parse ^ prop.Trim()
            Platform = PlatformType.Parse  ^ plat.Trim()  }

let pNestedProjectLine : Parser<_> =
    (spaces >>. pGuid .>> skipEqs) .>>. pGuid  .>> skipRestOfLine true
    |>> fun (proj, parent) -> { Project = proj ; Parent = parent }


let pPropertyLine = pitem |>> fun (n,v) -> { Name = n ; Value = v }

let spwork =  manyTill (spaces >>. pPropertyLine       .>> spaces) ^ lookAhead pEndGlobalSection
let scwork =  manyTill (spaces >>. pSolutionConfigLine .>> spaces) ^ lookAhead pEndGlobalSection
let pcwork =  manyTill (spaces >>. pProjectConfigLine  .>> spaces) ^ lookAhead pEndGlobalSection
let npwork =  manyTill (spaces >>. pNestedProjectLine  .>> spaces) ^ lookAhead pEndGlobalSection

let inline insertBuilder psr (insfn:Solution->Reply<_>-> _) (sol:Solution) : Parser<_> =
    fun stream -> 
        let (reply: _ Reply) = psr stream
        if reply.Status <> Ok  then Reply (Error, reply.Error) else
        insfn sol reply |> Reply   

let insertProperties (sol:Solution) : Parser<_> =
    sol |> insertBuilder spwork (fun sol reply ->
        { sol with 
            SolutionProperties = List.append sol.SolutionProperties reply.Result})

let insertNestedProjects (sol:Solution) : Parser<_> =
    sol |> insertBuilder npwork (fun sol reply ->
        { sol with 
            NestedProjects = List.append sol.NestedProjects reply.Result})

let insertProjectConfigs (sol:Solution) : Parser<_> =
    sol |> insertBuilder pcwork (fun sol reply ->
        { sol with 
            ProjectConfigurationPlatforms = List.append sol.ProjectConfigurationPlatforms reply.Result})

let insertSolutionConfigs (sol:Solution) : Parser<_> =
    sol |> insertBuilder scwork (fun sol reply ->
        { sol with 
            SolutionConfigurationPlatforms = List.append sol.SolutionConfigurationPlatforms reply.Result})

let sectionSwitch (sol:Solution) =
    between (spaces >>. pGlobalSection) (spaces >>. pEndGlobalSection)  <|
    fun (stream: _ CharStream) ->
        match stream.PeekString 10 with
        | "(ProjectCo" -> (skipRestOfLine true >>. insertProjectConfigs  sol) stream
        | "(SolutionC" -> (skipRestOfLine true >>. insertSolutionConfigs sol) stream
        | "(SolutionP" -> (skipRestOfLine true >>. insertProperties      sol) stream
        | "(NestedPro" -> (skipRestOfLine true >>. insertNestedProjects  sol) stream
        | s -> Reply (Error, expected <| sprintf 
                "Inside Global Property ::\ncould not parse unexpected string -'%s'\n at Ln: %d Col: %d"
                    s stream.Line stream.Column)


let inline folder (foldParser: _ -> Parser<_>) (endpsr:Parser<_>) seed =
    let rec loop acc (stream: _ CharStream) =
        let state = stream.State
        let (reply: _ Reply) = foldParser acc ^ stream
        if reply.Status = Ok then loop reply.Result stream else
        stream.BacktrackTo state 
        let (checkEnd: _ Reply) = endpsr stream
        if checkEnd.Status = Ok then 
            stream.BacktrackTo state; Reply acc
        else Reply (Error, checkEnd.Error)
    loop seed


let foldsec sol :Parser<_> = folder sectionSwitch (spaces >>. pEndGlobal) sol
    
let parseSections (sol:Solution) : Parser<_> =
    between (spaces >>. pGlobal) (spaces >>. pEndGlobal) <| foldsec sol

let gtext = """
Global
    GlobalSection(SolutionConfigurationPlatforms) = preSolution
        Debug|Any CPU = Debug|Any CPU
        Release|Any CPU = Release|Any CPU
    EndGlobalSection
    GlobalSection(ProjectConfigurationPlatforms) = postSolution
        {FBAF8C7B-4EDA-493A-A7FE-4DB25D15736F}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
        {FBAF8C7B-4EDA-493A-A7FE-4DB25D15736F}.Debug|Any CPU.Build.0 = Debug|Any CPU
        {FBAF8C7B-4EDA-493A-A7FE-4DB25D15736F}.Release|Any CPU.ActiveCfg = Release|Any CPU
        {FBAF8C7B-4EDA-493A-A7FE-4DB25D15736F}.Release|Any CPU.Build.0 = Release|Any CPU
        {D28CE980-2040-4B62-ACA6-F07EB6B31920}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
        {D28CE980-2040-4B62-ACA6-F07EB6B31920}.Debug|Any CPU.Build.0 = Debug|Any CPU
        {D28CE980-2040-4B62-ACA6-F07EB6B31920}.Release|Any CPU.ActiveCfg = Release|Any CPU
        {D28CE980-2040-4B62-ACA6-F07EB6B31920}.Release|Any CPU.Build.0 = Release|Any CPU
        {147B0E3C-C669-4666-8FBC-7F77CAC2FF36}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
        {147B0E3C-C669-4666-8FBC-7F77CAC2FF36}.Debug|Any CPU.Build.0 = Debug|Any CPU
        {147B0E3C-C669-4666-8FBC-7F77CAC2FF36}.Release|Any CPU.ActiveCfg = Release|Any CPU
        {147B0E3C-C669-4666-8FBC-7F77CAC2FF36}.Release|Any CPU.Build.0 = Release|Any CPU
    EndGlobalSection
EndGlobal
"""


runParserOnString (parseSections Solution.Empty)  () "" gtext