1
\$\begingroup\$

I'm in the beginning stages of rewriting the model layer of my VBA Sync Tool in F#, to better learn functional programming. So far I've defined:

  • A public VbaSyncMessage type for errors and other non-data messages, and an internal Piped type to move data and messages between functions.
  • A function getInitialConfig that is called from C# to build a startup configuration, reading first from isolated storage, then from a file VBASync.ini in the current directory (if that file exists), and then from command-line options and arguments.

An INI file looks like this:

[General]
ActionType=Publish # or Extract
FolderPath="VBA"
FilePath="My text add-in.xla"
AutoRun=true

[DiffTool]
Path="C:\Program Files\TortoiseHg\lib\kdiff3.exe"
Parameters=""{OldFile}" "{NewFile}""

Infrastructure.fs:

namespace VBASync.Model

open System
open System.IO.IsolatedStorage

type public VbaSyncMessage =
| CouldNotOpenIsolatedStorage of Exception
| CouldNotReadFile of string * Exception
| CouldNotReadIsolatedStorageFile of string * Exception
| CouldNotWriteIsolatedStorageFile of string * Exception
| InvalidIniLine of int * string
| UnrecognizedSwitch of string
| IniFileNotFound of string

type internal Piped<'TValue> =
| PipeValue of 'TValue * VbaSyncMessage list
| PipeFail of VbaSyncMessage list

[<RequireQualifiedAccess>]
module internal Piped =
    let internal apply application x =
        match application, x with
        | PipeValue (av, ams), PipeValue (xv, xms) -> PipeValue (av xv, ams @ xms)
        | PipeFail ams, PipeFail xms -> PipeFail (ams @ xms)
        | PipeFail ams, PipeValue (_, xms) -> PipeFail (ams @ xms)
        | PipeValue(_, ams), PipeFail xms -> PipeFail (ams @ xms)

    let internal bind binder x =
        match x with
        | PipeValue (xv, xms) ->
            match binder xv with
            | PipeValue (bv, bms) -> PipeValue (bv, bms @ xms)
            | PipeFail bms -> PipeFail (bms @ xms)
        | PipeFail xms -> PipeFail xms

    let internal map mapping x =
        match x with
        | PipeValue (v, ms) -> PipeValue (mapping v, ms)
        | PipeFail ms -> PipeFail ms

    let internal ret x = PipeValue (x, [ ])

    let internal tee action x =
        match x with
        | PipeValue (v, ms) -> action v; x
        | PipeFail ms -> PipeFail ms

    let internal toValue doMsg ifFail x =
        match x with
        | PipeValue (v, ms) -> List.iter doMsg ms; v
        | PipeFail ms -> List.iter doMsg ms; ifFail

    let internal warnBind binder x =
        // like bind, but if the binder fails, return the original value plus the binder's messages
        match x with
        | PipeValue (xv, xms) ->
            match binder xv with
            | PipeValue (bv, bms) -> PipeValue (bv, bms)
            | PipeFail bms -> PipeValue (xv, bms @ xms)
        | PipeFail _ -> x

module internal IsolatedStorageFile =
    let internal openFile path mode (store: IsolatedStorageFile) = store.OpenFile (path, mode)
    let internal fileExists path (store: IsolatedStorageFile) = store.FileExists path

module internal String =
    let internal joinLines (xs: string list) = String.Join (Environment.NewLine, xs)
    let internal splitLines (x: string) = x.Split ([| Environment.NewLine |], StringSplitOptions.None) |> Array.toList

SessionTypes.fs:

namespace VBASync.Model

open System

type public ActionType = Extract | Publish

type public DiffTool = { Path: string;
                         Parameters: string }

type public Session = { Action: ActionType;
                        DiffTool: DiffTool;
                        FilePath: string;
                        FolderPath: string;
                        AutoRun: bool }

SessionAccessType.fs:

namespace VBASync.Model

open System
open System.IO.IsolatedStorage

