diff --git a/coalton.asd b/coalton.asd index bbb99ba67..9aa364d0c 100644 --- a/coalton.asd +++ b/coalton.asd @@ -45,7 +45,7 @@ (:file "utils") (:coalton-file "types") (:coalton-file "primitive-types") - (:file "classes") + (:coalton-file "classes") (:file "hash") (:file "builtin") (:coalton-file "functions") diff --git a/library/classes.coal b/library/classes.coal new file mode 100644 index 000000000..4f2aa6aa8 --- /dev/null +++ b/library/classes.coal @@ -0,0 +1,340 @@ +(package coalton-library/classes + (import + (coalton-library/types as types)) + (export + Signalable + error + Tuple + Optional Some None + Result Ok Err + Eq == + Ord LT EQ GT + <=> > < >= <= + max + min + Num + - * fromInt + Semigroup <> + Monoid mempty + Functor map + Applicative pure liftA2 + Monad >>= + >> + MonadFail fail + Alternative alt empty + Foldable fold foldr mconcat + Traversable traverse + Bifunctor bimap map-fst map-snd + sequence + Into + TryInto + Iso + Unwrappable unwrap-or-else with-default unwrap expect as-optional + default defaulting-unwrap default?)) + +;;; +;;; Signaling errors and warnings +;;; + +;; +;; Signalling errors on supported types +;; +(define-class (Signalable :a) + "Signals errors or warnings by calling their respective lisp conditions." + (error "Signal an error with a type-specific error string." (:a -> :b))) + +(define-instance (Signalable String) + (define (error str) + (lisp :a (str) + (cl:error str)))) + +;; +;; Base Types +;; + +(define-struct (Tuple :a :b) + "A heterogeneous collection of items." + (first :a) + (second :b)) + +(define-type (Optional :a) + "Represents something that may not have a value." + (Some :a) + None) + +(define-type (Result :bad :good) + "Represents something that may have failed." + ;; We write (Result :bad :good) instead of (Result :good :bad) + ;; because of the limitations of how we deal with higher-kinded + ;; types; we want to implement Functor on this. + (Ok :good) + (Err :bad)) + +;; +;; Eq +;; + +(define-class (Eq :a) + "Types which have equality defined." + (== (:a -> :a -> Boolean))) + +(define-instance (Eq types:LispType) + (define (== a b) + (lisp Boolean (a b) + (cl:equalp a b)))) + +(define-class (Eq :a => Num :a) + "Types which have numeric operations defined." + (+ (:a -> :a -> :a)) + (- (:a -> :a -> :a)) + (* (:a -> :a -> :a)) + (fromInt (Integer -> :a))) + +(define-instance (Eq Unit) + (define (== _ _) True)) + +;; +;; Ord +;; + +(repr :enum) +(define-type Ord + "The result of an ordered comparison." + LT + EQ + GT) + +(define-instance (Eq Ord) + (define (== a b) + (match (Tuple a b) + ((Tuple (LT) (LT)) True) + ((Tuple (EQ) (EQ)) True) + ((Tuple (GT) (GT)) True) + (_ False)))) + +(define-instance (Ord Ord) + (define (<=> a b) + (match (Tuple a b) + ((Tuple (LT) (LT)) EQ) + ((Tuple (LT) (EQ)) LT) + ((Tuple (LT) (GT)) LT) + ((Tuple (EQ) (LT)) GT) + ((Tuple (EQ) (EQ)) EQ) + ((Tuple (EQ) (GT)) LT) + ((Tuple (GT) (LT)) GT) + ((Tuple (GT) (EQ)) GT) + ((Tuple (GT) (GT)) EQ)))) + +(define-class (Eq :a => Ord :a) + "Types whose values can be ordered." + (<=> (:a -> :a -> Ord))) + +(declare > (Ord :a => :a -> :a -> Boolean)) +(define (> x y) + "Is `x` greater than `y`?" + (match (<=> x y) + ((GT) True) + (_ False))) + +(declare < (Ord :a => :a -> :a -> Boolean)) +(define (< x y) + "Is `x` less than `y`?" + (match (<=> x y) + ((LT) True) + (_ False))) + +(declare >= (Ord :a => :a -> :a -> Boolean)) +(define (>= x y) + "Is `x` greater than or equal to `y`?" + (match (<=> x y) + ((LT) False) + (_ True))) + +(declare <= (Ord :a => :a -> :a -> Boolean)) +(define (<= x y) + "Is `x` less than or equal to `y`?" + (match (<=> x y) + ((GT) False) + (_ True))) + +(declare max (Ord :a => :a -> :a -> :a)) +(define (max x y) + "Returns the greater element of `x` and `y`." + (if (> x y) + x + y)) + +(declare min (Ord :a => :a -> :a -> :a)) +(define (min x y) + "Returns the lesser element of `x` and `y`." + (if (< x y) + x + y)) + + ;; + ;; Haskell + ;; + +(define-class (Semigroup :a) + "Types with an associative binary operation defined." + (<> (:a -> :a -> :a))) + +(define-class (Semigroup :a => Monoid :a) + "Types with an associative binary operation and identity defined." + (mempty :a)) + +(define-class (Functor :f) + "Types which can map an inner type where the mapping adheres to the identity and composition laws." + (map ((:a -> :b) -> :f :a -> :f :b))) + +(define-class (Functor :f => Applicative :f) + "Types which are a functor which can embed pure expressions and sequence operations." + (pure (:a -> (:f :a))) + (liftA2 ((:a -> :b -> :c) -> :f :a -> :f :b -> :f :c))) + +(define-class (Applicative :m => Monad :m) + "Types which are monads as defined in Haskell. See https://wiki.haskell.org/Monad for more information." + (>>= (:m :a -> (:a -> :m :b) -> :m :b))) + +(declare >> (Monad :m => (:m :a) -> (:m :b) -> (:m :b))) +(define (>> a b) + (>>= a (fn (_) b))) + +(define-class (Monad :m => MonadFail :m) + (fail (String -> :m :a))) + +(define-class (Applicative :f => Alternative :f) + "Types which are monoids on applicative functors." + (alt (:f :a -> :f :a -> :f :a)) + (empty (:f :a))) + +(define-class (Foldable :container) + "Types which can be folded into a single element." + (fold "A left tail-recursive fold." ((:accum -> :elt -> :accum) -> :accum -> :container :elt -> :accum)) + (foldr "A right non-tail-recursive fold."((:elt -> :accum -> :accum) -> :accum -> :container :elt -> :accum))) + +(declare mconcat ((Foldable :f) (Monoid :a) => :f :a -> :a)) +(define mconcat + "Fold a container of monoids into a single element." + (fold <> mempty)) + +(define-class (Traversable :t) + (traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b)))) + +(declare sequence ((Traversable :t) (Applicative :f) => :t (:f :b) -> :f (:t :b))) +(define sequence (traverse (fn (x) x))) + +(define-class (Bifunctor :f) + "Types which take two type arguments and are functors on both." + (bimap ((:a -> :b) -> (:c -> :d) -> :f :a :c -> :f :b :d))) + +(declare map-fst (Bifunctor :f => (:a -> :b) -> :f :a :c -> :f :b :c)) +(define (map-fst f b) + "Map over the first argument of a `Bifunctor`." + (bimap f (fn (x) x) b)) + +(declare map-snd (Bifunctor :f => (:b -> :c) -> :f :a :b -> :f :a :c)) +(define (map-snd f b) + "Map over the second argument of a `Bifunctor`." + (bimap (fn (x) x) f b)) + + ;; + ;; Conversions + ;; + +(define-class (Into :a :b) + "`INTO` imples *every* element of `:a` can be represented by an element of `:b`. This conversion might not be bijective (i.e., there may be elements in `:b` that don't correspond to any in `:a`)." + (into (:a -> :b))) + +(define-class ((Into :a :b) (Into :b :a) => Iso :a :b) + "Opting into this marker typeclass imples that the instances for `(Into :a :b)` and `(Into :b :a)` form a bijection.") + +(define-instance (Into :a :a) + (define (into x) x)) + +(define-class (TryInto :a :b :c (:a :b -> :c)) + "`TRY-INTO` implies some elements of `:a` can be represented exactly by an element of `:b`, but sometimes not. If not, an error of type `:c` is returned." + (tryInto (:a -> (Result :c :b)))) + +(define-instance (Iso :a :a)) + + ;; + ;; Unwrappable for fallible unboxing + ;; + +(define-class (Unwrappable :container) + "Containers which can be unwrapped to get access to their contents. + +`(unwrap-or-else succeed fail container)` should invoke the `succeed` continuation on the unwrapped contents of +`container` when successful, or invoke the `fail` continuation with no arguments (i.e., with `Unit` as an argument) +when unable to unwrap a value. + +The `succeed` continuation will often, but not always, be the identity function. `as-optional` passes `Some` to +construct an `Optional`. + +Typical `fail` continuations are: +- Return a default value, or +- Signal an error." + (unwrap-or-else ((:elt -> :result) + -> (Unit -> :result) + -> (:container :elt) + -> :result))) + +(declare expect ((Unwrappable :container) => + String + -> (:container :element) + -> :element)) +(define (expect reason container) + "Unwrap `container`, signaling an error with the description `reason` on failure." + (unwrap-or-else (fn (elt) elt) + (fn () (error reason)) + container)) + +(declare unwrap ((Unwrappable :container) => + (:container :element) + -> :element)) +(define (unwrap container) + "Unwrap `container`, signaling an error on failure." + (unwrap-or-else (fn (elt) elt) + (fn () (error (lisp String (container) + (cl:format cl:nil "Unexpected ~a in UNWRAP" + container)))) + container)) + +(declare with-default ((Unwrappable :container) => + :element + -> (:container :element) + -> :element)) +(define (with-default default container) + "Unwrap `container`, returning `default` on failure." + (unwrap-or-else (fn (elt) elt) + (fn () default) + container)) + +(declare as-optional ((Unwrappable :container) => (:container :elt) -> (Optional :elt))) +(define (as-optional container) + "Convert any Unwrappable container into an `Optional`, constructing Some on a successful unwrap and None on a failed unwrap." + (unwrap-or-else Some + (fn () None) + container)) + + + ;; + ;; Default + ;; + +(define-class (Default :a) + "Types which have default values." + (default (Unit -> :a))) + +(declare defaulting-unwrap ((Unwrappable :container) (Default :element) => + (:container :element) -> :element)) +(define (defaulting-unwrap container) + "Unwrap an `unwrappable`, returning `(default)` of the wrapped type on failure. " + (unwrap-or-else (fn (elt) elt) + (fn () (default)) + container)) + +(declare default? ((Default :a) (Eq :a) => :a -> Boolean)) +(define (default? x) + "Is `x` the default item of its type?" + (== x (default))) diff --git a/library/classes.lisp b/library/classes.lisp deleted file mode 100644 index 7b3e2029d..000000000 --- a/library/classes.lisp +++ /dev/null @@ -1,358 +0,0 @@ -(coalton-library/utils:defstdlib-package #:coalton-library/classes - (:use - #:coalton) - (:local-nicknames - (#:types #:coalton-library/types)) - (:export - #:Signalable - #:error - #:Tuple - #:Optional #:Some #:None - #:Result #:Ok #:Err - #:Eq #:== - #:Ord #:LT #:EQ #:GT - #:<=> #:> #:< #:>= #:<= - #:max - #:min - #:Num #:+ #:- #:* #:fromInt - #:Semigroup #:<> - #:Monoid #:mempty - #:Functor #:map - #:Applicative #:pure #:liftA2 - #:Monad #:>>= - #:>> - #:MonadFail #:fail - #:Alternative #:alt #:empty - #:Foldable #:fold #:foldr #:mconcat - #:Traversable #:traverse - #:Bifunctor #:bimap #:map-fst #:map-snd - #:sequence - #:Into - #:TryInto - #:Iso - #:Unwrappable #:unwrap-or-else #:with-default #:unwrap #:expect #:as-optional - #:default #:defaulting-unwrap #:default?)) - -(in-package #:coalton-library/classes) - -(named-readtables:in-readtable coalton:coalton) - -#+coalton-release -(cl:declaim #.coalton-impl/settings:*coalton-optimize-library*) - -;;; -;;; Signaling errors and warnings -;;; - -(coalton-toplevel - - ;; - ;; Signalling errors on supported types - ;; - (define-class (Signalable :a) - "Signals errors or warnings by calling their respective lisp conditions." - (error "Signal an error with a type-specific error string." (:a -> :b))) - - (define-instance (Signalable String) - (define (error str) - (lisp :a (str) - (cl:error str))))) - - -(coalton-toplevel - - ;; - ;; Base Types - ;; - - (define-struct (Tuple :a :b) - "A heterogeneous collection of items." - (first :a) - (second :b)) - - (define-type (Optional :a) - "Represents something that may not have a value." - (Some :a) - None) - - (define-type (Result :bad :good) - "Represents something that may have failed." - ;; We write (Result :bad :good) instead of (Result :good :bad) - ;; because of the limitations of how we deal with higher-kinded - ;; types; we want to implement Functor on this. - (Ok :good) - (Err :bad)) - - ;; - ;; Eq - ;; - - (define-class (Eq :a) - "Types which have equality defined." - (== (:a -> :a -> Boolean))) - - (define-instance (Eq types:LispType) - (define (== a b) - (lisp Boolean (a b) - (cl:equalp a b)))) - - (define-class (Eq :a => Num :a) - "Types which have numeric operations defined." - (+ (:a -> :a -> :a)) - (- (:a -> :a -> :a)) - (* (:a -> :a -> :a)) - (fromInt (Integer -> :a))) - - (define-instance (Eq Unit) - (define (== _ _) True)) - - ;; - ;; Ord - ;; - - (repr :enum) - (define-type Ord - "The result of an ordered comparison." - LT - EQ - GT) - - (define-instance (Eq Ord) - (define (== a b) - (match (Tuple a b) - ((Tuple (LT) (LT)) True) - ((Tuple (EQ) (EQ)) True) - ((Tuple (GT) (GT)) True) - (_ False)))) - - (define-instance (Ord Ord) - (define (<=> a b) - (match (Tuple a b) - ((Tuple (LT) (LT)) EQ) - ((Tuple (LT) (EQ)) LT) - ((Tuple (LT) (GT)) LT) - ((Tuple (EQ) (LT)) GT) - ((Tuple (EQ) (EQ)) EQ) - ((Tuple (EQ) (GT)) LT) - ((Tuple (GT) (LT)) GT) - ((Tuple (GT) (EQ)) GT) - ((Tuple (GT) (GT)) EQ)))) - - (define-class (Eq :a => Ord :a) - "Types whose values can be ordered." - (<=> (:a -> :a -> Ord))) - - (declare > (Ord :a => :a -> :a -> Boolean)) - (define (> x y) - "Is `x` greater than `y`?" - (match (<=> x y) - ((GT) True) - (_ False))) - - (declare < (Ord :a => :a -> :a -> Boolean)) - (define (< x y) - "Is `x` less than `y`?" - (match (<=> x y) - ((LT) True) - (_ False))) - - (declare >= (Ord :a => :a -> :a -> Boolean)) - (define (>= x y) - "Is `x` greater than or equal to `y`?" - (match (<=> x y) - ((LT) False) - (_ True))) - - (declare <= (Ord :a => :a -> :a -> Boolean)) - (define (<= x y) - "Is `x` less than or equal to `y`?" - (match (<=> x y) - ((GT) False) - (_ True))) - - (declare max (Ord :a => :a -> :a -> :a)) - (define (max x y) - "Returns the greater element of `x` and `y`." - (if (> x y) - x - y)) - - (declare min (Ord :a => :a -> :a -> :a)) - (define (min x y) - "Returns the lesser element of `x` and `y`." - (if (< x y) - x - y)) - - ;; - ;; Haskell - ;; - - (define-class (Semigroup :a) - "Types with an associative binary operation defined." - (<> (:a -> :a -> :a))) - - (define-class (Semigroup :a => Monoid :a) - "Types with an associative binary operation and identity defined." - (mempty :a)) - - (define-class (Functor :f) - "Types which can map an inner type where the mapping adheres to the identity and composition laws." - (map ((:a -> :b) -> :f :a -> :f :b))) - - (define-class (Functor :f => Applicative :f) - "Types which are a functor which can embed pure expressions and sequence operations." - (pure (:a -> (:f :a))) - (liftA2 ((:a -> :b -> :c) -> :f :a -> :f :b -> :f :c))) - - (define-class (Applicative :m => Monad :m) - "Types which are monads as defined in Haskell. See https://wiki.haskell.org/Monad for more information." - (>>= (:m :a -> (:a -> :m :b) -> :m :b))) - - (declare >> (Monad :m => (:m :a) -> (:m :b) -> (:m :b))) - (define (>> a b) - (>>= a (fn (_) b))) - - (define-class (Monad :m => MonadFail :m) - (fail (String -> :m :a))) - - (define-class (Applicative :f => Alternative :f) - "Types which are monoids on applicative functors." - (alt (:f :a -> :f :a -> :f :a)) - (empty (:f :a))) - - (define-class (Foldable :container) - "Types which can be folded into a single element." - (fold "A left tail-recursive fold." ((:accum -> :elt -> :accum) -> :accum -> :container :elt -> :accum)) - (foldr "A right non-tail-recursive fold." ((:elt -> :accum -> :accum) -> :accum -> :container :elt -> :accum))) - - (declare mconcat ((Foldable :f) (Monoid :a) => :f :a -> :a)) - (define mconcat - "Fold a container of monoids into a single element." - (fold <> mempty)) - - (define-class (Traversable :t) - (traverse (Applicative :f => (:a -> :f :b) -> :t :a -> :f (:t :b)))) - - (declare sequence ((Traversable :t) (Applicative :f) => :t (:f :b) -> :f (:t :b))) - (define sequence (traverse (fn (x) x))) - - (define-class (Bifunctor :f) - "Types which take two type arguments and are functors on both." - (bimap ((:a -> :b) -> (:c -> :d) -> :f :a :c -> :f :b :d))) - - (declare map-fst (Bifunctor :f => (:a -> :b) -> :f :a :c -> :f :b :c)) - (define (map-fst f b) - "Map over the first argument of a `Bifunctor`." - (bimap f (fn (x) x) b)) - - (declare map-snd (Bifunctor :f => (:b -> :c) -> :f :a :b -> :f :a :c)) - (define (map-snd f b) - "Map over the second argument of a `Bifunctor`." - (bimap (fn (x) x) f b)) - - ;; - ;; Conversions - ;; - - (define-class (Into :a :b) - "`INTO` imples *every* element of `:a` can be represented by an element of `:b`. This conversion might not be bijective (i.e., there may be elements in `:b` that don't correspond to any in `:a`)." - (into (:a -> :b))) - - (define-class ((Into :a :b) (Into :b :a) => Iso :a :b) - "Opting into this marker typeclass imples that the instances for `(Into :a :b)` and `(Into :b :a)` form a bijection.") - - (define-instance (Into :a :a) - (define (into x) x)) - - (define-class (TryInto :a :b :c (:a :b -> :c)) - "`TRY-INTO` implies some elements of `:a` can be represented exactly by an element of `:b`, but sometimes not. If not, an error of type `:c` is returned." - (tryInto (:a -> (Result :c :b)))) - - (define-instance (Iso :a :a)) - - ;; - ;; Unwrappable for fallible unboxing - ;; - - (define-class (Unwrappable :container) - "Containers which can be unwrapped to get access to their contents. - -`(unwrap-or-else succeed fail container)` should invoke the `succeed` continuation on the unwrapped contents of -`container` when successful, or invoke the `fail` continuation with no arguments (i.e., with `Unit` as an argument) -when unable to unwrap a value. - -The `succeed` continuation will often, but not always, be the identity function. `as-optional` passes `Some` to -construct an `Optional`. - -Typical `fail` continuations are: -- Return a default value, or -- Signal an error." - (unwrap-or-else ((:elt -> :result) - -> (Unit -> :result) - -> (:container :elt) - -> :result))) - - (declare expect ((Unwrappable :container) => - String - -> (:container :element) - -> :element)) - (define (expect reason container) - "Unwrap `container`, signaling an error with the description `reason` on failure." - (unwrap-or-else (fn (elt) elt) - (fn () (error reason)) - container)) - - (declare unwrap ((Unwrappable :container) => - (:container :element) - -> :element)) - (define (unwrap container) - "Unwrap `container`, signaling an error on failure." - (unwrap-or-else (fn (elt) elt) - (fn () (error (lisp String (container) - (cl:format cl:nil "Unexpected ~a in UNWRAP" - container)))) - container)) - - (declare with-default ((Unwrappable :container) => - :element - -> (:container :element) - -> :element)) - (define (with-default default container) - "Unwrap `container`, returning `default` on failure." - (unwrap-or-else (fn (elt) elt) - (fn () default) - container)) - - (declare as-optional ((Unwrappable :container) => (:container :elt) -> (Optional :elt))) - (define (as-optional container) - "Convert any Unwrappable container into an `Optional`, constructing Some on a successful unwrap and None on a failed unwrap." - (unwrap-or-else Some - (fn () None) - container)) - - - ;; - ;; Default - ;; - - (define-class (Default :a) - "Types which have default values." - (default (Unit -> :a))) - - (declare defaulting-unwrap ((Unwrappable :container) (Default :element) => - (:container :element) -> :element)) - (define (defaulting-unwrap container) - "Unwrap an `unwrappable`, returning `(default)` of the wrapped type on failure. " - (unwrap-or-else (fn (elt) elt) - (fn () (default)) - container)) - - (declare default? ((Default :a) (Eq :a) => :a -> Boolean)) - (define (default? x) - "Is `x` the default item of its type?" - (== x (default)))) - - -#+sb-package-locks -(sb-ext:lock-package "COALTON-LIBRARY/CLASSES")