Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Parser that folds over stream with a state record
#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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment