Add PureScript language & samples

lib/linguist/languages.yml

@@ -1391,6 +1391,12 @@ Pure Data:
   lexer: Text only
   primary_extension: .pd
 
+PureScript:
+  type: programming
+  color: "#f3ce45"
+  lexer: Haskell
+  primary_extension: .purs
+
 Python:
   type: programming
   ace_mode: python

samples/PureScript/Control.Arrow.purs

@@ -0,0 +1,34 @@
+module Control.Arrow where
+
+import Data.Tuple
+
+class Arrow a where
+  arr :: forall b c. (b -> c) -> a b c
+  first :: forall b c d. a b c -> a (Tuple b d) (Tuple c d)
+
+instance arrowFunction :: Arrow (->) where
+  arr f = f
+  first f (Tuple b d) = Tuple (f b) d
+
+second :: forall a b c d. (Category a, Arrow a) => a b c -> a (Tuple d b) (Tuple d c)
+second f = arr swap >>> first f >>> arr swap
+
+swap :: forall a b. Tuple a b -> Tuple b a
+swap (Tuple x y) = Tuple y x
+
+infixr 3 ***
+infixr 3 &&&
+
+(***) :: forall a b b' c c'. (Category a, Arrow a) => a b c -> a b' c' -> a (Tuple b b') (Tuple c c')
+(***) f g = first f >>> second g
+
+(&&&) :: forall a b b' c c'. (Category a, Arrow a) => a b c -> a b c' -> a b (Tuple c c')
+(&&&) f g = arr (\b -> Tuple b b) >>> (f *** g)
+
+class ArrowZero a where
+  zeroArrow :: forall b c. a b c
+
+infixr 5 <+>
+
+class ArrowPlus a where
+  (<+>) :: forall b c. a b c -> a b c -> a b c

samples/PureScript/Data.Foreign.purs

@@ -0,0 +1,111 @@
+module Data.Foreign
+  ( Foreign(..)
+  , ForeignParser(ForeignParser)
+  , parseForeign
+  , parseJSON
+  , ReadForeign
+  , read
+  , prop
+  ) where
+
+import Prelude
+import Data.Array
+import Data.Either
+import Data.Maybe
+import Data.Tuple
+import Data.Traversable
+
+foreign import data Foreign :: *
+
+foreign import fromString
+  "function fromString (str) { \
+  \  try { \
+  \    return _ps.Data_Either.Right(JSON.parse(str)); \
+  \  } catch (e) { \
+  \    return _ps.Data_Either.Left(e.toString()); \
+  \  } \
+  \}" :: String -> Either String Foreign
+
+foreign import readPrimType
+  "function readPrimType (typeName) { \
+  \  return function (value) { \
+  \    if (toString.call(value) == '[object ' + typeName + ']') { \
+  \      return _ps.Data_Either.Right(value);\
+  \    } \
+  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
+  \  }; \
+  \}" :: forall a. String -> Foreign -> Either String a
+
+foreign import readMaybeImpl
+  "function readMaybeImpl (value) { \
+  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
+  \}" :: forall a. Foreign -> Maybe Foreign
+
+foreign import readPropImpl
+  "function readPropImpl (k) { \
+  \  return function (obj) { \
+  \    return _ps.Data_Either.Right(obj[k]);\
+  \  }; \
+  \}" :: forall a. String -> Foreign -> Either String Foreign
+
+foreign import showForeignImpl
+  "var showForeignImpl = JSON.stringify;" :: Foreign -> String
+
+instance showForeign :: Prelude.Show Foreign where
+  show = showForeignImpl
+
+data ForeignParser a = ForeignParser (Foreign -> Either String a)
+
+parseForeign :: forall a. ForeignParser a -> Foreign -> Either String a
+parseForeign (ForeignParser p) x = p x
+
+parseJSON :: forall a. (ReadForeign a) => String -> Either String a
+parseJSON json = fromString json >>= parseForeign read
+
+instance monadForeignParser :: Prelude.Monad ForeignParser where
+  return x = ForeignParser \_ -> Right x
+  (>>=) (ForeignParser p) f = ForeignParser \x -> case p x of
+      Left err -> Left err
+      Right x' -> parseForeign (f x') x
+
+instance applicativeForeignParser :: Prelude.Applicative ForeignParser where
+  pure x = ForeignParser \_ -> Right x
+  (<*>) (ForeignParser f) (ForeignParser p) = ForeignParser \x -> case f x of
+      Left err -> Left err
+      Right f' -> f' <$> p x
+
+instance functorForeignParser :: Prelude.Functor ForeignParser where
+  (<$>) f (ForeignParser p) = ForeignParser \x -> f <$> p x
+
+class ReadForeign a where
+  read :: ForeignParser a
+
+instance readString :: ReadForeign String where
+  read = ForeignParser $ readPrimType "String"
+
+instance readNumber :: ReadForeign Number where
+  read = ForeignParser $ readPrimType "Number"
+
+instance readBoolean :: ReadForeign Boolean where
+  read = ForeignParser $ readPrimType "Boolean"
+
+instance readArray :: (ReadForeign a) => ReadForeign [a] where
+  read =
+    let arrayItem (Tuple i x) = case parseForeign read x of
+      Right result -> Right result
+      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err
+    in
+    (ForeignParser $ readPrimType "Array") >>= \xs -> 
+      ForeignParser \_ -> arrayItem `traverse` (zip (range 0 (length xs)) xs)
+
+instance readMaybe :: (ReadForeign a) => ReadForeign (Maybe a) where
+  read = (ForeignParser $ Right <<< readMaybeImpl) >>= \x -> 
+    ForeignParser \_ -> case x of
+      Just x' -> parseForeign read x' >>= return <<< Just
+      Nothing -> return Nothing
+
+prop :: forall a. (ReadForeign a) => String -> ForeignParser a
+prop p = (ForeignParser \x -> readPropImpl p x) >>= \x -> 
+  ForeignParser \_ -> case parseForeign read x of
+    Right result -> Right result
+    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

