From 110fa6d384e2e074de739d935bdf3f39b9cfd3c0 Mon Sep 17 00:00:00 2001 From: Gary Burgess Date: Fri, 21 Mar 2014 23:55:20 +0000 Subject: [PATCH] Add PureScript language & samples --- lib/linguist/languages.yml | 6 + samples/PureScript/Control.Arrow.purs | 34 ++++++ samples/PureScript/Data.Foreign.purs | 111 ++++++++++++++++++ samples/PureScript/Data.Map.purs | 90 +++++++++++++++ samples/PureScript/ReactiveJQueryTest.purs | 128 +++++++++++++++++++++ 5 files changed, 369 insertions(+) create mode 100644 samples/PureScript/Control.Arrow.purs create mode 100644 samples/PureScript/Data.Foreign.purs create mode 100644 samples/PureScript/Data.Map.purs create mode 100644 samples/PureScript/ReactiveJQueryTest.purs diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index 6eb2a378..d61e9964 100644 --- a/lib/linguist/languages.yml +++ b/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 diff --git a/samples/PureScript/Control.Arrow.purs b/samples/PureScript/Control.Arrow.purs new file mode 100644 index 00000000..56ae846f --- /dev/null +++ b/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 diff --git a/samples/PureScript/Data.Foreign.purs b/samples/PureScript/Data.Foreign.purs new file mode 100644 index 00000000..d3d64f59 --- /dev/null +++ b/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 diff --git a/samples/PureScript/Data.Map.purs b/samples/PureScript/Data.Map.purs new file mode 100644 index 00000000..0733fac3 --- /dev/null +++ b/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 }) diff --git a/samples/PureScript/ReactiveJQueryTest.purs b/samples/PureScript/ReactiveJQueryTest.purs new file mode 100644 index 00000000..d1d941dc --- /dev/null +++ b/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 "
" + firstNameInput <- create "" + "First Name: " `appendText` firstNameDiv + firstNameInput `append` firstNameDiv + firstNameDiv `append` b + + -- Create a text box for the last name + lastNameDiv <- create "
" + lastNameInput <- create "" + "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 "

" + { 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 "

    " + + -- Bind the ul to the array + bindArray arr ul $ \entry indexR -> do + li <- create "
  • " + + completedInput <- create "" + setAttr "type" "checkbox" completedInput + completedInput `append` li + sub1 <- bindCheckedTwoWay entry.completed completedInput + + textInput <- create "" + textInput `append` li + sub2 <- bindValueTwoWay entry.text textInput + + btn <- create "