From 4d6b2fec130331507f872b3683f8b2c8d3340dd5 Mon Sep 17 00:00:00 2001
From: sharkdp <davidpeter@web.de>
Date: Wed, 14 Oct 2020 08:12:50 +0200
Subject: [PATCH] Add PureScript syntax test

---
 .../highlighted/PureScript/test.purs          | 89 +++++++++++++++++++
 .../syntax-tests/source/PureScript/test.purs  | 89 +++++++++++++++++++
 2 files changed, 178 insertions(+)
 create mode 100644 tests/syntax-tests/highlighted/PureScript/test.purs
 create mode 100644 tests/syntax-tests/source/PureScript/test.purs

diff --git a/tests/syntax-tests/highlighted/PureScript/test.purs b/tests/syntax-tests/highlighted/PureScript/test.purs
new file mode 100644
index 00000000..d59b29b8
--- /dev/null
+++ b/tests/syntax-tests/highlighted/PureScript/test.purs
@@ -0,0 +1,89 @@
+-- | This module defines a datatype `Pair` together with a few useful instances
+-- | and helper functions. Note that this is not just `Tuple a a` but rather a
+-- | list with exactly two elements. Specifically, the `Functor` instance maps
+-- | over both values (in contrast to the `Functor` instance for `Tuple a`).
+module Data.Pair
+  ( Pair(..)
+  , (~)
+  , fst
+  , snd
+  , curry
+  , uncurry
+  , swap
+  ) where
+
+import Prelude
+
+import Data.Foldable (class Foldable)
+import Data.Traversable (class Traversable)
+import Data.Distributive (class Distributive)
+
+import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)
+
+-- | A pair simply consists of two values of the same type.
+data Pair a = Pair a a
+
+infixl 6 Pair as ~
+
+-- | Returns the first component of a pair.
+fst ∷ ∀ a. Pair a → a
+fst (x ~ _) = x
+
+-- | Returns the second component of a pair.
+snd ∷ ∀ a. Pair a → a
+snd (_ ~ y) = y
+
+-- | Turn a function that expects a pair into a function of two arguments.
+curry ∷ ∀ a b. (Pair a → b) → a → a → b
+curry f x y = f (x ~ y)
+
+-- | Turn a function of two arguments into a function that expects a pair.
+uncurry ∷ ∀ a b. (a → a → b) → Pair a → b
+uncurry f (x ~ y) = f x y
+
+-- | Exchange the two components of the pair
+swap ∷ ∀ a. Pair a → Pair a
+swap (x ~ y) = y ~ x
+
+derive instance eqPair ∷ Eq a ⇒ Eq (Pair a)
+
+derive instance ordPair ∷ Ord a ⇒ Ord (Pair a)
+
+instance showPair ∷ Show a ⇒ Show (Pair a) where
+  show (x ~ y) = "(" <> show x <> " ~ " <> show y <> ")"
+
+instance functorPair ∷ Functor Pair where
+  map f (x ~ y) = f x ~ f y
+
+instance applyPair ∷ Apply Pair where
+  apply (f ~ g) (x ~ y) = f x ~ g y
+
+instance applicativePair ∷ Applicative Pair where
+  pure x = x ~ x
+
+instance bindPair ∷ Bind Pair where
+  bind (x ~ y) f = fst (f x) ~ snd (f y)
+
+instance monadPair ∷ Monad Pair
+
+instance semigroupPair ∷ Semigroup a ⇒ Semigroup (Pair a) where
+  append (x1 ~ y1) (x2 ~ y2) = (x1 <> x2) ~ (y1 <> y2)
+
+instance monoidPair ∷ Monoid a ⇒ Monoid (Pair a) where
+  mempty = mempty ~ mempty
+
+instance foldablePair ∷ Foldable Pair where
+  foldr f z (Pair x y) = x `f` (y `f` z)
+  foldl f z (Pair x y) = (z `f` x) `f` y
+  foldMap f (Pair x y) = f x <> f y
+
+instance traversablePair ∷ Traversable Pair where
+  traverse f (Pair x y) = Pair <$> f x <*> f y
+  sequence (Pair mx my) = Pair <$> mx <*> my
+
+instance distributivePair ∷ Distributive Pair where
+  distribute xs = map fst xs ~ map snd xs
+  collect f xs = map (fst <<< f) xs ~ map (snd <<< f) xs
+
+instance arbitraryPair ∷ Arbitrary a ⇒ Arbitrary (Pair a) where
+  arbitrary = Pair <$> arbitrary <*> arbitrary
diff --git a/tests/syntax-tests/source/PureScript/test.purs b/tests/syntax-tests/source/PureScript/test.purs
new file mode 100644
index 00000000..35da2b62
--- /dev/null
+++ b/tests/syntax-tests/source/PureScript/test.purs
@@ -0,0 +1,89 @@
+-- | This module defines a datatype `Pair` together with a few useful instances
+-- | and helper functions. Note that this is not just `Tuple a a` but rather a
+-- | list with exactly two elements. Specifically, the `Functor` instance maps
+-- | over both values (in contrast to the `Functor` instance for `Tuple a`).
+module Data.Pair
+  ( Pair(..)
+  , (~)
+  , fst
+  , snd
+  , curry
+  , uncurry
+  , swap
+  ) where
+
+import Prelude
+
+import Data.Foldable (class Foldable)
+import Data.Traversable (class Traversable)
+import Data.Distributive (class Distributive)
+
+import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)
+
+-- | A pair simply consists of two values of the same type.
+data Pair a = Pair a a
+
+infixl 6 Pair as ~
+
+-- | Returns the first component of a pair.
+fst ∷ ∀ a. Pair a → a
+fst (x ~ _) = x
+
+-- | Returns the second component of a pair.
+snd ∷ ∀ a. Pair a → a
+snd (_ ~ y) = y
+
+-- | Turn a function that expects a pair into a function of two arguments.
+curry ∷ ∀ a b. (Pair a → b) → a → a → b
+curry f x y = f (x ~ y)
+
+-- | Turn a function of two arguments into a function that expects a pair.
+uncurry ∷ ∀ a b. (a → a → b) → Pair a → b
+uncurry f (x ~ y) = f x y
+
+-- | Exchange the two components of the pair
+swap ∷ ∀ a. Pair a → Pair a
+swap (x ~ y) = y ~ x
+
+derive instance eqPair ∷ Eq a ⇒ Eq (Pair a)
+
+derive instance ordPair ∷ Ord a ⇒ Ord (Pair a)
+
+instance showPair ∷ Show a ⇒ Show (Pair a) where
+  show (x ~ y) = "(" <> show x <> " ~ " <> show y <> ")"
+
+instance functorPair ∷ Functor Pair where
+  map f (x ~ y) = f x ~ f y
+
+instance applyPair ∷ Apply Pair where
+  apply (f ~ g) (x ~ y) = f x ~ g y
+
+instance applicativePair ∷ Applicative Pair where
+  pure x = x ~ x
+
+instance bindPair ∷ Bind Pair where
+  bind (x ~ y) f = fst (f x) ~ snd (f y)
+
+instance monadPair ∷ Monad Pair
+
+instance semigroupPair ∷ Semigroup a ⇒ Semigroup (Pair a) where
+  append (x1 ~ y1) (x2 ~ y2) = (x1 <> x2) ~ (y1 <> y2)
+
+instance monoidPair ∷ Monoid a ⇒ Monoid (Pair a) where
+  mempty = mempty ~ mempty
+
+instance foldablePair ∷ Foldable Pair where
+  foldr f z (Pair x y) = x `f` (y `f` z)
+  foldl f z (Pair x y) = (z `f` x) `f` y
+  foldMap f (Pair x y) = f x <> f y
+
+instance traversablePair ∷ Traversable Pair where
+  traverse f (Pair x y) = Pair <$> f x <*> f y
+  sequence (Pair mx my) = Pair <$> mx <*> my
+
+instance distributivePair ∷ Distributive Pair where
+  distribute xs = map fst xs ~ map snd xs
+  collect f xs = map (fst <<< f) xs ~ map (snd <<< f) xs
+
+instance arbitraryPair ∷ Arbitrary a ⇒ Arbitrary (Pair a) where
+  arbitrary = Pair <$> arbitrary <*> arbitrary