CodeMirror

Module:       locators-internals

Synopsis:     Abstract modeling of locations

Author:       Andy Armstrong

Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.

              All rights reserved.

License:      See License.txt in this distribution for details.

Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND

​

define open generic locator-server

    (locator :: <locator>) => (server :: false-or(<server-locator>));

define open generic locator-host

    (locator :: <locator>) => (host :: false-or(<string>));

define open generic locator-volume

    (locator :: <locator>) => (volume :: false-or(<string>));

define open generic locator-directory

    (locator :: <locator>) => (directory :: false-or(<directory-locator>));

define open generic locator-relative?

    (locator :: <locator>) => (relative? :: <boolean>);

define open generic locator-path

    (locator :: <locator>) => (path :: <sequence>);

define open generic locator-base

    (locator :: <locator>) => (base :: false-or(<string>));

define open generic locator-extension

    (locator :: <locator>) => (extension :: false-or(<string>));

​

/// Locator classes

​

define open abstract class <directory-locator> (<physical-locator>)

end class <directory-locator>;

​

define open abstract class <file-locator> (<physical-locator>)

end class <file-locator>;

​

define method as

    (class == <directory-locator>, string :: <string>)

 => (locator :: <directory-locator>)

  as(<native-directory-locator>, string)

end method as;

​