type internal ConfigIni =
| IniFile of string
| IniIsolatedStorage of Piped<IsolatedStorageFile> * string
| IniTest of string list

SessionAccessImpl.fs:

namespace VBASync.Model

open System
open System.IO
open System.IO.IsolatedStorage
open System.Text
open System.Text.RegularExpressions

module public ConfigStorage =
    let internal defaults = { Action = Extract; DiffTool = { Path = ""; Parameters = "\"{OldFile}\" \"{NewFile}\"" };
                              FilePath = ""; FolderPath = ""; AutoRun = false }

    let private (|IniIgnored|_|) x =
        let m = Regex.Match (x, @"^\s*([#[[]|$)") // currently lines like "[General]" are ignored
        if m.Success then Some () else None

    let private (|IniString|_|) x =
        let m = if (Regex.Match (x, @"^\s*\w+\s*=\s*['""]")).Success then
                    // match a double- or single-quoted string
                    Regex.Match (x, @"^\s*(?'key'\w+)\s*=\s*([""'])(?'value'.*?)\1\s*(#.*)?$",
                                    RegexOptions.IgnoreCase ||| RegexOptions.CultureInvariant)
                else
                    // match an unquoted string
                    Regex.Match (x, @"^\s*(?'key'\w+)\s*=\s*(?'value'[^#]+?)\s*(#.*)?$",
                                    RegexOptions.IgnoreCase ||| RegexOptions.CultureInvariant)
        if m.Success then Some (m.Groups.["key"].Value.ToUpperInvariant(), m.Groups.["value"].Value) else None

    let private readLinesFromFile path =
        if File.Exists path then
            try path |> File.ReadAllLines |> Array.toList |> Piped.ret
            with ex -> PipeFail [ CouldNotReadFile (path, ex) ]
        else Piped.ret [ ]

    let private readLinesFromStorage path store =
        try
            if IsolatedStorageFile.fileExists path store then
                use strm = new IsolatedStorageFileStream(path, FileMode.Open, FileAccess.Read, store)
                let buf = Array.zeroCreate<byte> (int strm.Length)
                strm.Read (buf, 0, int strm.Length) |> ignore
                buf |> Encoding.UTF8.GetString |> String.splitLines |> Piped.ret
            else Piped.ret [ ]
        with ex -> PipeFail [ CouldNotReadIsolatedStorageFile (path, ex) ]

    let private writeLinesToStorage path store lines =
        try
            use strm = IsolatedStorageFile.openFile path FileMode.Create store
            let buf = lines |> String.joinLines |> Encoding.UTF8.GetBytes
            strm.Write (buf, 0, buf.Length)
            Piped.ret ()
        with ex -> PipeFail [ CouldNotWriteIsolatedStorageFile (path, ex) ]

    let internal augmentConfigWithIni ini getFullConfig config =
        let rec doLines xn xs cfg =
            let doNextLine = doLines (xn + 1)
            match xs with
            | [ ] -> Piped.ret cfg
            | IniIgnored :: xs -> doNextLine xs cfg // currently lines like "[General]" are ignored
            | IniString ("ACTIONTYPE", v) as x :: xs ->
                if getFullConfig then
                    match v.ToUpperInvariant() with
                    | "EXTRACT" -> doNextLine xs { cfg with Action = Extract }
                    | "PUBLISH" -> doNextLine xs { cfg with Action = Publish }
                    | _ -> PipeFail [ InvalidIniLine (xn, x) ]
                else doNextLine xs cfg
            | IniString ("FOLDERPATH", v) :: xs ->
                doNextLine xs (if getFullConfig then { cfg with FolderPath = v } else cfg)
            | IniString ("FILEPATH", v) :: xs ->
                doNextLine xs (if getFullConfig then { cfg with FilePath = v } else cfg)
            | IniString ("AUTORUN", v) as x :: xs ->
                if getFullConfig then
                    match v.ToUpperInvariant () with
                    | "TRUE" | "YES" | "1" -> doNextLine xs { cfg with AutoRun = true }
                    | "FALSE" | "NO" | "0" -> doNextLine xs { cfg with AutoRun = false }
                    | _ -> PipeFail [ InvalidIniLine (xn, x) ]
                else doNextLine xs cfg
            | IniString ("PATH", v) :: xs -> doNextLine xs { cfg with DiffTool = { cfg.DiffTool with Path = v } }
            | IniString ("PARAMETERS", v) :: xs -> doNextLine xs {cfg with DiffTool = { cfg.DiffTool with Parameters = v } }
            | x :: _ -> PipeFail [ InvalidIniLine (xn, x) ]
        let lines =
            match ini with
            | IniFile path -> readLinesFromFile path
            | IniIsolatedStorage (pipedStore, fileName) -> Piped.bind (readLinesFromStorage fileName) pipedStore
            | IniTest testLines -> Piped.ret testLines
        lines |> Piped.bind (fun xs -> doLines 1 xs config)

    let rec internal augmentConfigWithArgs args config =
        match args with
        | [] -> Piped.ret config
        | "-r" :: xs -> augmentConfigWithArgs xs  { config with AutoRun = true }
        | "-x" :: xs -> augmentConfigWithArgs xs  { config with Action = Extract }
        | "-p" :: xs -> augmentConfigWithArgs xs  { config with Action = Publish }
        | "-f" :: x :: xs -> augmentConfigWithArgs xs  { config with FilePath = x }
        | "-d" :: x :: xs -> augmentConfigWithArgs xs  { config with FolderPath = x }
        | x :: xs when x.StartsWith "-" -> PipeFail [ UnrecognizedSwitch x ]
        | x :: xs ->
            if File.Exists x then
                Piped.bind (augmentConfigWithArgs xs) (augmentConfigWithIni (IniFile x) true config)
            else
                PipeFail [ IniFileNotFound x ]

    let private getStore () =
        try Piped.ret (IsolatedStorageFile.GetStore (IsolatedStorageScope.User ||| IsolatedStorageScope.Assembly,
                                                        null, null))
        with ex -> PipeFail [ CouldNotOpenIsolatedStorage ex ]

    let public getInitialConfig (doMsg: Action<VbaSyncMessage>, args) =
        // only the diff tool settings from the isolated storage file will be used at first;
        // the user can choose to import all settings later
        Piped.ret defaults |> Piped.warnBind (augmentConfigWithIni (IniIsolatedStorage (getStore (), "LastSession.ini")) false)
                            |> Piped.warnBind (augmentConfigWithIni (IniFile "VBASync.ini") true)
                            |> Piped.warnBind (augmentConfigWithArgs (Seq.toList args))
                            |> Piped.toValue (doMsg.Invoke) defaults

    let public getPreviousConfig (doMsg: Action<VbaSyncMessage>) =
        Piped.ret defaults |> Piped.bind (augmentConfigWithIni (IniIsolatedStorage (getStore (), "LastSession.ini")) true)
                            |> Piped.toValue (doMsg.Invoke) defaults

    let public saveToPreviousConfig session =
        let lines = [ sprintf "ActionType=%s" (if session.Action = Extract then "Extract" else "Publish");
                        sprintf "FolderPath=\"%s\"" session.FolderPath;
                        sprintf "FilePath=\"%s\"" session.FilePath;
                        "";
                        "[DiffTool]";
                        sprintf "Path=\"%s\"" session.DiffTool.Path;
                        sprintf "Parameters=\"%s\"" session.DiffTool.Parameters; ]
        match getStore () |> Piped.bind (fun x -> writeLinesToStorage "LastSession.ini" x lines) with
        | PipeValue (_, ms) -> List.toSeq ms
        | PipeFail ms -> List.toSeq ms
Improve this question
\$\endgroup\$

0

Reset to default

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.