<commit_before>#lang hackett/private/kernel

(require (only-in racket/base for-syntax)

         (for-syntax racket/base
                     syntax/parse/class/paren-shape)

         (except-in hackett/private/adt data)
         (except-in hackett/private/class class)
         hackett/private/provide
         hackett/private/prim/op
         hackett/private/prim/type
         syntax/parse/define)

(provide not || && if fst snd foldr unsafe-run-io!

         . $ & id const flip

         (class Eq) (class Show)
         (class Semigroup) (class Monoid) concat

         (class Functor) (rename-out [map <$>]) <&> <$ $> ignore
         (class Applicative) sequence traverse
         (class Monad) =<< >>= do ap)

;; ---------------------------------------------------------------------------------------------------
;; basic operations

(defn not : {Bool -> Bool}
  [[true ] false]
  [[false] true])

(defn || : {Bool -> Bool -> Bool} #:fixity right
  [[true  _] true]
  [[false y] y])

(defn && : {Bool -> Bool -> Bool} #:fixity right
  [[true  y] y]
  [[false _] false])

(defn if : (∀ [a] {Bool -> a -> a -> a})
  [[true  x _] x]
  [[false _ y] y])

(defn fst : (∀ [a b] {(Tuple a b) -> a})
  [[(tuple x _)] x])

(defn snd : (∀ [a b] {(Tuple a b) -> b})
  [[(tuple _ x)] x])

(defn foldr : (∀ [a b] {{a -> b -> b} -> b -> (List a) -> b})
  [[f a {x :: xs}] (f x (foldr f a xs))]
  [[_ a nil      ] a])

(defn unsafe-run-io! : (∀ [a] {(IO a) -> a})
  [[(io f)] (snd (f real-world))])

;; ---------------------------------------------------------------------------------------------------
;; function combinators

(defn id : (∀ [a] {a -> a})
  [[x] x])

(defn . : (∀ [a b c] {{b -> c} -> {a -> b} -> a -> c})
  [[f g x] (f (g x))])

(defn $ : (∀ [a b] {{a -> b} -> a -> b})
  [[f x] (f x)])

(defn & : (∀ [a b] {a -> {a -> b} -> b})
  [[x f] (f x)])

(defn const : (∀ [a b] {a -> b -> a})
  [[x _] x])

(defn flip : (∀ [a b c] {{a -> b -> c} -> b -> a -> c})
  [[f x y] (f y x)])

;; ---------------------------------------------------------------------------------------------------
;; Show

(class (Show a)
  [show : {a -> String}])

(instance (Show Unit)
  [show (λ [unit] "unit")])

(instance (Show Bool)
  [show (λ* [[true ] "true"]
            [[false] "false"])])

(instance (Show Integer)
  [show show/Integer])

(instance (Show Double)
  [show show/Double])

(instance (Show String)
  [show (λ [str] {"\"" ++ str ++ "\""})])

(instance (∀ [a] (Show a) => (Show (Maybe a)))
  [show (λ* [[(just x)] {"(just " ++ (show x) ++ ")"}]
            [[nothing ] "nothing"])])

(instance (∀ [a b] (Show a) (Show b) => (Show (Tuple a b)))
  [show (λ [(tuple a b)] {"(tuple " ++ (show a) ++ " " ++ (show b) ++ ")"})])

(instance (∀ [a] (Show a) => (Show (List a)))
  [show (λ* [[nil] "nil"]
            [[xs] (let ([strs (map {(λ [x] {x ++ " :: "}) . show} xs)])
                    {"{" ++ (concat strs) ++ "nil}"})])])

;; ---------------------------------------------------------------------------------------------------
;; Eq

(class (Eq a)
  [== : {a -> a -> Bool}])

(instance (Eq Unit)
  [== (λ [unit unit] true)])

(instance (Eq Bool)
  [== (λ* [[true  y] y]
          [[false y] (not y)])])

(instance (Eq Integer)
  [== equal?/Integer])

(instance (Eq Double)
  [== equal?/Double])

(instance (Eq String)
  [== equal?/String])

(instance (∀ [a] (Eq a) => (Eq (Maybe a)))
  [== (λ* [[(just a) (just b)] (== a b)]
          [[nothing  nothing ] true]
          [[_        _       ] false])])