samples/PureScript/Data.Map.purs

@@ -0,0 +1,90 @@
+module Data.Map
+  ( Map(),
+    empty,
+    singleton,
+    insert,
+    lookup,
+    delete,
+    alter,
+    toList,
+    fromList,
+    union,
+    map
+  ) where
+
+import qualified Prelude as P
+
+import Data.Array (concat)
+import Data.Foldable (foldl)
+import Data.Maybe
+import Data.Tuple
+
+data Map k v = Leaf | Branch { key :: k, value :: v, left :: Map k v, right :: Map k v }
+
+instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v) where
+  (==) m1 m2 = toList m1 P.== toList m2
+  (/=) m1 m2 = P.not (m1 P.== m2)
+
+instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v) where
+  show m = "fromList " P.++ P.show (toList m)
+
+empty :: forall k v. Map k v
+empty = Leaf
+
+singleton :: forall k v. k -> v -> Map k v
+singleton k v = Branch { key: k, value: v, left: empty, right: empty }
+
+insert :: forall k v. (P.Eq k, P.Ord k) => k -> v -> Map k v -> Map k v
+insert k v Leaf = singleton k v
+insert k v (Branch b@{ key = k1 }) | k P.== k1 = Branch (b { key = k, value = v })
+insert k v (Branch b@{ key = k1 }) | k P.< k1 = Branch (b { left = insert k v b.left })
+insert k v (Branch b) = Branch (b { right = insert k v b.right })
+
+lookup :: forall k v. (P.Eq k, P.Ord k) => k -> Map k v -> Maybe v
+lookup k Leaf = Nothing
+lookup k (Branch { key = k1, value = v }) | k P.== k1 = Just v
+lookup k (Branch { key = k1, left = left }) | k P.< k1 = lookup k left
+lookup k (Branch { right = right }) = lookup k right
+
+findMinKey :: forall k v. (P.Ord k) => Map k v -> Tuple k v
+findMinKey (Branch { key = k, value = v, left = Leaf }) = Tuple k v
+findMinKey (Branch b) = findMinKey b.left
+
+delete :: forall k v. (P.Eq k, P.Ord k) => k -> Map k v -> Map k v
+delete k Leaf = Leaf
+delete k (Branch b@{ key = k1, left = Leaf }) | k P.== k1 =
+  case b of
+    { left = Leaf } -> b.right
+    { right = Leaf } -> b.left
+    _ -> glue b.left b.right
+delete k (Branch b@{ key = k1 }) | k P.< k1 = Branch (b { left = delete k b.left })
+delete k (Branch b) = Branch (b { right = delete k b.right })
+
+alter :: forall k v. (P.Eq k, P.Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
+alter f k Leaf = case f Nothing of
+  Nothing -> Leaf
+  Just v -> singleton k v
+alter f k (Branch b@{ key = k1, value = v }) | k P.== k1 = case f (Just v) of
+  Nothing -> glue b.left b.right
+  Just v' -> Branch (b { value = v' })
+alter f k (Branch b@{ key = k1 }) | k P.< k1 = Branch (b { left = alter f k b.left })
+alter f k (Branch b) = Branch (b { right = alter f k b.right })
+
+glue :: forall k v. (P.Eq k, P.Ord k) => Map k v -> Map k v -> Map k v
+glue left right = 
+  let Tuple minKey root = findMinKey right in
+  Branch { key: minKey, value: root, left: left, right: delete minKey right }
+
+toList :: forall k v. Map k v -> [Tuple k v]
+toList Leaf = []
+toList (Branch b) = toList b.left `concat` [Tuple b.key b.value] `concat` toList b.right
+
+fromList :: forall k v. (P.Eq k, P.Ord k) => [Tuple k v] -> Map k v
+fromList = foldl (\m (Tuple k v) -> insert k v m) empty
+
+union :: forall k v. (P.Eq k, P.Ord k) => Map k v -> Map k v -> Map k v
+union m1 m2 = foldl (\m (Tuple k v) -> insert k v m) m2 (toList m1)
+
+map :: forall k v1 v2. (P.Eq k, P.Ord k) => (v1 -> v2) -> Map k v1 -> Map k v2
+map _ Leaf = Leaf
+map f (Branch b) = Branch (b { value = f b.value, left = map f b.left, right = map f b.right })