define method make

    (class == <directory-locator>,

     #key server :: false-or(<server-locator>) = #f,

          path :: <sequence> = #[],

          relative? :: <boolean> = #f,

          name :: false-or(<string>) = #f)

 => (locator :: <directory-locator>)

  make(<native-directory-locator>,

       server:    server,

       path:      path,

       relative?: relative?,

       name:      name)

end method make;

​

define method as

    (class == <file-locator>, string :: <string>)

 => (locator :: <file-locator>)

  as(<native-file-locator>, string)

end method as;

​

define method make

    (class == <file-locator>,

     #key directory :: false-or(<directory-locator>) = #f,

          base :: false-or(<string>) = #f,

          extension :: false-or(<string>) = #f,

          name :: false-or(<string>) = #f)

 => (locator :: <file-locator>)

  make(<native-file-locator>,

       directory: directory,

       base:      base,

       extension: extension,

       name:      name)

end method make;

​

/// Locator coercion

​

//---*** andrewa: This caching scheme doesn't work yet, so disable it.

define constant $cache-locators?        = #f;

define constant $cache-locator-strings? = #f;

​

define constant $locator-to-string-cache = make(<object-table>, weak: #"key");

define constant $string-to-locator-cache = make(<string-table>, weak: #"value");

​

define open generic locator-as-string

    (class :: subclass(<string>), locator :: <locator>)

 => (string :: <string>);

​

define open generic string-as-locator

    (class :: subclass(<locator>), string :: <string>)

 => (locator :: <locator>);

​

define sealed sideways method as

    (class :: subclass(<string>), locator :: <locator>)

 => (string :: <string>)

  let string = element($locator-to-string-cache, locator, default: #f);

  if (string)

    as(class, string)

  else

    let string = locator-as-string(class, locator);

    if ($cache-locator-strings?)

      element($locator-to-string-cache, locator) := string;

    else

      string

    end

  end

end method as;

​

define sealed sideways method as

    (class :: subclass(<locator>), string :: <string>)

 => (locator :: <locator>)

  let locator = element($string-to-locator-cache, string, default: #f);

  if (instance?(locator, class))

    locator

  else

    let locator = string-as-locator(class, string);

    if ($cache-locators?)

      element($string-to-locator-cache, string) := locator;

    else

      locator

    end

  end

end method as;

​

/// Locator conditions

​

define class <locator-error> (<format-string-condition>, <error>)

end class <locator-error>;

​

define function locator-error

    (format-string :: <string>, #rest format-arguments)

  error(make(<locator-error>, 

             format-string:    format-string,

             format-arguments: format-arguments))

end function locator-error;

​

/// Useful locator protocols

​

define open generic locator-test

    (locator :: <directory-locator>) => (test :: <function>);

​

define method locator-test

    (locator :: <directory-locator>) => (test :: <function>)

  \=

end method locator-test;

​

define open generic locator-might-have-links?

    (locator :: <directory-locator>) => (links? :: <boolean>);

​

define method locator-might-have-links?

    (locator :: <directory-locator>) => (links? :: singleton(#f))

  #f

end method locator-might-have-links?;

​

define method locator-relative?

    (locator :: <file-locator>) => (relative? :: <boolean>)

  let directory = locator.locator-directory;

  ~directory | directory.locator-relative?

end method locator-relative?;

​

define method current-directory-locator?

    (locator :: <directory-locator>) => (current-directory? :: <boolean>)

  locator.locator-relative?

    & locator.locator-path = #[#"self"]

end method current-directory-locator?;

​

define method locator-directory

    (locator :: <directory-locator>) => (parent :: false-or(<directory-locator>))

  let path = locator.locator-path;

  unless (empty?(path))

    make(object-class(locator),

         server:    locator.locator-server,

         path:      copy-sequence(path, end: path.size - 1),

         relative?: locator.locator-relative?)

  end

end method locator-directory;

​

/// Simplify locator

​

define open generic simplify-locator

    (locator :: <physical-locator>)

 => (simplified-locator :: <physical-locator>);

​

define method simplify-locator

    (locator :: <directory-locator>)

 => (simplified-locator :: <directory-locator>)

  let path = locator.locator-path;

  let relative? = locator.locator-relative?;

  let resolve-parent? = ~locator.locator-might-have-links?;

  let simplified-path

    = simplify-path(path, 

                    resolve-parent?: resolve-parent?,

                    relative?: relative?);

  if (path ~= simplified-path)

    make(object-class(locator),

         server:    locator.locator-server,

         path:      simplified-path,

         relative?: locator.locator-relative?)

  else

    locator

  end

end method simplify-locator;

​

define method simplify-locator

    (locator :: <file-locator>) => (simplified-locator :: <file-locator>)

  let directory = locator.locator-directory;

  let simplified-directory = directory & simplify-locator(directory);

  if (directory ~= simplified-directory)

    make(object-class(locator),

         directory: simplified-directory,

         base:      locator.locator-base,

         extension: locator.locator-extension)

  else

    locator

  end

end method simplify-locator;

​

/// Subdirectory locator

​

define open generic subdirectory-locator

    (locator :: <directory-locator>, #rest sub-path)

 => (subdirectory :: <directory-locator>);

​

define method subdirectory-locator

    (locator :: <directory-locator>, #rest sub-path)

 => (subdirectory :: <directory-locator>)

  let old-path = locator.locator-path;

  let new-path = concatenate-as(<simple-object-vector>, old-path, sub-path);

  make(object-class(locator),

       server:    locator.locator-server,

       path:      new-path,

       relative?: locator.locator-relative?)

end method subdirectory-locator;

​

/// Relative locator

​

define open generic relative-locator

    (locator :: <physical-locator>, from-locator :: <physical-locator>)

 => (relative-locator :: <physical-locator>);

​

define method relative-locator

    (locator :: <directory-locator>, from-locator :: <directory-locator>)

 => (relative-locator :: <directory-locator>)

  let path = locator.locator-path;

  let from-path = from-locator.locator-path;

  case

    ~locator.locator-relative? & from-locator.locator-relative? =>

      locator-error

        ("Cannot find relative path of absolute locator %= from relative locator %=",

         locator, from-locator);

    locator.locator-server ~= from-locator.locator-server =>

      locator;

    path = from-path =>

      make(object-class(locator),

           path: vector(#"self"),

           relative?: #t);

    otherwise =>

      make(object-class(locator),

           path: relative-path(path, from-path, test: locator.locator-test),

           relative?: #t);

  end

end method relative-locator;

​

define method relative-locator

    (locator :: <file-locator>, from-directory :: <directory-locator>)

 => (relative-locator :: <file-locator>)

  let directory = locator.locator-directory;

  let relative-directory = directory & relative-locator(directory, from-directory);

  if (relative-directory ~= directory)

    simplify-locator

      (make(object-class(locator),

            directory: relative-directory,

            base:      locator.locator-base,

            extension: locator.locator-extension))

  else

    locator

  end

end method relative-locator;

​

define method relative-locator

    (locator :: <physical-locator>, from-locator :: <file-locator>)

 => (relative-locator :: <physical-locator>)

  let from-directory = from-locator.locator-directory;

  case

    from-directory =>

      relative-locator(locator, from-directory);

    ~locator.locator-relative? =>

      locator-error

        ("Cannot find relative path of absolute locator %= from relative locator %=",

         locator, from-locator);

    otherwise =>

      locator;

  end

end method relative-locator;

​

/// Merge locators

​

define open generic merge-locators

    (locator :: <physical-locator>, from-locator :: <physical-locator>)

 => (merged-locator :: <physical-locator>);

​

/// Merge locators

​

define method merge-locators

    (locator :: <directory-locator>, from-locator :: <directory-locator>)

 => (merged-locator :: <directory-locator>)

  if (locator.locator-relative?)

    let path = concatenate(from-locator.locator-path, locator.locator-path);

    simplify-locator

      (make(object-class(locator),

            server:    from-locator.locator-server,

            path:      path,

            relative?: from-locator.locator-relative?))

  else

    locator

  end

end method merge-locators;

​

define method merge-locators

    (locator :: <file-locator>, from-locator :: <directory-locator>)

 => (merged-locator :: <file-locator>)

  let directory = locator.locator-directory;

  let merged-directory 

    = if (directory)

        merge-locators(directory, from-locator)

      else

        simplify-locator(from-locator)

      end;

  if (merged-directory ~= directory)

    make(object-class(locator),

         directory: merged-directory,

         base:      locator.locator-base,

         extension: locator.locator-extension)

  else

    locator

  end

end method merge-locators;

​

define method merge-locators

    (locator :: <physical-locator>, from-locator :: <file-locator>)

 => (merged-locator :: <physical-locator>)

  let from-directory = from-locator.locator-directory;

  if (from-directory)

    merge-locators(locator, from-directory)

  else

    locator

  end

end method merge-locators;

​

/// Locator protocols

​

define sideways method supports-open-locator?

    (locator :: <file-locator>) => (openable? :: <boolean>)

  ~locator.locator-relative?

end method supports-open-locator?;

​

define sideways method open-locator

    (locator :: <file-locator>, #rest keywords, #key, #all-keys)

 => (stream :: <stream>)

  apply(open-file-stream, locator, keywords)

end method open-locator;

​