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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.