samples/PureScript/ReactiveJQueryTest.purs

@@ -0,0 +1,128 @@
+module ReactiveJQueryTest where
+
+import Prelude ((+), (++), (<$>), (<*>), ($), (<<<), flip, return, show)
+import Control.Monad
+import Control.Monad.Eff
+import Control.Monad.JQuery
+import Control.Reactive
+import Control.Reactive.JQuery
+import Data.Array (map, head, length)
+import Data.Foldable
+import Data.Foreign
+import Data.Maybe
+import Data.Monoid
+import Data.Traversable
+import Debug.Trace
+import Global (parseInt)
+
+main = do
+  personDemo
+  todoListDemo
+
+greet firstName lastName = "Hello, " ++ firstName ++ " " ++ lastName ++ "!"
+
+personDemo = do
+  -- Create new reactive variables to hold the user's names
+  firstName <- newRVar "John"
+  lastName <- newRVar "Smith"
+
+  -- Get the document body
+  b <- body
+
+  -- Create a text box for the first name
+  firstNameDiv <- create "<div>"
+  firstNameInput <- create "<input>"
+  "First Name: " `appendText` firstNameDiv
+  firstNameInput `append` firstNameDiv
+  firstNameDiv `append` b
+
+  -- Create a text box for the last name
+  lastNameDiv <- create "<div>"
+  lastNameInput <- create "<input>"
+  "Last Name: " `appendText` lastNameDiv
+  lastNameInput `append` lastNameDiv
+  lastNameDiv `append` b
+
+  -- Bind the text box values to the name variables
+  bindValueTwoWay firstName firstNameInput
+  bindValueTwoWay lastName lastNameInput
+
+  -- Create a paragraph to display a greeting
+  greeting <- create "<p>"
+  { color: "red" } `css` greeting
+  greeting `append` b
+
+  -- Bind the text property of the greeting paragraph to a computed property
+  let greetingC = greet <$> toComputed firstName <*> toComputed lastName
+  bindTextOneWay greetingC greeting
+
+todoListDemo = do
+  -- Get the document body
+  b <- body
+
+  -- Create an array
+  arr <- newRArray
+
+  text1 <- newRVar "Learn PureScript"
+  comp1 <- newRVar false
+  insertRArray arr { text: text1, completed: comp1 } 0
+  
+  ul <- create "<ul>"
+
+  -- Bind the ul to the array
+  bindArray arr ul $ \entry indexR -> do
+    li <- create "<li>"
+
+    completedInput <- create "<input>"
+    setAttr "type" "checkbox" completedInput
+    completedInput `append` li
+    sub1 <- bindCheckedTwoWay entry.completed completedInput
+    
+    textInput <- create "<input>"
+    textInput `append` li
+    sub2 <- bindValueTwoWay entry.text textInput
+
+    btn <- create "<button>"
+    "Remove" `appendText` btn
+    flip (on "click") btn $ do
+      index <- readRVar indexR
+      removeRArray arr index
+    btn `append` li
+
+    return { el: li, subscription: sub1 <> sub2 }
+
+  ul `append` b
+
+  -- Add button
+  newEntryDiv <- create "<div>"
+  btn <- create "<button>"
+  "Add" `appendText` btn
+  btn `append` newEntryDiv
+  newEntryDiv `append` b
+
+  flip (on "click") btn $ do
+    text <- newRVar ""
+    completed <- newRVar false
+    arr' <- readRArray arr
+    insertRArray arr { text: text, completed: completed } (length arr')
+
+  -- Create a paragraph to display the next task
+  nextTaskLabel <- create "<p>"
+  nextTaskLabel `append` b
+
+  let nextTask = do
+    task <- head <$> toComputedArray arr
+    case task of
+      Nothing -> return "Done!"
+      Just { text = text } -> (++) "Next task: " <$> toComputed text
+  bindTextOneWay nextTask nextTaskLabel
+
+  -- Create a paragraph to display the task counter
+  counterLabel <- create "<p>"
+  counterLabel `append` b
+
+  let counter = (flip (++) " tasks remaining") <<< show <$> do
+    rs <- toComputedArray arr
+    cs <- map (\c -> if c then 0 else 1) <$> traverse (\entry -> toComputed entry.completed) rs
+    return $ foldl (+) 0 cs
+  bindTextOneWay counter counterLabel