(instance (∀ [a b] (Eq a) (Eq b) => (Eq (Tuple a b)))
  [== (λ [(tuple a b) (tuple c d)] {{a == c} && {b == d}})])

(instance (∀ [a] (Eq a) => (Eq (List a)))
  [== (λ* [[{x :: xs} {y :: ys}] {{x == y} && {xs == ys}}]
          [[nil       nil      ] true]
          [[_         _        ] false])])

;; ---------------------------------------------------------------------------------------------------
;; Semigroup / Monoid

(class (Semigroup a)
  [++ : {a -> a -> a}
      #:fixity right])

(instance (Semigroup String)
  [++ append/String])

(instance (∀ [a] (Semigroup (List a)))
  [++ (λ* [[{z :: zs} ys] {z :: {zs ++ ys}}]
          [[nil       ys] ys])])

(class (Semigroup a) => (Monoid a)
  [mempty : a])

(instance (Monoid String)
  [mempty ""])

(instance (∀ [a] (Monoid (List a)))
  [mempty nil])

(def concat : (∀ [a] (Monoid a) => {(List a) -> a})
  (foldr ++ mempty))

;; ---------------------------------------------------------------------------------------------------
;; Functor

(class (Functor f)
  [map : (∀ [a b] {{a -> b} -> (f a) -> (f b)})])

(def <&> : (∀ [f a b] (Functor f) => {(f a) -> {a -> b} -> (f b)})
  (flip map))

(def <$ : (∀ [f a b] (Functor f) => {a -> (f b) -> (f a)})<commit_msg>Add Semigroup/Monoid instances for Maybe and -><commit_after>#lang hackett/private/kernel

(require (only-in racket/base for-syntax)

         (for-syntax racket/base
                     syntax/parse/class/paren-shape)

         (except-in hackett/private/adt data)
         (except-in hackett/private/class class)
         hackett/private/provide
         hackett/private/prim/op
         hackett/private/prim/type
         syntax/parse/define)

(provide not || && if fst snd foldr unsafe-run-io!

         . $ & id const flip

         (class Eq) (class Show)
         (class Semigroup) (class Monoid) concat

         (class Functor) (rename-out [map <$>]) <&> <$ $> ignore
         (class Applicative) sequence traverse
         (class Monad) =<< >>= do ap)

;; ---------------------------------------------------------------------------------------------------
;; basic operations

(defn not : {Bool -> Bool}
  [[true ] false]
  [[false] true])

(defn || : {Bool -> Bool -> Bool} #:fixity right
  [[true  _] true]
  [[false y] y])

(defn && : {Bool -> Bool -> Bool} #:fixity right
  [[true  y] y]
  [[false _] false])

(defn if : (∀ [a] {Bool -> a -> a -> a})
  [[true  x _] x]
  [[false _ y] y])

(defn fst : (∀ [a b] {(Tuple a b) -> a})
  [[(tuple x _)] x])

(defn snd : (∀ [a b] {(Tuple a b) -> b})
  [[(tuple _ x)] x])

(defn foldr : (∀ [a b] {{a -> b -> b} -> b -> (List a) -> b})
  [[f a {x :: xs}] (f x (foldr f a xs))]
  [[_ a nil      ] a])

(defn unsafe-run-io! : (∀ [a] {(IO a) -> a})
  [[(io f)] (snd (f real-world))])

;; ---------------------------------------------------------------------------------------------------
;; function combinators

(defn id : (∀ [a] {a -> a})
  [[x] x])

(defn . : (∀ [a b c] {{b -> c} -> {a -> b} -> a -> c})
  [[f g x] (f (g x))])

(defn $ : (∀ [a b] {{a -> b} -> a -> b})
  [[f x] (f x)])

(defn & : (∀ [a b] {a -> {a -> b} -> b})
  [[x f] (f x)])

(defn const : (∀ [a b] {a -> b -> a})
  [[x _] x])

(defn flip : (∀ [a b c] {{a -> b -> c} -> b -> a -> c})
  [[f x y] (f y x)])

;; ---------------------------------------------------------------------------------------------------
;; Show

(class (Show a)
  [show : {a -> String}])

(instance (Show Unit)
  [show (λ [unit] "unit")])

(instance (Show Bool)
  [show (λ* [[true ] "true"]
            [[false] "false"])])

(instance (Show Integer)
  [show show/Integer])

(instance (Show Double)
  [show show/Double])

(instance (Show String)
  [show (λ [str] {"\"" ++ str ++ "\""})])

(instance (∀ [a] (Show a) => (Show (Maybe a)))
  [show (λ* [[(just x)] {"(just " ++ (show x) ++ ")"}]
            [[nothing ] "nothing"])])

(instance (∀ [a b] (Show a) (Show b) => (Show (Tuple a b)))
  [show (λ [(tuple a b)] {"(tuple " ++ (show a) ++ " " ++ (show b) ++ ")"})])

(instance (∀ [a] (Show a) => (Show (List a)))
  [show (λ* [[nil] "nil"]
            [[xs] (let ([strs (map {(λ [x] {x ++ " :: "}) . show} xs)])
                    {"{" ++ (concat strs) ++ "nil}"})])])

;; ---------------------------------------------------------------------------------------------------
;; Eq

(class (Eq a)
  [== : {a -> a -> Bool}])

(instance (Eq Unit)
  [== (λ [unit unit] true)])

(instance (Eq Bool)
  [== (λ* [[true  y] y]
          [[false y] (not y)])])

(instance (Eq Integer)
  [== equal?/Integer])

(instance (Eq Double)
  [== equal?/Double])

(instance (Eq String)
  [== equal?/String])

(instance (∀ [a] (Eq a) => (Eq (Maybe a)))
  [== (λ* [[(just a) (just b)] (== a b)]
          [[nothing  nothing ] true]
          [[_        _       ] false])])

(instance (∀ [a b] (Eq a) (Eq b) => (Eq (Tuple a b)))
  [== (λ [(tuple a b) (tuple c d)] {{a == c} && {b == d}})])

(instance (∀ [a] (Eq a) => (Eq (List a)))
  [== (λ* [[{x :: xs} {y :: ys}] {{x == y} && {xs == ys}}]
          [[nil       nil      ] true]
          [[_         _        ] false])])

;; ---------------------------------------------------------------------------------------------------
;; Semigroup / Monoid

(class (Semigroup a)
  [++ : {a -> a -> a}
      #:fixity right])

(instance (Semigroup String)
  [++ append/String])

(instance (∀ [a] (Semigroup a) => (Semigroup (Maybe a)))
  [++ (λ* [[(just x) (just y)] (just {x ++ y})]
          [[(just x) nothing ] (just x)]
          [[nothing  (just y)] (just y)]
          [[nothing  nothing ] nothing])])

(instance (∀ [a] (Semigroup (List a)))
  [++ (λ* [[{z :: zs} ys] {z :: {zs ++ ys}}]
          [[nil       ys] ys])])

(instance (∀ [a b] (Semigroup b) => (Semigroup {a -> b}))
  [++ (λ [f g x] {(f x) ++ (g x)})])

(class (Semigroup a) => (Monoid a)
  [mempty : a])

(instance (Monoid String)
  [mempty ""])

(instance (∀ [a] (Semigroup a) => (Monoid (Maybe a)))
  [mempty nothing])

(instance (∀ [a] (Monoid (List a)))
  [mempty nil])

(instance (∀ [a b] (Monoid b) => (Monoid {a -> b}))
  [mempty (λ [_] mempty)])

(def concat : (∀ [a] (Monoid a) => {(List a) -> a})
  (foldr ++ mempty))

;; ---------------------------------------------------------------------------------------------------
;; Functor

(class (Functor f)
  [map : (∀ [a b] {{a -> b} -> (f a) -> (f b)})])

(def <&> : (∀ [f a b] (Functor f) => {(f a) -> {a -> b} -> (f b)})
  (flip map))

(def <$ : (∀ [f a b] (Functor f) => {a -> (f b) -> (f a)})
{'fraction_non_alphanumeric': 0.3536022476419827, 'fraction_numerical': 0.0, 'mean_word_length': 1.5595788392398562, 'pattern_counts': {'":': 0, '<': 17, '<?xml version=': 0, '>': 140, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4216810', 'n_tokens_mistral': 3851, 'n_tokens_neox': 3702, 'n_words': 1155}