cherry-core-alpha (empty) → 0.1.0.0
raw patch · 39 files changed
+8627/−0 lines, 39 filesdep +asyncdep +basedep +base64-bytestringsetup-changed
Dependencies added: async, base, base64-bytestring, binary, bytestring, case-insensitive, cherry-core, containers, ghc-prim, hspec, http-client, http-client-tls, http-types, mtl, network, safe-exceptions, scientific, stm, text-utf8, time, unix, utf8-string, vector, wai, wai-extra, wai-middleware-static, warp
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +2/−0
- Setup.hs +2/−0
- cherry-core-alpha.cabal +109/−0
- src/Array.hs +277/−0
- src/Basics.hs +821/−0
- src/Bitwise.hs +105/−0
- src/Char.hs +217/−0
- src/Cherry/Prelude.hs +19/−0
- src/Debug.hs +77/−0
- src/Dict.hs +320/−0
- src/Environment.hs +24/−0
- src/File.hs +48/−0
- src/Http.hs +86/−0
- src/Internal/Shortcut.hs +71/−0
- src/Internal/Task.hs +185/−0
- src/Internal/Utils.hs +138/−0
- src/Interop.hs +40/−0
- src/Json/Decode.hs +1472/−0
- src/Json/Encode.hs +328/−0
- src/Json/String.hs +150/−0
- src/List.hs +506/−0
- src/Maybe.hs +176/−0
- src/Parser.hs +493/−0
- src/Parser/Reporting.hs +104/−0
- src/Result.hs +225/−0
- src/Server.hs +256/−0
- src/Set.hs +176/−0
- src/String.hs +680/−0
- src/Task.hs +113/−0
- src/Terminal.hs +48/−0
- src/Tuple.hs +123/−0
- src/Url.hs +117/−0
- src/Url/Builder.hs +235/−0
- src/Url/Parser.hs +429/−0
- src/Url/Parser/Internal.hs +13/−0
- src/Url/Parser/Query.hs +283/−0
- tests/Main.hs +124/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for cherry-core++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Tereza Sokol++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tereza Sokol nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,2 @@+# cherry-core+🍒 A library with basic functions and logging helpers.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cherry-core-alpha.cabal view
@@ -0,0 +1,109 @@+cabal-version: >=1.10+name: cherry-core-alpha+version: 0.1.0.0+synopsis: The core library for Cherry Haskell.+description: The core library for Cherry Haskell, including a standard fuctions, server, and json parsing.+license: BSD3+license-file: LICENSE+author: Tereza Sokol+maintainer: terezasokol@gmail.com+copyright: Tereza Sokol+category: Development+build-type: Simple+extra-source-files: CHANGELOG.md, README.md++source-repository head+ type: git+ location: https://github.com/cherry-haskell/cherry-core++library+ exposed-modules:+ Cherry.Prelude,+ Array,+ Basics,+ Bitwise,+ Char,+ Debug,+ Dict,+ Environment,+ File,+ Interop,+ Json.Decode,+ Json.Encode,+ Http,+ List,+ Maybe,+ Result,+ Set,+ Server,+ String,+ Url,+ Url.Builder,+ Url.Parser,+ Url.Parser.Query,+ Task,+ Terminal,+ Tuple+ other-modules:+ Internal.Shortcut,+ Internal.Task,+ Internal.Utils,+ Url.Parser.Internal+ Json.String,+ Parser+ Parser.Reporting+ default-extensions:+ OverloadedStrings,+ NoImplicitPrelude+ other-extensions:+ RankNTypes,+ GADTs,+ FlexibleInstances,+ MultiParamTypeClasses,+ BangPatterns,+ ImplicitPrelude,+ MagicHash,+ UnboxedTuples,+ Rank2Types,+ TypeSynonymInstances+ build-depends:+ async >=2.2 && <2.3,+ base >=4.12 && <4.13,+ binary,+ bytestring,+ containers >=0.6 && <0.7,+ ghc-prim,+ base64-bytestring,+ wai-middleware-static,+ wai-extra,+ warp,+ network,+ wai,+ http-client,+ http-client-tls,+ http-types,+ mtl,+ safe-exceptions,+ case-insensitive,+ scientific,+ stm,+ text-utf8 >=1.2 && <1.3,+ time,+ unix,+ utf8-string,+ vector >=0.12 && <0.13+ hs-source-dirs: src+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: tests+ ghc-options: -Wall+ build-depends: base >= 4.12.0 && < 4.13,+ hspec,+ text-utf8 >= 1.2.3 && < 1.3,+ containers >= 0.6.0 && < 0.7,+ cherry-core+ default-language: Haskell2010+ build-tool-depends: hspec-discover:hspec-discover == 2.*
+ src/Array.hs view
@@ -0,0 +1,277 @@++{-|++Module : Array+Description : Fast immutable arrays. The elements in an array must have the same type.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++Fast immutable arrays. The elements in an array must have the same type.++-}++module Array+ ( Array++ -- * Creation+ , empty, initialize, repeat, fromList++ -- * Query+ , isEmpty, length, get++ -- * Manipulate+ , set, push, append, slice++ -- * Lists+ , toList, toIndexedList++ -- * Transform+ , map, indexedMap, foldr, foldl, filter+ ) where+++import Data.Foldable (foldl', product, sum)+import Prelude (Applicative, Char, Eq, Functor, Monad, Num, Ord, Show, flip, fromIntegral, mappend, mconcat, otherwise, pure)+import Data.Vector ((!?), (++), (//))+import Basics ((&&), (+), (-), (<), (<=), (<|), (>>), Bool, Int, clamp)+import List (List)+import Maybe (Maybe (..))+import qualified Data.Vector+import qualified Data.Foldable+import qualified Data.Maybe as HM+import qualified List as List+import qualified Tuple as Tuple+++{-| An array.+-}+newtype Array a+ = Array (Data.Vector.Vector a)+ deriving (Eq, Show)+++{-| Return an empty array.++ > length empty == 0+-}+empty :: Array a+empty =+ Array Data.Vector.empty+++{-| Determine if an array is empty.++ > isEmpty empty == True++-}+isEmpty :: Array a -> Bool+isEmpty =+ unwrap >> Data.Vector.null++{-| Return the length of an array.++ > length (fromList [1,2,3]) == 3++-}+length :: Array a -> Int+length =+ unwrap+ >> Data.Vector.length+ >> fromIntegral+++{-| Initialize an array. `initialize n f` creates an array of length `n` with+the element at index `i` initialized to the result of `(f i)`.++ > initialize 4 identity == fromList [0,1,2,3]+ > initialize 4 (\n -> n*n) == fromList [0,1,4,9]+ > initialize 4 (always 0) == fromList [0,0,0,0]+-}+initialize :: Int -> (Int -> a) -> Array a+initialize n f =+ Array+ <| Data.Vector.generate+ (fromIntegral n)+ (fromIntegral >> f)+++{-| Creates an array with a given length, filled with a default element.++ > repeat 5 0 == fromList [0,0,0,0,0]+ > repeat 3 "cat" == fromList ["cat","cat","cat"]++Notice that `repeat 3 x` is the same as `initialize 3 (always x)`.+-}+repeat :: Int -> a -> Array a+repeat n e =+ Array+ <| Data.Vector.replicate (fromIntegral n) e+++{-| Create an array from a `List`.+-}+fromList :: List a -> Array a+fromList =+ Data.Vector.fromList >> Array+++{-| Return `Just` the element at the index or `Nothing` if the index is out of+range.++ > get 0 (fromList [0,1,2]) == Just 0+ > get 2 (fromList [0,1,2]) == Just 2+ > get 5 (fromList [0,1,2]) == Nothing+ > get -1 (fromList [0,1,2]) == Nothing+-}+get :: Int -> Array a -> Maybe a+get i array =+ case unwrap array !? fromIntegral i of+ HM.Just a -> Just a+ HM.Nothing -> Nothing+++{-| Set the element at a particular index. Returns an updated array.+If the index is out of range, the array is unaltered.++ > set 1 7 (fromList [1,2,3]) == fromList [1,7,3]+-}+set :: Int -> a -> Array a -> Array a+set i value array =+ let len = length array+ vector = unwrap array+ result =+ if 0 <= i && i < len+ then vector // [(fromIntegral i, value)]+ else vector+ in+ Array result+++{-| Push an element onto the end of an array.++ > push 3 (fromList [1,2]) == fromList [1,2,3]+-}+push :: a -> Array a -> Array a+push a (Array vector) =+ Array (Data.Vector.snoc vector a)+++{-| Create a list of elements from an array.++ > toList (fromList [3,5,8]) == [3,5,8]+-}+toList :: Array a -> List a+toList =+ unwrap >> Data.Vector.toList+++{-| Create an indexed list from an array. Each element of the array will be+paired with its index.++ > toIndexedList (fromList ["cat","dog"]) == [(0,"cat"), (1,"dog")]+-}+toIndexedList :: Array a -> List (Int, a)+toIndexedList =+ unwrap+ >> Data.Vector.indexed+ >> Data.Vector.toList+ >> List.map (Tuple.mapFirst fromIntegral)+++{-| Reduce an array from the right. Read `foldr` as fold from the right.++ > foldr (+) 0 (repeat 3 5) == 15+-}+foldr :: (a -> b -> b) -> b -> Array a -> b+foldr f value array =+ Data.Foldable.foldr f value (unwrap array)+++{-| Reduce an array from the left. Read `foldl` as fold from the left.++ > foldl (::) [] (fromList [1,2,3]) == [3,2,1]+-}+foldl :: (a -> b -> b) -> b -> Array a -> b+foldl f value array =+ foldl' (flip f) value (unwrap array)+++{-| Keep elements that pass the test.++ > filter isEven (fromList [1,2,3,4,5,6]) == (fromList [2,4,6])+-}+filter :: (a -> Bool) -> Array a -> Array a+filter f (Array vector) =+ Array (Data.Vector.filter f vector)+++{-| Apply a function on every element in an array.++ > map sqrt (fromList [1,4,9]) == fromList [1,2,3]+-}+map :: (a -> b) -> Array a -> Array b+map f (Array vector) =+ Array (Data.Vector.map f vector)+++{-| Apply a function on every element with its index as first argument.++ > indexedMap (*) (fromList [5,5,5]) == fromList [0,5,10]+-}+indexedMap :: (Int -> a -> b) -> Array a -> Array b+indexedMap f (Array vector) =+ Array (Data.Vector.imap (fromIntegral >> f) vector)+++{-| Append two arrays to a new one.++ > append (repeat 2 42) (repeat 3 81) == fromList [42,42,81,81,81]+-}+append :: Array a -> Array a -> Array a+append (Array first) (Array second) =+ Array (first ++ second)+++{-| Get a sub-section of an array: `(slice start end array)`. The `start` is a+zero-based index where we will start our slice. The `end` is a zero-based index+that indicates the end of the slice. The slice extracts up to but not including+`end`.++ > slice 0 3 (fromList [0,1,2,3,4]) == fromList [0,1,2]+ > slice 1 4 (fromList [0,1,2,3,4]) == fromList [1,2,3]++Both the `start` and `end` indexes can be negative, indicating an offset from+the end of the array.++ > slice 1 -1 (fromList [0,1,2,3,4]) == fromList [1,2,3]+ > slice -2 5 (fromList [0,1,2,3,4]) == fromList [3,4]++This makes it pretty easy to `pop` the last element off of an array:+`slice 0 -1 array`+-}+slice :: Int -> Int -> Array a -> Array a+slice from to (Array vector) =+ let len = Data.Vector.length vector+ handleNegative value = if value < 0 then len + value else value+ normalize = fromIntegral >> handleNegative >> clamp 0 len+ from' = normalize from+ to' = normalize to+ sliceLen = to' - from'+ in+ if sliceLen <= 0+ then empty+ else Array <| Data.Vector.slice from' sliceLen vector++++-- INTERNAL+++{-| Helper function to unwrap an array.++-}+unwrap :: Array a -> Data.Vector.Vector a+unwrap (Array v) =+ v
+ src/Basics.hs view
@@ -0,0 +1,821 @@+{-# LANGUAGE RankNTypes #-}++{-|++Module : Basics+Description : Basics for working with Cherry.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module Basics+ ( -- * Math+ Int, Float, (+), (-), (*), (/), (//), (^)++ -- * Int to Float / Float to Int+ , toFloat, round, floor, ceiling, truncate++ -- * Equality+ , (==), (/=)++ -- * Comparison+ , (<), (>), (<=), (>=), max, min, compare, Order(..)++ -- * Booleans+ , Bool(..), not, (&&), (||)++ -- * Append Strings and Lists+ , Appendable, (++)++ -- * Fancier Math+ , modBy, remainderBy, negate, abs, clamp, sqrt, logBase++ -- * Trigonometry+ , pi, cos, sin, tan, acos, asin, atan, atan2++ -- * Floating Point Checks+ , isNaN, isInfinite++ -- * Function Helpers+ , identity, always, (<|), (|>), (<<), (>>), Never, never+ ) where++import Prelude (Bool)+import qualified Prelude+import qualified List+import qualified String+++-- INFIX OPERATORS+++infixr 0 <|+infixl 0 |>+infixr 2 ||+infixr 3 &&+infix 4 ==, /=, <, >, <=, >=+infixr 5 +++infixl 6 +, -+infixl 7 *, /, //+infixr 8 ^+infixl 9 <<+infixr 9 >>++++-- MATHEMATICS+++{-| An `Int` is a whole number. Valid syntax for integers includes:++ > 0+ > 42+ > 9000+ > 0xFF -- 255 in hexadecimal+ > 0x000A -- 10 in hexadecimal++Historical Note: The name `Int` comes from the term [integer](https://en.wikipedia.org/wiki/Integer). It appears+that the `int` abbreviation was introduced in [ALGOL 68](https://en.wikipedia.org/wiki/ALGOL_68), shortening it+from `integer` in [ALGOL 60](https://en.wikipedia.org/wiki/ALGOL_60). Today, almost all programming languages use+this abbreviation.++-}+type Int = Prelude.Int+++{-| A `Float` is a [floating-point number](https://en.wikipedia.org/wiki/Floating-point_arithmetic). Valid syntax for floats includes:++ > 0+ > 42+ > 3.14+ > 0.1234+ > 6.022e23 -- == (6.022 * 10^23)+ > 6.022e+23 -- == (6.022 * 10^23)+ > 1.602e−19 -- == (1.602 * 10^-19)+ > 1e3 -- == (1 * 10^3) == 1000++Historical Note: The particular details of floats (e.g. `NaN`) are+specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_754) which is literally hard-coded into almost all+CPUs in the world. That means if you think `NaN` is weird, you must+successfully overtake Intel and AMD with a chip that is not backwards+compatible with any widely-used assembly language.++-}+type Float = Prelude.Double++++{-| Add two numbers. The `number` type variable means this operation can be+specialized to `Int -> Int -> Int` or to `Float -> Float -> Float`. So you+can do things like this:++ > 3002 + 4004 == 7006 -- all ints+ > 3.14 + 3.14 == 6.28 -- all floats++You _cannot_ add an `Int` and a `Float` directly though. Use functions like+`toFloat` or `round` to convert both values to the same type.+So if you needed to add a list length to a `Float` for some reason, you+could say one of these:++ > 3.14 + toFloat (List.length [1,2,3]) == 6.14+ > round 3.14 + List.length [1,2,3] == 6++-}+(+) :: Prelude.Num number => number -> number -> number+(+) =+ (Prelude.+)+++{-| Subtract numbers like `4 - 3 == 1`.++See `(+)` for docs on the `number` type variable.+-}+(-) :: (Prelude.Num number) => number -> number -> number+(-) =+ (Prelude.-)+++{-| Multiply numbers like `2 * 3 == 6`.++See `(+)` for docs on the `number` type variable.+-}+(*) :: (Prelude.Num number) => number -> number -> number+(*) =+ (Prelude.*)+++{-| Floating-point division:++ > 3.14 / 2 == 1.57+-}+(/) :: Float -> Float -> Float+(/) =+ (Prelude./)+++{-| Integer division:++ > 3 // 2 == 1++Notice that the remainder is discarded.+-}+(//) :: Int -> Int -> Int+(//) =+ Prelude.quot+++{-| Exponentiation++ > 3^2 == 9+ > 3^3 == 27+-}+(^) :: (Prelude.Num number, Prelude.Integral number) => number -> number -> number+(^) =+ (Prelude.^)++++-- INT TO FLOAT / FLOAT TO INT+++{-| Convert an integer into a float. Useful when mixing `Int` and `Float`+values like this:++ > halfOf :: Int -> Float+ > halfOf number =+ > toFloat number / 2++-}+toFloat :: Int -> Float+toFloat x =+ Prelude.fromIntegral x :: Float+++{-| Round a number to the nearest integer.++ > round 1.0 == 1+ > round 1.2 == 1+ > round 1.5 == 2+ > round 1.8 == 2+ > round -1.2 == -1+ > round -1.5 == -1+ > round -1.8 == -2++-}+round :: Float -> Int+round =+ Prelude.round+++{-| Floor function, rounding down.++ > floor 1.0 == 1+ > floor 1.2 == 1+ > floor 1.5 == 1+ > floor 1.8 == 1+ > floor -1.2 == -2+ > floor -1.5 == -2+ > floor -1.8 == -2++-}+floor :: Float -> Int+floor =+ Prelude.floor+++{-| Ceiling function, rounding up.++ > ceiling 1.0 == 1+ > ceiling 1.2 == 2+ > ceiling 1.5 == 2+ > ceiling 1.8 == 2+ > ceiling -1.2 == -1+ > ceiling -1.5 == -1+ > ceiling -1.8 == -1++-}+ceiling :: Float -> Int+ceiling =+ Prelude.ceiling+++{-| Truncate a number, rounding towards zero.++ > truncate 1.0 == 1+ > truncate 1.2 == 1+ > truncate 1.5 == 1+ > truncate 1.8 == 1+ > truncate -1.2 == -1+ > truncate -1.5 == -1+ > truncate -1.8 == -1++-}+truncate :: Float -> Int+truncate =+ Prelude.truncate++++-- EQUALITY+++{-| Check if values are “the same”.++-}+(==) :: (Prelude.Eq a) => a -> a -> Bool+(==) =+ (Prelude.==)+++{-| Check if values are not “the same”.++So `(a /= b)` is the same as `(not (a == b))`.+-}+(/=) :: (Prelude.Eq a) => a -> a -> Bool+(/=) =+ (Prelude./=)++++-- COMPARISONS+++{-|-}+(<) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool+(<) =+ (Prelude.<)+++{-|-}+(>) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool+(>) =+ (Prelude.>)+++{-|-}+(<=) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool+(<=) =+ (Prelude.<=)+++{-|-}+(>=) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool+(>=) =+ (Prelude.>=)+++{-| Find the smaller of two comparables.++ > min 42 12345678 == 42+ > min "abc" "xyz" == "abc"++-}+min :: (Prelude.Ord comparable) => comparable -> comparable -> comparable+min =+ Prelude.min+++{-| Find the larger of two comparables.++ > max 42 12345678 == 12345678+ > max "abc" "xyz" == "xyz"++-}+max :: (Prelude.Ord comparable) => comparable -> comparable -> comparable+max =+ Prelude.max+++{-| Compare any two comparable values. Comparable values include `String`,+`Char`, `Int`, `Float`, or a list or tuple containing comparable values. These+are also the only values that work as `Dict` keys or `Set` members.++ > compare 3 4 == LT+ > compare 4 4 == EQ+ > compare 5 4 == GT++-}+compare :: Prelude.Ord comparable => comparable -> comparable -> Order+compare =+ Prelude.compare+++{-| Represents the relative ordering of two things.++The relations are less than, equal to, and greater than.+-}+type Order = Prelude.Ordering++++-- BOOLEANS+++{-| Negate a boolean value.++ > not True == False+ > not False == True++-}+not :: Bool -> Bool+not =+ Prelude.not+++{-| The logical AND operator. `True` if both inputs are `True`.++ > True && True == True+ > True && False == False+ > False && True == False+ > False && False == _False++Note:_ When used in the infix position, like `(left && right)`, the operator+short-circuits. This means if `left` is `False` we do not bother evaluating `right`+and just return `False` overall.++-}+(&&) :: Bool -> Bool -> Bool+(&&) =+ (Prelude.&&)+++{-| The logical OR operator. `True` if one or both inputs are `True`.++ > True || True == True+ > True || False == True+ > False || True == True+ > False || False == False++Note: When used in the infix position, like `(left || right)`, the operator+short-circuits. This means if `left` is `True` we do not bother evaluating `right`+and just return `True` overall.++-}+(||) :: Bool -> Bool -> Bool+(||) =+ (Prelude.||)++++-- APPEND+++{-| Put two appendable things together. This includes strings and lists.++ > "hello" ++ "world" == "helloworld"+ > [1,1,2] ++ [3,5,8] == [1,1,2,3,5,8]++-}+(++) :: (Appendable appendable) => appendable -> appendable -> appendable+(++) =+ append+++class Appendable a where+ append :: a -> a -> a+++instance Appendable String.String where+ append = String.append+++instance Appendable [a] where+ append = List.append++++-- FANCIER MATH+++{-| Perform [modular arithmetic](https://en.wikipedia.org/wiki/Modular_arithmetic).+A common trick is to use (n mod 2) to detect even and odd numbers:++ > modBy 2 0 == 0+ > modBy 2 1 == 1+ > modBy 2 2 == 0+ > modBy 2 3 == 1++Our `modBy` function works in the typical mathematical way when you run into+negative numbers:++ > List.map (modBy 4) [ -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5 ]+ > -- [ 3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1 ]++Use `remainderBy` for a different treatment of negative numbers,+or read Daan Leijen’s [Division and Modulus for Computer Scientists](https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf) for more+information.++-}+modBy :: Int -> Int -> Int+modBy modulus n =+ n `Prelude.mod` modulus+++{-| Get the remainder after division. Here are bunch of examples of dividing by four:++ > List.map (remainderBy 4) [ -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5 ]+ > -- [ -1, 0, -3, -2, -1, 0, 1, 2, 3, 0, 1 ]++Use `modBy` for a different treatment of negative numbers,+or read Daan Leijen’s [Division and Modulus for Computer Scientists](https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/divmodnote-letter.pdf) for more+information.++-}+remainderBy :: Int -> Int -> Int+remainderBy divisor numerator =+ numerator `Prelude.rem` divisor+++{-| Negate a number.++ > negate 42 == -42+ > negate -42 == 42+ > negate 0 == 0++-}+negate :: (Prelude.Num number) => number -> number+negate =+ Prelude.negate+++{-| Get the [absolute value](https://en.wikipedia.org/wiki/Absolute_value) of a number.++ > abs 16 == 16+ > abs -4 == 4+ > abs -8.5 == 8.5+ > abs 3.14 == 3.14++-}+abs :: (Prelude.Num number) => number -> number+abs =+ Prelude.abs+++{-| Clamps a number within a given range. With the expression+`clamp 100 200 x` the results are as follows:++ > 100 if x < 100+ > x if 100 <= x < 200+ > 200 if 200 <= x++-}+clamp :: (Prelude.Num number, Prelude.Ord number) => number -> number -> number -> number+clamp low high number =+ if number < low then+ low+ else if number > high then+ high+ else+ number+++{-| Take the square root of a number.++ > sqrt 4 == 2+ > sqrt 9 == 3+ > sqrt 16 == 4+ > sqrt 25 == 5++-}+sqrt :: Float -> Float+sqrt =+ Prelude.sqrt+++{-| Calculate the logarithm of a number with a given base.++ > logBase 10 100 == 2+ > logBase 2 256 == 8++-}+logBase :: Float -> Float -> Float+logBase base number =+ Prelude.log number / Prelude.log base++++-- TRIGONOMETRY+++{-| An approximation of pi.++-}+pi :: Float+pi =+ Prelude.pi+++{-| Figure out the cosine given an angle in radians.++ > cos (degrees 60) == 0.5000000000000001+ > cos (turns (1/6)) == 0.5000000000000001+ > cos (radians (pi/3)) == 0.5000000000000001+ > cos (pi/3) == 0.5000000000000001++-}+cos :: Float -> Float+cos =+ Prelude.cos+++{-| Figure out the sine given an angle in radians.++ > sin (degrees 30) == 0.49999999999999994+ > sin (turns (1/12)) == 0.49999999999999994+ > sin (radians (pi/6)) == 0.49999999999999994+ > sin (pi/6) == 0.49999999999999994++-}+sin :: Float -> Float+sin =+ Prelude.sin+++{-| Figure out the tangent given an angle in radians.++ > tan (degrees 45) == 0.9999999999999999+ > tan (turns (1/8)) == 0.9999999999999999+ > tan (radians (pi/4)) == 0.9999999999999999+ > tan (pi/4) == 0.9999999999999999++-}+tan :: Float -> Float+tan =+ Prelude.tan+++{-| Figure out the arccosine for `adjacent / hypotenuse` in radians:++ > acos (1/2) == 1.0471975511965979 -- 60° or pi/3 radians++-}+acos :: Float -> Float+acos =+ Prelude.acos+++{-| Figure out the arcsine for `opposite / hypotenuse` in radians:++ > asin (1/2) == 0.5235987755982989 -- 30° or pi/6 radians++-}+asin :: Float -> Float+asin =+ Prelude.asin+++{-| This helps you find the angle (in radians) to an `(x,y)` coordinate, but+in a way that is rarely useful in programming. _You probably want+`atan2` instead!_++This version takes `y/x` as its argument, so there is no way to know whether+the negative signs comes from the `y` or `x` value. So as we go counter-clockwise+around the origin from point `(1,1)` to `(1,-1)` to `(-1,-1)` to `(-1,1)` we do+not get angles that go in the full circle:++ > atan ( 1 / 1 ) == 0.7853981633974483 -- 45° or pi/4 radians+ > atan ( 1 / -1 ) == -0.7853981633974483 -- 315° or 7*pi/4 radians+ > atan ( -1 / -1 ) == 0.7853981633974483 -- 45° or pi/4 radians+ > atan ( -1 / 1 ) == -0.7853981633974483 -- 315° or 7*pi/4 radians++Notice that everything is between `pi/2` and `-pi/2`. That is pretty useless+for figuring out angles in any sort of visualization, so again, check out+`atan2` instead!++-}+atan :: Float -> Float+atan =+ Prelude.atan+++{-| This helps you find the angle (in radians) to an `(x,y)` coordinate.+So rather than saying `atan (y/x)` you say `atan2 y x` and you can get a full+range of angles:++ > atan2 1 1 == 0.7853981633974483 -- 45° or pi/4 radians+ > atan2 1 -1 == 2.356194490192345 -- 135° or 3*pi/4 radians+ > atan2 -1 -1 == -2.356194490192345 -- 225° or 5*pi/4 radians+ > atan2 -1 1 == -0.7853981633974483 -- 315° or 7*pi/4 radians++-}+atan2 :: Float -> Float -> Float+atan2 =+ Prelude.atan2++++-- CRAZY FLOATS+++{-| Determine whether a float is an undefined or unrepresentable number.+NaN stands for *not a number* and it is [a standardized part of floating point+numbers](https://en.wikipedia.org/wiki/NaN).++ > isNaN (0/0) == True+ > isNaN (sqrt -1) == True+ > isNaN (1/0) == False -- infinity is a number+ > isNaN 1 == False++-}+isNaN :: Float -> Bool+isNaN =+ Prelude.isNaN+++{-| Determine whether a float is positive or negative infinity.++ > isInfinite (0/0) == False+ > isInfinite (sqrt -1) == False+ > isInfinite (1/0) == True+ > isInfinite 1 == False++Notice that NaN is not infinite! For float `n` to be finite implies+that `not (isInfinite n || isNaN n)` evaluates to `True`.+-}+isInfinite :: Float -> Bool+isInfinite =+ Prelude.isInfinite++++-- FUNCTION HELPERS+++{-| Function composition, passing results along in the suggested direction. For+example, the following code checks if the square root of a number is odd:++ > not << isEven << sqrt++You can think of this operator as equivalent to the following:++ > (g << f) == (\x -> g (f x))++So our example expands out to something like this:++ > \n -> not (isEven (sqrt n))++-}+(<<) :: (b -> c) -> (a -> b) -> (a -> c)+(<<) g f x =+ g (f x)+++{-| Function composition, passing results along in the suggested direction. For+example, the following code checks if the square root of a number is odd:++ > sqrt >> isEven >> not++-}+(>>) :: (a -> b) -> (b -> c) -> (a -> c)+(>>) f g x =+ g (f x)+++{-| Saying `x |> f` is exactly the same as `f x`.+It is called the “pipe” operator because it lets you write “pipelined” code.+For example, say we have a `sanitize` function for turning user input into+integers:++ > -- BEFORE+ > sanitize :: String -> Maybe Int+ > sanitize input =+ > String.toInt (String.trim input)++We can rewrite it like this:++ > -- AFTER+ > sanitize :: String -> Maybe Int+ > sanitize input =+ > input+ > |> String.trim+ > |> String.toInt++Totally equivalent! I recommend trying to rewrite code that uses `x |> f`+into code like `f x` until there are no pipes left. That can help you build+your intuition.++Note: This can be overused! I think folks find it quite neat, but when you+have three or four steps, the code often gets clearer if you break out a+top-level helper function. Now the transformation has a name. The arguments are+named. It has a type annotation. It is much more self-documenting that way!+Testing the logic gets easier too. Nice side benefit!++-}+(|>) :: a -> (a -> b) -> b+(|>) x f =+ f x+++{-| Saying `f <| x` is exactly the same as `f x`.++It can help you avoid parentheses, which can be nice sometimes. Maybe you want+to apply a function to a `case` expression? That sort of thing.++-}+(<|) :: (a -> b) -> a -> b+(<|) f x =+ f x+++{-| Given a value, returns exactly the same value. This is called+[the identity function](https://en.wikipedia.org/wiki/Identity_function).++-}+identity :: a -> a+identity x =+ x+++{-| Create a function that always returns the same value. Useful with+functions like `map`:++ > List.map (always 0) [1,2,3,4,5] == [0,0,0,0,0]+ > -- List.map (\_ -> 0) [1,2,3,4,5] == [0,0,0,0,0]+ > -- always = (\x _ -> x)++-}+always :: a -> b -> a+always a _ =+ a+++{-| A value that can never happen! For context:++ - The boolean type `Bool` has two values: `True` and `False`+ - The unit type `()` has one value: `()`+ - The never type `Never` has no values!++The `Never` type is useful for restricting *arguments* to a function. Maybe my+API can only accept a result which never fails, so I require `Result Never a` and+users can give `Result msg` and everything will go fine. Generally speaking, you+do not want `Never` in your return types though.++-}+data Never+ = JustOneMore Never+++{-| A function that can never be called. Seems extremely pointless, but it+*can* come in handy. Imagine you have some HTML that should never produce any+messages. And say you want to use it in some other HTML that *does* produce+messages. You could say:++ > import Html exposing (..)+ >+ > embedHtml :: Html Never -> Html msg+ > embedHtml staticStuff =+ > div []+ > [ text "hello"+ > , Html.map never staticStuff+ > ]++So the `never` function is basically telling the type system, make sure no one+ever calls me!++-}+never :: Never -> a+never (JustOneMore nvr) =+ never nvr
+ src/Bitwise.hs view
@@ -0,0 +1,105 @@++{-|++Module : Bitwise+Description : Work with bits.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module Bitwise+ ( and,+ or,+ xor,+ complement,+ shiftLeftBy,+ shiftRightBy,+ shiftRightZfBy,+ )+where++import Data.Bits ((.&.), (.|.))+import Basics (Int)+import qualified Prelude+import qualified Data.Bits+++{-| Bitwise AND+-}+and :: Int -> Int -> Int+and =+ (.&.)+++{-| Bitwise OR+-}+or :: Int -> Int -> Int+or =+ (.|.)+++{-| Bitwise XOR+-}+xor :: Int -> Int -> Int+xor = Data.Bits.xor+++{-| Flip each bit individually, often called bitwise NOT+-}+complement :: Int -> Int+complement = Data.Bits.complement+++{-| Shift bits to the left by a given offset, filling new bits with zeros.+This can be used to multiply numbers by powers of two.++ > shiftLeftBy 1 5 == 10+ > shiftLeftBy 5 1 == 32+-}+shiftLeftBy :: Int -> Int -> Int+shiftLeftBy offset value =+ Data.Bits.shift value (Prelude.fromIntegral offset)+++{-| Shift bits to the right by a given offset, filling new bits with+whatever is the topmost bit. This can be used to divide numbers by powers of two.++ > shiftRightBy 1 32 == 16+ > shiftRightBy 2 32 == 8+ > shiftRightBy 1 -32 == -16++This is called an [arithmetic right shift](https://en.wikipedia.org/wiki/Bitwise_operation#Arithmetic_shift), often written `>>`, and+sometimes called a sign-propagating right shift because it fills empty spots+with copies of the highest bit.++-}+shiftRightBy :: Int -> Int -> Int+shiftRightBy offset value =+ Data.Bits.shiftR value (Prelude.fromIntegral offset)+++{-| Shift bits to the right by a given offset, filling new bits with zeros.++ > shiftRightZfBy 1 32 == 16+ > shiftRightZfBy 2 32 == 8+ > shiftRightZfBy 1 -32 == 2147483632++This is called an [logical right shift](https://en.wikipedia.org/wiki/Bitwise_operation#Logical_shift), often written `>>>`, and+sometimes called a zero-fill right shift because it fills empty spots with+zeros.++-}+shiftRightZfBy :: Int -> Int -> Int+shiftRightZfBy offset value =+ -- For some reason Data.Bits does not implement this function. The general idea is:+ -- 1. Generate a mask that will clear the leftmost n bits when ANDed with the result.+ -- 2. Shift right by n bits.+ -- 3. Bitwise AND the mask.+ let n = Prelude.fromIntegral offset+ oneBits = Data.Bits.complement Data.Bits.zeroBits :: Int+ shiftedValue = Data.Bits.shiftR value n+ shiftedMask = Data.Bits.rotateR (Data.Bits.shiftL oneBits n) n+ in and shiftedValue shiftedMask
+ src/Char.hs view
@@ -0,0 +1,217 @@++{-|++Module : Char+Description : Functions for working with characters. Character literals are enclosed in `'a'` pair of single quotes.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++Functions for working with characters. Character literals are enclosed in `'a'` pair of single quotes.++-}++module Char+ ( -- * Characters+ Char++ -- * ASCII Letters+ , isUpper, isLower, isAlpha, isAlphaNum++ -- * Digits+ , isDigit, isOctDigit, isHexDigit++ -- * Conversion+ , toUpper, toLower++ -- * Unicode Code Points+ , toCode, fromCode+ ) where++import Prelude (Applicative, Eq, Functor, Monad, Num, Ord, Show, Bool(..), Int, (&&), (<=), flip, mappend, mconcat, otherwise, pure)+import qualified Data.Char+++{-| A `Char` is a single [unicode](https://en.wikipedia.org/wiki/Unicode) character:++ > 'a'+ > '0'+ > 'Z'+ > '?'+ > '"'+ > 'Σ'+ > '🙈'+ >+ > '\t'+ > '\"'+ > '\''+ > '\u{1F648}' -- '🙈'++Note 2: You can use the unicode escapes from `\u{0000}` to `\u{10FFFF}` to+represent characters by their code point. You can also include the unicode+characters directly. Using the escapes can be better if you need one of the+many whitespace characters with different widths.++-}+type Char =+ Data.Char.Char+++{-| Detect upper case ASCII characters.++ > isUpper 'A' == True+ > isUpper 'B' == True+ > ...+ > isUpper 'Z' == True+ >+ > isUpper '0' == False+ > isUpper 'a' == False+ > isUpper '-' == False+ > isUpper 'Σ' == False++-}+isUpper :: Char -> Bool+isUpper =+ Data.Char.isUpper+++{-| Detect lower case ASCII characters.++ > isLower 'a' == True+ > isLower 'b' == True+ > ...+ > isLower 'z' == True+ >+ > isLower '0' == False+ > isLower 'A' == False+ > isLower '-' == False+ > isLower 'π' == False++-}+isLower :: Char -> Bool+isLower =+ Data.Char.isLower+++{-| Detect upper case and lower case ASCII characters.++ > isAlpha 'a' == True+ > isAlpha 'b' == True+ > isAlpha 'E' == True+ > isAlpha 'Y' == True+ >+ > isAlpha '0' == False+ > isAlpha '-' == False+ > isAlpha 'π' == False++-}+isAlpha :: Char -> Bool+isAlpha =+ Data.Char.isAlpha+++{-| Detect upper case and lower case ASCII characters.++ > isAlphaNum 'a' == True+ > isAlphaNum 'b' == True+ > isAlphaNum 'E' == True+ > isAlphaNum 'Y' == True+ > isAlphaNum '0' == True+ > isAlphaNum '7' == True+ >+ > isAlphaNum '-' == False+ > isAlphaNum 'π' == False++-}+isAlphaNum :: Char -> Bool+isAlphaNum =+ Data.Char.isAlphaNum+++{-| Detect digits `0123456789`++ > isDigit '0' == True+ > isDigit '1' == True+ > ...+ > isDigit '9' == True+ >+ > isDigit 'a' == False+ > isDigit 'b' == False+ > isDigit 'A' == False++-}+isDigit :: Char -> Bool+isDigit =+ Data.Char.isDigit+++{-| Detect octal digits `01234567`++ > isOctDigit '0' == True+ > isOctDigit '1' == True+ > ...+ > isOctDigit '7' == True+ >+ > isOctDigit '8' == False+ > isOctDigit 'a' == False+ > isOctDigit 'A' == False++-}+isOctDigit :: Char -> Bool+isOctDigit =+ Data.Char.isOctDigit+++{-| Detect hexadecimal digits `0123456789abcdefABCDEF`+-}+isHexDigit :: Char -> Bool+isHexDigit =+ Data.Char.isHexDigit+++{-| Convert to upper case. -}+toUpper :: Char -> Char+toUpper =+ Data.Char.toUpper+++{-| Convert to lower case. -}+toLower :: Char -> Char+toLower =+ Data.Char.toLower+++{-| Convert to the corresponding Unicode [code point](https://en.wikipedia.org/wiki/Code_point).++ > toCode 'A' == 65+ > toCode 'B' == 66+ > toCode '木' == 0x6728+ > toCode '𝌆' == 0x1D306+ > toCode '😃' == 0x1F603++-}+toCode :: Char -> Int+toCode =+ Data.Char.ord+++{-| Convert a Unicode [code point](https://en.wikipedia.org/wiki/Code_point) to a character.++ > fromCode 65 == 'A'+ > fromCode 66 == 'B'+ > fromCode 0x6728 == '木'+ > fromCode 0x1D306 == '𝌆'+ > fromCode 0x1F603 == '😃'+ > fromCode -1 == '�'++The full range of unicode is from `0` to `0x10FFFF`. With numbers outside that+range, you get [the replacement character](https://en.wikipedia.org/wiki/Specials_(Unicode_block)#Replacement_character).++-}+fromCode :: Int -> Char+fromCode value =+ if 0 <= value && value <= 0x10FFFF then+ Data.Char.chr value+ else+ '\xfffd'
+ src/Cherry/Prelude.hs view
@@ -0,0 +1,19 @@+module Cherry.Prelude+ ( module Basics+ , module Terminal+ , Prelude.IO, Maybe(..), Result(..), Dict, String, List, Array, Set, Char, Task+ )+where++import qualified Prelude+import Basics+import Terminal+import Maybe (Maybe (..))+import Result (Result (..))+import String (String)+import Dict (Dict)+import List (List)+import Array (Array)+import Set (Set)+import Char (Char)+import Task (Task)
+ src/Debug.hs view
@@ -0,0 +1,77 @@++{-|++Module : Debug+Description : This module can be useful while _developing_ an application.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}+++module Debug+ ( toString,+ log,+ todo,+ )+where++import Prelude (Show, error, show)+import Basics ((>>))+import String (String)+import qualified String+import qualified Debug.Trace+++{-| Turn any kind of value into a string.++ > toString 42 == "42"+ > toString [1,2] == "[1,2]"+ > toString ('a', "cat", 13) == "('a', \"cat\", 13)"+ > toString "he said, \"hi\"" == "\"he said, \\\"hi\\\"\""++-}+toString :: Show a => a -> String+toString value =+ String.fromList (show value)+++{-| Log a tagged value on the developer console, and then return the value.++ > 1 + log "number" 1 -- equals 2, logs "number: 1"+ > length (log "start" []) -- equals 0, logs "start: []"++It is often possible to sprinkle this around to see if values are what you+expect. It is kind of old-school to do it this way, but it works!++-}+log :: Show a => String -> a -> a+log message value =+ Debug.Trace.trace (String.toList (String.concat [message, ": ", toString value])) value+++{-| This is a placeholder for code that you will write later.++For example, if you are working with a large union type and have partially+completed a case expression, it may make sense to do this:++ > type Entity = Ship | Fish | Captain | Seagull+ >+ > drawEntity entity =+ > case entity of+ > Ship ->+ > ...+ >+ > Fish ->+ > ...+ >+ > _ ->+ > Debug.todo "handle Captain and Seagull"+ >++-}+todo :: String -> a+todo msg =+ error (String.toList msg)
+ src/Dict.hs view
@@ -0,0 +1,320 @@++{-|++Module : Dict+Description : A dictionary mapping unique keys to values.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++A dictionary mapping unique keys to values. The keys can be any comparable type. This includes `Int`, `Float`, `Time`, `Char`, `String`, and tuples or lists of comparable types. Insert, remove, and query operations all take *O(log n)* time.++-}+++module Dict+ ( -- * Dictionaries+ Dict++ -- * Build+ , empty, singleton, insert, update, remove++ -- * Query+ , isEmpty, member, get, size++ -- * Lists+ , keys, values, toList, fromList++ -- * Transform+ , map, foldl, foldr, filter, partition++ -- * Combine+ , union, intersect, diff, merge+ ) where++import Prelude (Applicative, Char, Eq, Functor, Monad, Num, Ord, Show, flip, fromIntegral, mappend, mconcat, otherwise, pure)+import Basics+import List (List)+import Maybe (Maybe (..))+import qualified Data.Maybe+import qualified Data.Map.Strict+import qualified List as List+++-- DICTIONARIES+++{-| A dictionary of keys and values. So a `Dict String User` is a dictionary+that lets you look up a `String` (such as user names) and find the associated+`User`.++ > import Dict exposing (Dict)+ >+ > users :: Dict String User+ > users =+ > Dict.fromList+ > [ ("Alice", User "Alice" 28 1.65)+ > , ("Bob" , User "Bob" 19 1.82)+ > , ("Chuck", User "Chuck" 33 1.75)+ > ]+ >+ > data User = User+ > { name :: String+ > , age :: Int+ > , height :: Float+ > }++-}+type Dict k v =+ Data.Map.Strict.Map k v+++{-| Create an empty dictionary. -}+empty :: Dict k v+empty =+ Data.Map.Strict.empty+++{-| Get the value associated with a key. If the key is not found, return+`Nothing`. This is useful when you are not sure if a key will be in the+dictionary.++ > animals = fromList [ ("Tom", Cat), ("Jerry", Mouse) ]+ >+ > get "Tom" animals == Just Cat+ > get "Jerry" animals == Just Mouse+ > get "Spike" animals == Nothing++-}+get :: Ord comparable => comparable -> Dict comparable v -> Maybe v+get a =+ Data.Map.Strict.lookup a >> fromHMaybe+++{-| Determine if a key is in a dictionary. -}+member :: Ord comparable => comparable -> Dict comparable v -> Bool+member =+ Data.Map.Strict.member+++{-| Determine the number of key-value pairs in the dictionary. -}+size :: Dict k v -> Int+size =+ Data.Map.Strict.size >> fromIntegral+++{-| Determine if a dictionary is empty.++ > isEmpty empty == True+-}+isEmpty :: Dict k v -> Bool+isEmpty =+ Data.Map.Strict.null+++{-| Insert a key-value pair into a dictionary. Replaces value when there is+a collision. -}+insert :: Ord comparable => comparable -> v -> Dict comparable v -> Dict comparable v+insert =+ Data.Map.Strict.insert+++{-| Remove a key-value pair from a dictionary. If the key is not found,+no changes are made. -}+remove :: Ord comparable => comparable -> Dict comparable v -> Dict comparable v+remove =+ Data.Map.Strict.delete+++{-| Update the value of a dictionary for a specific key with a given function. -}+update :: Ord comparable => comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v+update targetKey alter dictionary =+ let maybeItemToSet =+ Data.Map.Strict.lookup targetKey dictionary |> fromHMaybe |> alter+ in case maybeItemToSet of+ Just itemToSet ->+ Data.Map.Strict.insert targetKey itemToSet dictionary+ Nothing ->+ Data.Map.Strict.delete targetKey dictionary+++{-| Create a dictionary with one key-value pair. -}+singleton :: comparable -> v -> Dict comparable v+singleton =+ Data.Map.Strict.singleton++++-- COMBINE+++{-| Combine two dictionaries. If there is a collision, preference is given+to the first dictionary.+-}+union :: Ord comparable => Dict comparable v -> Dict comparable v -> Dict comparable v+union =+ Data.Map.Strict.union+++{-| Keep a key-value pair when its key appears in the second dictionary.+Preference is given to values in the first dictionary.+-}+intersect :: Ord comparable => Dict comparable v -> Dict comparable v -> Dict comparable v+intersect =+ Data.Map.Strict.intersection+++{-| Keep a key-value pair when its key does not appear in the second dictionary.+-}+diff :: Ord comparable => Dict comparable a -> Dict comparable b -> Dict comparable a+diff =+ Data.Map.Strict.difference+++{-| The most general way of combining two dictionaries. You provide three+accumulators for when a given key appears:++ 1. Only in the left dictionary.+ 2. In both dictionaries.+ 3. Only in the right dictionary.++You then traverse all the keys from lowest to highest, building up whatever+you want.+-}+merge ::+ Ord comparable =>+ (comparable -> a -> result -> result) ->+ (comparable -> a -> b -> result -> result) ->+ (comparable -> b -> result -> result) ->+ Dict comparable a ->+ Dict comparable b ->+ result ->+ result+merge leftStep bothStep rightStep leftDict rightDict initialResult =+ let stepState rKey rValue (list, result) =+ case list of+ [] ->+ (list, rightStep rKey rValue result)++ (lKey, lValue) : rest ->+ if lKey < rKey then stepState rKey rValue (rest, leftStep lKey lValue result)+ else if lKey > rKey then (list, rightStep rKey rValue result)+ else (rest, bothStep lKey lValue rValue result)++ (leftovers, intermediateResult) =+ foldl stepState (toList leftDict, initialResult) rightDict+ in+ List.foldl (\(k, v) result -> leftStep k v result) intermediateResult leftovers++++-- TRANSFORM+++{-| Apply a function to all values in a dictionary.+-}+map :: (k -> a -> b) -> Dict k a -> Dict k b+map = Data.Map.Strict.mapWithKey+++{-| Fold over the key-value pairs in a dictionary from lowest key to highest key.++ > import Dict exposing (Dict)+ >+ > getAges :: Dict String User -> List String+ > getAges users =+ > Dict.foldl addAge [] users+ >+ > addAge :: String -> User -> List String -> List String+ > addAge _ user ages =+ > user.age : ages+ >+ > -- getAges users == [33,19,28]++-}+foldl :: (k -> v -> b -> b) -> b -> Dict k v -> b+foldl fun =+ let flippedFun acc key value = fun key value acc+ in+ Data.Map.Strict.foldlWithKey' flippedFun+++{-| Fold over the key-value pairs in a dictionary from highest key to lowest key.++ > import Dict exposing (Dict)+ >+ > getAges :: Dict String User -> List String+ > getAges users =+ > Dict.foldr addAge [] users+ >+ > addAge :: String -> User -> List String -> List String+ > addAge _ user ages =+ > user.age : ages+ >+ > -- getAges users == [28,19,33]++-}+foldr :: (k -> v -> b -> b) -> b -> Dict k v -> b+foldr =+ Data.Map.Strict.foldrWithKey+++{-| Keep only the key-value pairs that pass the given test. -}+filter :: (comparable -> v -> Bool) -> Dict comparable v -> Dict comparable v+filter =+ Data.Map.Strict.filterWithKey+++{-| Partition a dictionary according to some test. The first dictionary+contains all key-value pairs which passed the test, and the second contains+the pairs that did not.+-}+partition :: (comparable -> v -> Bool) -> Dict comparable v -> (Dict comparable v, Dict comparable v)+partition =+ Data.Map.Strict.partitionWithKey++++-- LISTS+++{-| Get all of the keys in a dictionary, sorted from lowest to highest.++ > keys (fromList [(0,"Alice"),(1,"Bob")]) == [0,1]+-}+keys :: Dict k v -> List k+keys =+ Data.Map.Strict.keys+++{-| Get all of the values in a dictionary, in the order of their keys.++ > values (fromList [(0,"Alice"),(1,"Bob")]) == ["Alice", "Bob"]+-}+values :: Dict k v -> List v+values =+ Data.Map.Strict.elems+++{-| Convert a dictionary into an association list of key-value pairs, sorted by keys. -}+toList :: Dict k v -> List (k, v)+toList =+ Data.Map.Strict.toList+++{-| Convert an association list into a dictionary. -}+fromList :: Ord comparable => List (comparable, v) -> Dict comparable v+fromList =+ Data.Map.Strict.fromList++++-- INTERNAL+++fromHMaybe :: Data.Maybe.Maybe a -> Maybe a+fromHMaybe maybe =+ case maybe of+ Data.Maybe.Just a -> Just a+ Data.Maybe.Nothing -> Nothing
+ src/Environment.hs view
@@ -0,0 +1,24 @@+module Environment (variable) where++import qualified System.Environment+import qualified Data.ByteString as ByteString+import qualified Internal.Shortcut as IO+import qualified Interop+import qualified Task+import qualified Result+import qualified String+import qualified Maybe+import qualified Task+import qualified Prelude+import Cherry.Prelude+++{-| -}+variable :: String -> Task String String+variable name =+ Interop.fromResult <| do+ var <- System.Environment.lookupEnv (String.toList name)+ Prelude.return <| case var of+ Prelude.Nothing -> Err "Could not read variable."+ Prelude.Just value -> Ok (String.fromList value)+
+ src/File.hs view
@@ -0,0 +1,48 @@++{-|++Module : File+Description : Read and write to a file.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++Read and write to a file.++-}++module File (read, write) where++import qualified List+import qualified String+import qualified Internal.Task as Task+import qualified Internal.Utils as U+import qualified Data.Text.IO as IO+import Prelude (return, getContents)+import Basics+import Maybe (Maybe (..))+import Result (Result (..))+import String (String)+import Dict (Dict)+import List (List)+import Array (Array)+import Task (Task)+import Set (Set)+import Char (Char)+++{-| -}+write :: String -> String -> Task x ()+write filename string =+ Task.Task <| do+ IO.writeFile (String.toList filename) (String.toTextUtf8 string)+ return (Ok ())+++{-| -}+read :: String -> Task x String+read filename =+ Task.Task <| do+ contents <- IO.readFile (String.toList filename)+ return (Ok (String.fromTextUtf8 contents))
+ src/Http.hs view
@@ -0,0 +1,86 @@+{-|++Module : Http+Description : Send HTTPS requests.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module Http (Request, Response, Key, Decoder(..), getKey, post) where++import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Middleware.Static as Static+import qualified Network.Wai.Middleware.RequestLogger as RequestLogger+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Types.Method as Method+import qualified Network.HTTP.Types.Header as Header+import qualified Network.HTTP.Client as Client+import qualified Network.HTTP.Client.TLS as TLS+import qualified Internal.Shortcut as Shortcut+import qualified Data.ByteString.Lazy as BL+import qualified Prelude+import qualified Maybe+import qualified String+import qualified List+import qualified Tuple+import qualified Result+import qualified Dict+import qualified Task+import qualified Terminal+import qualified Url+import qualified Url.Parser as Parser+import qualified Interop+import qualified Json.Encode as E+import qualified Json.Decode as D+import Cherry.Prelude++++{-| -}+type Request =+ Wai.Request+++{-| -}+type Response =+ Wai.Response+++data Key+ = Key Client.Manager+++{-| -}+getKey :: IO Key+getKey =+ Shortcut.map Key TLS.newTlsManager+++data Decoder a+ = Json (D.Decoder a)+ | Text (String -> Result String a)+++{-| -}+post :: Key -> String -> E.Value -> Decoder a -> Task String a+post (Key manager) url body decoder =+ Interop.fromResult <| do+ base <- Client.parseRequest (String.toList url)+ let request = base { Client.method = "POST", Client.requestBody = Client.RequestBodyBuilder 1 (E.toBuilder body) }+ response <- Client.httpLbs request manager+ Prelude.return (decodeResponse decoder (Client.responseBody response))+++decodeResponse :: Decoder a -> BL.ByteString -> Result String a+decodeResponse decoder bs =+ case decoder of+ Json decoder ->+ D.fromString decoder (String.fromLazyByteString bs)+ |> Result.mapError (\_ -> "Could not decode body.") -- TODO++ Text decoder ->+ decoder (String.fromLazyByteString bs)
+ src/Internal/Shortcut.hs view
@@ -0,0 +1,71 @@+module Internal.Shortcut (map, map2, map3, map4, map5, map6, map7, map8, map9, andThen, afterwards) where++import Prelude ((<$>), (<*>), (>>=), Applicative, Monad, fmap, return)+++{-| -}+andThen :: Monad m => (a -> m b) -> m a -> m b+andThen b a =+ a >>= b+++{-| -}+afterwards :: Monad m => m b -> m a -> m b+afterwards b a =+ a >>= (\_ -> b)+++{-| -}+map :: (Applicative m) => (a -> value) -> m a -> m value+map f a =+ fmap f a+++{-| -}+map2 :: (Applicative m) => (a -> b -> value) -> m a -> m b -> m value+map2 func a b =+ func <$> a <*> b+++{-| -}+map3 :: (Applicative m) => (a -> b -> c -> value) -> m a -> m b -> m c -> m value+map3 func a b c =+ func <$> a <*> b <*> c+++{-| -}+map4 :: (Applicative m) => (a -> b -> c -> d -> value) -> m a -> m b -> m c -> m d -> m value+map4 func a b c d =+ func <$> a <*> b <*> c <*> d+++{-| -}+map5 :: (Applicative m) => (a -> b -> c -> d -> e -> value) -> m a -> m b -> m c -> m d -> m e -> m value+map5 func a b c d e =+ func <$> a <*> b <*> c <*> d <*> e+++{-| -}+map6 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m value+map6 func a b c d e f =+ func <$> a <*> b <*> c <*> d <*> e <*> f+++{-| -}+map7 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> g -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m value+map7 func a b c d e f g =+ func <$> a <*> b <*> c <*> d <*> e <*> f <*> g+++{-| -}+map8 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> g -> h -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m h -> m value+map8 func a b c d e f g h =+ func <$> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h+++{-| -}+map9 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> g -> h -> i -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m h -> m i -> m value+map9 func a b c d e f g h i =+ func <$> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h <*> i++
+ src/Internal/Task.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Internal.Task where++import qualified Prelude as P+import qualified Data.Text+import qualified Control.Exception.Safe as Control+import qualified Data.Text.Encoding+import qualified Data.ByteString.Lazy as ByteString+import qualified GHC.Stack as Stack+import qualified Internal.Shortcut as Shortcut+import qualified Control.Concurrent.MVar as MVar+import qualified System.IO+import qualified List+import qualified Dict+import qualified String+import qualified Result+import qualified Tuple+import qualified Debug+import qualified System.IO+import qualified Data.Time.Clock as Clock+import qualified GHC.Stack as Stack+import qualified Internal.Utils as Utils+import Prelude (IO, Show, Functor, Monad, Applicative, FilePath, sequence_, pure, return, fmap, show)+import Control.Monad (void)+import Internal.Shortcut+import Basics+import Maybe (Maybe (..))+import Result (Result (..))+import String (String)+import Dict (Dict)+import List (List)+import Array (Array)+import Set (Set)+import Char (Char)++++{-| A task is a __description__ of what you need to do. Like a todo+list. Or like a grocery list. Or like GitHub issues. So saying "the task is+to tell me the current POSIX time" does not complete the task! You need+`perform` tasks or `attempt` tasks.+-}+newtype Task x a =+ Task { toIO :: IO (Result x a) }+++instance Functor (Task a) where+ fmap func task =+ Task <| do+ fmap (Result.map func) (toIO task)+++instance Applicative (Task a) where+ pure a =+ succeed a++ (<*>) func task =+ Task <| do+ rFunc <- toIO func+ rTask <- toIO task+ let apply f t = f t+ return (Result.map2 apply rFunc rTask)+++instance Monad (Task a) where+ task >>= func =+ Task <| do+ result <- toIO task+ case result of+ Ok ok -> toIO (func ok)+ Err err -> return (Err err)++++-- BASICS+++{-| Just having a `Task` does not mean it is done. We must `perform` the task:++ > import Cherry.Prelude+ >+ > main =+ > Task.perform Time.now++-}+perform :: Task Never a -> IO a+perform task = do+ Ok a <- attempt task+ return a+++{-| Like `perform`, except for tasks which can fail.+-}+attempt :: Task x a -> IO (Result x a)+attempt task =+ toIO task+++{-| A task that succeeds immediately when run. Often useful in the last+statement of a `do` block.++ > import Time+ >+ > timeAndZone :: Task x (Time.Posix, Time.Zone)+ > timeAndZone = do+ > time <- Time.now+ > timezone <- Time.here+ > Task.succeed (time, timezone)++-}+succeed :: a -> Task x a+succeed a =+ Task <| return (Ok a)+++{-| A task that fails immediately when run. Like with `succeed`, this can be+used with `andThen` to check on the outcome of another task.++ > type Error = NotFound+ >+ > notFound :: Task Error a+ > notFound =+ > fail NotFound+-}+fail :: x -> Task x a+fail x =+ Task <| return (Err x)+++{-| Start with a list of tasks, and turn them into a single task that returns a+list. The tasks will be run in order one-by-one and if any task fails the whole+sequence fails.++ > sequence [ succeed 1, succeed 2 ] == succeed [ 1, 2 ]++-}+sequence :: List (Task x a) -> Task x (List a)+sequence tasks =+ List.foldr (map2 (:)) (succeed []) tasks+++{-| Recover from a failure in a task. If the given task fails, we use the+callback to recover.++ > fail "file not found"+ > |> onError (\msg -> succeed 42)+ > -- succeed 42+ >+ > succeed 9+ > |> onError (\msg -> succeed 42)+ > -- succeed 9+-}+onError :: (x -> Task y a) -> Task x a -> Task y a+onError func task =+ Task <| do+ result <- toIO task+ case result of+ Ok ok -> return (Ok ok)+ Err err -> toIO (func err)+++{-| Transform the error value. This can be useful if you need a bunch of error+types to match up.++ > data Error+ > = Http Http.Error+ > | WebGL WebGL.Error+ >+ > getResources :: Task Error Resource+ > getResources =+ > sequence+ > [ mapError Http serverTask+ > , mapError WebGL textureTask+ > ]+-}+mapError :: (x -> y) -> Task x a -> Task y a+mapError func task =+ onError (fail << func) task+++
+ src/Internal/Utils.hs view
@@ -0,0 +1,138 @@+module Internal.Utils where++import qualified String+import qualified List+import qualified Dict+import qualified Data.Text+import qualified GHC.Stack as Stack+import qualified System.IO+import qualified Control.Concurrent.MVar as MVar+import qualified Prelude as P+import Prelude (IO, FilePath, return, fmap, putStr, getLine)+import Basics+import Maybe (Maybe (..))+import Result (Result (..))+import String (String)+import Dict (Dict)+import List (List)+import Array (Array)+import Set (Set)+import Char (Char)+++-- TEXT HELPERS+++red :: String+red =+ "\x1b[31m"+++blue :: String+blue =+ "\x1b[34m"+++magenta :: String+magenta =+ "\x1b[35m"++green :: String+green =+ "\x1b[32m"+++yellow :: String+yellow =+ "\x1b[33m"+++cyan :: String+cyan =+ "\x1b[36m"+++gray :: String+gray =+ "\x1b[90m"+++white :: String+white =+ "\x1b[37m"+++reset :: String+reset =+ "\x1b[0m"+++break :: String+break =+ "\n"+++blank :: String+blank =+ "\n\n"+++underline :: String+underline =+ "\x1b[4m"+++italic :: String+italic =+ "\x1b[3m"+++indent :: Int -> String+indent number =+ String.repeat number " "++++-- MESSAGE+++header :: String -> String -> String -> String+header color title location =+ color ++ "-- " ++ String.toUpper title ++ " " ++ dashes title location ++ " " ++ location ++ " " ++ reset+++dashes :: String -> String -> String+dashes title location =+ let number = 75 - String.length title - String.length location in+ String.repeat number "-"+++breakAt80 :: String -> String+breakAt80 text =+ let+ fold :: String -> ( List String, List String ) -> ( List String, List String )+ fold word ( lines, words ) =+ let next = String.join " " (word : words) in+ if word == "\n" then+ ( lines ++ [ String.join " " words ], [] )+ else if String.length next > 80 then+ ( lines ++ [ String.join " " words ], [ word ] )+ else+ ( lines, words ++ [ word ] )++ concat :: ( List String, List String ) -> String+ concat ( lines, words ) =+ String.join break (lines ++ [ String.join " " words ])+ in+ text+ |> String.replace "\n" " \n"+ |> String.split " "+ |> List.foldl fold ([], [])+ |> concat+++--++toString :: P.String -> String+toString =+ Data.Text.pack >> String.fromTextUtf8
+ src/Interop.hs view
@@ -0,0 +1,40 @@++{-|++Module : Interop+Description : Interop with third party libraries.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++Interop with third party libraries.++-}++module Interop (enter, fromResult, Shortcut.map, Shortcut.andThen) where++import qualified Control.Exception.Safe as Control+import qualified Internal.Shortcut as Shortcut+import qualified Internal.Task as Task+import qualified Internal.Shortcut as Shortcut+import Internal.Task (Task)+import Basics+import Result (Result(..))+import Prelude (IO, return)+++{-| When working with third party libraries, you might need to+transform an `IO` into a `Task`. If that is the case, use this function.++-}+enter :: IO a -> Task Control.SomeException a+enter io =+ Task.Task <|+ Control.handleAny (Err >> return) (Shortcut.map Ok io)+++{-| -}+fromResult :: IO (Result x a) -> Task x a+fromResult io =+ Task.Task io
+ src/Json/Decode.hs view
@@ -0,0 +1,1472 @@+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns, Rank2Types, MagicHash, OverloadedStrings, UnboxedTuples, TypeSynonymInstances #-}++{-|++Module : Json.Decode+Description : Decode JSON.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module Json.Decode+ ( -- Turn JSON values into Haskell values.+ -- * Primitives+ Decoder+ , string+ , bool+ , int+ , float+ , null+ , succeed+ , fail+ -- * Data Structures+ , nullable+ , list+ , oneOrMore+ , dict+ , pair+ , field+ , at+ -- * Inconsistent Data Structure+ , maybe+ , oneOf+ -- * Run Decoders+ , fromString+ , fromFile+ , Error(..)+ , Problem(..)+ , DecodeExpectation(..)+ , ParseError(..)+ , errorToString+ -- * Transforming+ , map, map2, map3, map4, map5, map6, map7, map8, andThen+ )+ where+++import Prelude hiding ((++), Float, String, maybe, map, fail, null)+import qualified Data.List as List hiding (map)+import qualified Data.Maybe as Maybe+import qualified Data.Text.IO+import GHC.Prim (ByteArray#)+import GHC.Word (Word8)+import Basics ((++), Float, (<|))+import Dict (Dict)+import qualified Dict+import qualified Json.String as JS+import List (List)+import Parser (Pos, End, Row, Col)+import qualified Parser as P+import Result (Result(..))+import String (String)+import qualified String+import Task (Task)+import qualified Internal.Task++++-- RUNNERS+++{-| Parse the given string into a JSON value and then run the `Decoder` on it.+This will fail if the string is not well-formed JSON or if the `Decoder`+fails for some reason.++ > fromString int "4" == Ok 4+ > fromString int "1 + 2" == Err ...++-}+fromString :: Decoder a -> String -> Result Error a+fromString (Decoder decode) src =+ case P.fromString pFile BadEnd src of+ Ok ast ->+ decode ast Ok (Err . DecodeProblem)++ Err problem ->+ Err (ParseProblem problem)+++{-| -}+fromFile :: Decoder a -> String -> Task Error a+fromFile decoder file =+ Internal.Task.Task <| do+ content <- Data.Text.IO.readFile (String.toList file)+ let src = String.fromTextUtf8 content+ return (fromString decoder src)++++-- DECODERS+++{-| A value that knows how to decode JSON values.+-}+newtype Decoder a =+ Decoder (forall b. AST -> (a -> b) -> (Problem -> b) -> b)+++data AST+ = Array (List AST)+ | Object (List (String, AST))+ | String String+ | Int Int+ | Float Float+ | Boolean Bool+ | NULL++++-- ERRORS+++{-| A structured error describing exactly how the decoder failed. You can use+this to create more elaborate visualizations of a decoder problem. For example,+you could show the entire JSON object and show the part causing the failure in+red.+-}+data Error+ = DecodeProblem Problem+ | ParseProblem ParseError+ deriving (Eq, Show)++++-- DECODE PROBLEMS+++data Problem+ = Field String Problem+ | Index Int Problem+ | OneOf Problem [Problem]+ | Failure String+ | Expecting DecodeExpectation+ deriving (Eq, Show)+++{-| -}+data DecodeExpectation+ = TObject+ | TArray+ | TString+ | TBool+ | TInt+ | TFloat+ | TObjectWith String+ | TArrayPair Int+ | TNull+ deriving (Eq, Show)++++-- ERROR TO STRING+++{-| Convert a decoding error into a `String` that is nice for debugging.++This function is WORK IN PROGRESS and frankly not very good yet.+-}+errorToString :: Error -> String+errorToString error =+ case error of+ DecodeProblem problem ->+ case problem of+ Field field _ ->+ "Could not decode field " ++ field ++ "."++ Index i _ ->+ "Errored at array index " ++ String.fromList (show i) ++ "."++ OneOf _ _ ->+ "Could not find any solutions in oneOf"++ Failure msg ->+ msg++ Expecting expecting ->+ case expecting of+ TObject ->+ "Expected an object."++ TArray ->+ "Expected an array."++ TString ->+ "Expected a string."++ TBool ->+ "Expected a boolean."++ TInt ->+ "Expected an int."++ TFloat ->+ "Expected a float."++ TObjectWith field ->+ "Expected an object with a property \"" ++ field ++ "\"."++ TArrayPair _ ->+ "Expected an array of two elements."++ TNull ->+ "Expected a null."++ ParseProblem _ ->+ "Parser problem TODO"++++-- INSTANCES+++instance Functor Decoder where+ {-# INLINE fmap #-}+ fmap func (Decoder decodeA) =+ Decoder $ \ast ok err ->+ let+ ok' a = ok (func a)+ in+ decodeA ast ok' err+++instance Applicative Decoder where+ {-# INLINE pure #-}+ pure = return++ {-# INLINE (<*>) #-}+ (<*>) (Decoder decodeFunc) (Decoder decodeArg) =+ Decoder $ \ast ok err ->+ let+ okF func =+ let+ okA arg = ok (func arg)+ in+ decodeArg ast okA err+ in+ decodeFunc ast okF err+++instance Monad Decoder where+ {-# INLINE return #-}+ return a =+ Decoder $ \_ ok _ ->+ ok a++ {-# INLINE (>>=) #-}+ (>>=) (Decoder decodeA) callback =+ Decoder $ \ast ok err ->+ let+ ok' a =+ case callback a of+ Decoder decodeB -> decodeB ast ok err+ in+ decodeA ast ok' err++++-- STRINGS+++{-| Decode a JSON string into a `Text`.++ > fromString string "true" == Err ...+ > fromString string "42" == Err ...+ > fromString string "3.14" == Err ...+ > fromString string "\"hello\"" == Ok "hello"+ > fromString string "{ \"hello\": 42 }" == Err ...++-}+string :: Decoder String+string =+ Decoder $ \ast ok err ->+ case ast of+ String str ->+ ok str++ _ ->+ err (Expecting TString)++++-- BOOL+++{-| Decode a JSON boolean into a `Prelude.Bool`.++ > fromString bool "true" == Ok True+ > fromString bool "42" == Err ...+ > fromString bool "3.14" == Err ...+ > fromString bool "\"hello\"" == Err ...+ > fromString bool "{ \"hello\": 42 }" == Err ...++-}+bool :: Decoder Bool+bool =+ Decoder $ \ast ok err ->+ case ast of+ Boolean boolean ->+ ok boolean++ _ ->+ err (Expecting TBool)++++-- INT+++{-| Decode a JSON number into an `Prelude.Int`.++ > fromString int "true" == Err ...+ > fromString int "42" == Ok 42+ > fromString int "3.14" == Err ...+ > fromString int "\"hello\"" == Err ...+ > fromString int "{ \"hello\": 42 }" == Err ...++-}+int :: Decoder Int+int =+ Decoder $ \ast ok err ->+ case ast of+ Int n ->+ ok n++ _ ->+ err (Expecting TInt)++++-- FLOAT+++{-| Decode a JSON number into a `Prelude.Float`.++ > fromString float "true" == Err ..+ > fromString float "42" == Ok 42+ > fromString float "3.14" == Ok 3.14+ > fromString float "\"hello\"" == Err ...+ > fromString float "{ \"hello\": 42 }" == Err ...++-}+float :: Decoder Float+float =+ Decoder $ \ast ok err ->+ case ast of+ Float n ->+ ok n++ _ ->+ err (Expecting TFloat)++++-- NULL+++{-| Decode a nullable JSON value into a value.++ > fromString (nullable int) "13" == Ok (Just 13)+ > fromString (nullable int) "42" == Ok (Just 42)+ > fromString (nullable int) "null" == Ok Nothing+ > fromString (nullable int) "true" == Err ..++-}+nullable :: Decoder a -> Decoder (Maybe.Maybe a)+nullable decoder =+ oneOf+ [ fmap Maybe.Just decoder+ , null_+ ]+++null_ :: Decoder (Maybe.Maybe a)+null_ =+ Decoder $ \ast ok err ->+ case ast of+ NULL ->+ ok Maybe.Nothing++ _ ->+ err (Expecting TNull)+++{-| Decode a `null` value into some value.++ > fromString (null False) "null" == Ok False+ > fromString (null 42) "null" == Ok 42+ > fromString (null 42) "42" == Err ..+ > fromString (null 42) "false" == Err ..++So if you ever see a `null`, this will return whatever value you specified.+-}+null :: a -> Decoder a+null value =+ Decoder $ \ast ok err ->+ case ast of+ NULL ->+ ok value++ _ ->+ err (Expecting TNull)++++-- MAYBE+++{-| Helpful for dealing with optional fields. Here are a few slightly different+examples:++ > json = """{ "name": "tom", "age": 42 }"""+ > fromString (maybe (field "age" int )) json == Ok (Just 42)+ > fromString (maybe (field "name" int )) json == Ok Nothing+ > fromString (maybe (field "height" float)) json == Ok Nothing+ > fromString (field "age" (maybe int )) json == Ok (Just 42)+ > fromString (field "name" (maybe int )) json == Ok Nothing+ > fromString (field "height" (maybe float)) json == Err ...++Notice the last example! It is saying we *must* have a field named `height` and+the content *may* be a float. There is no `height` field, so the decoder fails.+Point is, `maybe` will make exactly what it contains conditional. For optional+fields, this means you probably want it *outside* a use of `field` or `at`.+-}+maybe :: Decoder a -> Decoder (Maybe.Maybe a)+maybe decoder_ =+ oneOf+ [ fmap Maybe.Just decoder_+ , return Maybe.Nothing+ ]++++-- LISTS+++{-| Decode a JSON array into a `List`.++ > fromString (list int) "[1,2,3]" == Ok [1,2,3]+ > fromString (list bool) "[true,false]" == Ok [True,False]++-}+list :: Decoder a -> Decoder [a]+list decoder =+ Decoder $ \ast ok err ->+ case ast of+ Array asts ->+ listHelp decoder ok err 0 asts []++ _ ->+ err (Expecting TArray)+++listHelp :: Decoder a -> ([a] -> b) -> (Problem -> b) -> Int -> [AST] -> [a] -> b+listHelp decoder@(Decoder decodeA) ok err !i asts revs =+ case asts of+ [] ->+ ok (List.reverse revs)++ ast:asts ->+ let+ ok' value = listHelp decoder ok err (i+1) asts (value:revs)+ err' prob = err (Index i prob)+ in+ decodeA ast ok' err'++++-- PAIR+++{-| Decode a JSON array of exactly two elements into a `Tuple`.++ > fromString (pair int book) "[1, false]" == Ok (1, false)+ > fromString (pair int bool) "[1, false, 3]" == Err ..++-}+pair :: Decoder a -> Decoder b -> Decoder ( a, b )+pair (Decoder decodeA) (Decoder decodeB) =+ Decoder $ \ast ok err ->+ case ast of+ Array vs ->+ case vs of+ [astA,astB] ->+ let+ err0 e = err (Index 0 e)+ ok0 a =+ let+ err1 e = err (Index 1 e)+ ok1 b = ok (a,b)+ in+ decodeB astB ok1 err1+ in+ decodeA astA ok0 err0++ _ ->+ err (Expecting (TArrayPair (List.length vs)))++ _ ->+ err (Expecting TArray)++++-- OBJECTS+++{-| Decode a JSON object into an `Dict`.++ > fromString (dict int) "{ \"alice\": 42, \"bob\": 99 }"+ > == Ok (Dict.fromList [("alice", 42), ("bob", 99)])++If you need the keys (like `alice` and `bob`) available in the `Dict`+values as well, I recommend using a (private) intermediate data structure like+`Info` in this example:++ > module User exposing (User, decoder)+ >+ > import Dict+ > import Json.Decode exposing (..)+ >+ > type alias User =+ > { name : String+ > , height : Float+ > , age : Int+ > }+ >+ > decoder : Decoder (Dict.Dict String User)+ > decoder =+ > map (Dict.map infoToUser) (dict infoDecoder)+ >+ > type alias Info =+ > { height : Float+ > , age : Int+ > }+ >+ > infoDecoder : Decoder Info+ > infoDecoder =+ > map2 Info+ > (field "height" float)+ > (field "age" int)+ >+ > infoToUser : String -> Info -> User+ > infoToUser name { height, age } =+ > User name height age++So now JSON like++ > { "alice": { height: 1.6, age: 33 }}++are turned into dictionary values like++> Dict.singleton "alice" (User "alice" 1.6 33)++if you need that.+-}+dict :: Decoder a -> Decoder (Dict String a)+dict valueDecoder =+ map Dict.fromList (pairs valueDecoder)+++pairs :: Decoder a -> Decoder [( String, a )]+pairs valueDecoder =+ Decoder $ \ast ok err ->+ case ast of+ Object kvs ->+ pairsHelp valueDecoder ok err kvs []++ _ ->+ err (Expecting TObject)+++pairsHelp :: Decoder a -> ([( String, a )] -> b) -> (Problem -> b) -> [( String, AST )] -> [( String, a )] -> b+pairsHelp valueDecoder@(Decoder decodeA) ok err kvs revs =+ case kvs of+ [] ->+ ok (List.reverse revs)++ ( key, ast ) : kvs ->+ let+ ok' value = pairsHelp valueDecoder ok err kvs (( key, value ) : revs)+ err' prob = err (Field key prob)+ in+ decodeA ast ok' err'+++{-| Decode a JSON array that has one or more elements.+-}+oneOrMore :: (a -> [a] -> value) -> Decoder a -> Decoder value+oneOrMore toValue decoder =+ list decoder >>= oneOrMoreHelp toValue+++oneOrMoreHelp :: (a -> [a] -> value) -> [a] -> Decoder value+oneOrMoreHelp toValue xs =+ case xs of+ [] ->+ fail "a ARRAY with at least ONE element"++ y : ys ->+ succeed (toValue y ys)++++-- FIELDS+++{-| Decode a JSON object, requiring a particular field.++ > fromString (field "x" int) "{ \"x\": 3 }" == Ok 3+ > fromString (field "x" int) "{ \"x\": 3, \"y\": 4 }" == Ok 3+ > fromString (field "x" int) "{ \"x\": true }" == Err ...+ > fromString (field "x" int) "{ \"y\": 4 }" == Err ...+ > fromString (field "name" string) "{ \"name\": \"tom\" }" == Ok "tom"++The object *can* have other fields. Lots of them! The only thing this decoder+cares about is if `x` is present and that the value there is an `Int`.+Check out [`map2`](#map2) to see how to decode multiple fields!+-}+field :: String -> Decoder a -> Decoder a+field key (Decoder decodeA) =+ Decoder $ \ast ok err ->+ case ast of+ Object kvs ->+ case findField key kvs of+ Maybe.Just value ->+ let+ err' prob =+ err (Field key prob)+ in+ decodeA value ok err'++ Maybe.Nothing ->+ err (Expecting (TObjectWith key))++ _ ->+ err (Expecting TObject)+++findField :: String -> [( String, AST )] -> Maybe.Maybe AST+findField key pairs =+ case pairs of+ [] ->+ Maybe.Nothing++ (bts, value) : remainingPairs ->+ if key == bts+ then Just value+ else findField key remainingPairs+++{-| Decode a nested JSON object, requiring certain fields.++ > json = """{ "person": { "name": "tom", "age": 42 } }"""+ > fromString (at ["person", "name"] string) json == Ok "tom"+ > fromString (at ["person", "age" ] int ) json == Ok "42++This is really just a shorthand for saying things like:++ > field "person" (field "name" string) == at ["person","name"] string++-}+at :: [String] -> Decoder a -> Decoder a+at fields decoder =+ List.foldr field decoder fields++++-- ONE OF+++{-| Try a bunch of different decoders. This can be useful if the JSON may come+in a couple different formats. For example, say you want to read an array of+numbers, but some of them are `null`.++ > import String+ >+ > badInt : Decoder Int+ > badInt =+ > oneOf [ int, null 0 ]+ >+ > -- fromString (list badInt) "[1,2,null,4]" == Ok [1,2,0,4]++Why would someone generate JSON like this? Questions like this are not good+for your health. The point is that you can use `oneOf` to handle situations+like this!++You could also use `oneOf` to help version your data. Try the latest format,+then a few older ones that you still support. You could use `andThen` to be+even more particular if you wanted.+-}+oneOf :: [Decoder a] -> Decoder a+oneOf decoders =+ Decoder $ \ast ok err ->+ case decoders of+ Decoder decodeA : decoders ->+ let+ err' e =+ oneOfHelp ast ok err decoders e []+ in+ decodeA ast ok err'++ [] ->+ error "Ran into (Json.Decode.oneOf [])"+++oneOfHelp :: AST -> (a -> b) -> (Problem -> b) -> [Decoder a] -> Problem -> [Problem] -> b+oneOfHelp ast ok err decoders p ps =+ case decoders of+ Decoder decodeA : decoders ->+ let+ err' p' =+ oneOfHelp ast ok err decoders p' (p:ps)+ in+ decodeA ast ok err'++ [] ->+ err (oneOfError [] p ps)+++oneOfError :: [Problem] -> Problem -> [Problem] -> Problem+oneOfError problems prob ps =+ case ps of+ [] ->+ OneOf prob problems++ p:ps ->+ oneOfError (prob:problems) p ps++++-- PRIMITIVES+++{-| Ignore the JSON and make the decoder fail. This is handy when used with+`oneOf` or `andThen` where you want to give a custom error message in some+case.++See the [`andThen`](#andThen) docs for an example.+-}+fail :: String -> Decoder a+fail x =+ Decoder $ \_ _ err ->+ err (Failure x)+++{-| Ignore the JSON and produce a certain value.++ > fromString (succeed 42) "true" == Ok 42+ > fromString (succeed 42) "[1,2,3]" == Ok 42+ > fromString (succeed 42) "hello" == Err ... -- this is not a valid JSON string++This is handy when used with `oneOf` or `andThen`.+-}+succeed :: a -> Decoder a+succeed a =+ Decoder $ \_ ok _ ->+ ok a++++-- MAPS+++{-| Transform a decoder. Maybe you just want to know the length of a string:++ > import String+ >+ > stringLength : Decoder Int+ > stringLength =+ > map String.length string++It is often helpful to use `map` with `oneOf`, like when defining `nullable`:++ nullable : Decoder a -> Decoder (Maybe a)+ nullable decoder =+ oneOf+ [ null Nothing+ , map Just decoder+ ]++-}+map :: (a -> value) -> Decoder a -> Decoder value+map f a =+ return f <*> a+++{-| Try two decoders and then combine the result. We can use this to decode+objects with many fields:++ > type alias Point = { x : Float, y : Float }+ >+ > point : Decoder Point+ > point =+ > map2 Point+ > (field "x" float)+ > (field "y" float)+ >+ > -- fromString point """{ "x": 3, "y": 4 }""" == Ok { x = 3, y = 4 }++It tries each individual decoder and puts the result together with the `Point`+constructor.+-}+map2 :: (a -> b -> value) -> Decoder a -> Decoder b -> Decoder value+map2 func a b =+ return func <*> a <*> b+++{-| Try three decoders and then combine the result. We can use this to decode+objects with many fields:++ > type alias Person = { name : String, age : Int, height : Float }+ >+ > person : Decoder Person+ > person =+ > map3 Person+ > (at ["name"] string)+ > (at ["info","age"] int)+ > (at ["info","height"] float)+ >+ > -- json = """{ "name": "tom", "info": { "age": 42, "height": 1.8 } }"""+ > -- fromString person json == Ok { name = "tom", age = 42, height = 1.8 }++Like `map2` it tries each decoder in order and then give the results to the+`Person` constructor. That can be any function though!+-}+map3 :: (a -> b -> c -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder value+map3 func a b c =+ return func <*> a <*> b <*> c+++{-| -}+map4 :: (a -> b -> c -> d -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder value+map4 func a b c d =+ return func <*> a <*> b <*> c <*> d+++{-| -}+map5 :: (a -> b -> c -> d -> e -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder value+map5 func a b c d e =+ return func <*> a <*> b <*> c <*> d <*> e+++{-| -}+map6 :: (a -> b -> c -> d -> e -> f -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder value+map6 func a b c d e f =+ return func <*> a <*> b <*> c <*> d <*> e <*> f+++{-| -}+map7 :: (a -> b -> c -> d -> e -> f -> g -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder g -> Decoder value+map7 func a b c d e f g =+ return func <*> a <*> b <*> c <*> d <*> e <*> f <*> g+++{-| -}+map8 :: (a -> b -> c -> d -> e -> f -> g -> h -> value) -> Decoder a -> Decoder b -> Decoder c -> Decoder d -> Decoder e -> Decoder f -> Decoder g -> Decoder h -> Decoder value+map8 func a b c d e f g h =+ return func <*> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h+++{-| Create decoders that depend on previous results. If you are creating+versioned data, you might do something like this:++ > info : Decoder Info+ > info =+ > field "version" int+ > |> andThen infoHelp+ >+ > infoHelp : Int -> Decoder Info+ > infoHelp version =+ > case version of+ > 4 ->+ > infoDecoder4+ >+ > 3 ->+ > infoDecoder3+ >+ > _ ->+ > fail <|+ > "Trying to decode info, but version "+ > ++ toString version ++ " is not supported."+ >+ > -- infoDecoder4 : Decoder Info+ > -- infoDecoder3 : Decoder Info++-}+andThen :: (a -> Decoder b) -> Decoder a -> Decoder b+andThen callback (Decoder decodeA) =+ Decoder $ \ast ok err ->+ let+ ok' a =+ case callback a of+ Decoder decodeB -> decodeB ast ok err+ in+ decodeA ast ok' err++++-- PARSE+++type Parser a =+ P.Parser ParseError a+++data ParseError+ = ObjectStart Row Col+ | ObjectMore Row Col+ | ObjectEnd Row Col+ | ArrayStart Row Col+ | ArrayMore Row Col+ | ArrayEnd Row Col+ | StringStart Row Col+ | StringProblem StringProblem Row Col+ | NumberStart Row Col+ | NumberProblem NumberProblem Row Col+ | Bool Row Col+ | Null Row Col+ | Value Row Col+ | Colon Row Col+ | BadEnd Row Col+ deriving (Eq, Show)+++data StringProblem+ = BadStringEnd+ | BadStringControlChar+ | BadStringEscapeChar+ | BadStringEscapeHex+ deriving (Eq, Show)+++data NumberProblem+ = NumberEnd+ | NumberDot Int+ | NumberNoLeadingZero+ deriving (Eq, Show)++++-- PARSE AST+++pFile :: Parser AST+pFile =+ do spaces+ value <- pValue+ spaces+ return value+++pValue :: Parser AST+pValue =+ P.oneOf Value+ [ String <$> pString+ , pObject+ , pArray+ , P.symbol 0x2B {- + -} NumberStart >> pNumber id id+ , P.symbol 0x2D {- - -} NumberStart >> pNumber negate negate+ , pNumber id id+ , P.k4 0x74 0x72 0x75 0x65 Bool >> return (Boolean True)+ , P.k5 0x66 0x61 0x6C 0x73 0x65 Bool >> return (Boolean False)+ , P.k4 0x6E 0x75 0x6C 0x6C Null >> return NULL+ ]++++-- OBJECT+++pObject :: Parser AST+pObject =+ do P.word1 0x7B {- { -} ObjectStart+ spaces+ P.oneOf ObjectMore+ [ do entry <- pField+ spaces+ pObjectHelp [entry]+ , do P.word1 0x7D {-}-} ObjectEnd+ return (Object [])+ ]+++pObjectHelp :: [(String, AST)] -> Parser AST+pObjectHelp revEntries =+ P.oneOf ObjectMore+ [ do P.word1 0x2C {-,-} ObjectMore+ spaces+ entry <- pField+ spaces+ pObjectHelp (entry : revEntries)+ ,+ do P.word1 0x7D {-}-} ObjectEnd+ return (Object (List.reverse revEntries))+ ]+++pField :: Parser (String, AST)+pField =+ do key <- pString+ spaces+ P.word1 0x3A {-:-} Colon+ spaces+ value <- pValue+ return (key, value)++++-- ARRAY+++pArray :: Parser AST+pArray =+ do P.word1 0x5B {-[-} ArrayStart+ spaces+ P.oneOf ArrayMore+ [ do entry <- pValue+ spaces+ pArrayHelp [entry]+ , do P.word1 0x5D {-]-} ArrayEnd+ return (Array [])+ ]+++pArrayHelp :: [AST] -> Parser AST+pArrayHelp revEntries =+ P.oneOf ArrayMore+ [ do P.word1 0x2C {-,-} ArrayMore+ spaces+ entry <- pValue+ spaces+ pArrayHelp (entry:revEntries)+ ,+ do P.word1 0x5D {-]-} ArrayEnd+ return (Array (List.reverse revEntries))+ ]++++-- STRING+++pString :: Parser String+pString =+ P.Parser $ \(P.State src pos end row col) cok _ cerr eerr ->+ if pos < end && P.unsafeIndex src pos == 0x22 {-"-} then+ let+ !pos1 = pos + 1+ !col1 = col + 1++ (# status, newPos, newRow, newCol #) =+ pStringHelp src pos1 end row col1 pos1 []+ in+ case status of+ GoodString chunks ->+ let+ string = String.fromTextUtf8 (JS.toTextUtf8 src chunks)+ !newState = P.State src newPos end newRow newCol+ in+ cok string newState++ BadString problem ->+ cerr newRow newCol (StringProblem problem)++ else+ eerr row col StringStart+++data StringStatus+ = GoodString [JS.Chunk]+ | BadString StringProblem+++pStringHelp :: ByteArray# -> Pos -> End -> Row -> Col -> Pos -> [JS.Chunk] -> (# StringStatus, Pos, Row, Col #)+pStringHelp src pos end row col initPos revChunks =+ if pos >= end then+ (# BadString BadStringEnd, pos, row, col #)+ else+ case P.unsafeIndex src pos of+ 0x22 {-"-} ->+ (# GoodString (finalize initPos pos revChunks), pos + 1, row, col + 1 #)++ 0x0A {-\n-} ->+ (# BadString BadStringEnd, pos, row, col #)++ 0x5C {-\-} ->+ let !pos1 = pos + 1 in+ if pos1 >= end then+ (# BadString BadStringEnd, pos1, row + 1, col #)++ else+ case P.unsafeIndex src pos1 of+ 0x22 {-"-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x22) initPos pos revChunks)+ 0x5C {-\-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x5C) initPos pos revChunks)+ 0x2F {-/-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x2F) initPos pos revChunks)+ 0x62 {-b-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x08) initPos pos revChunks)+ 0x66 {-f-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x0C) initPos pos revChunks)+ 0x6E {-n-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x0A) initPos pos revChunks)+ 0x72 {-r-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x0D) initPos pos revChunks)+ 0x74 {-t-} -> pStringHelp src (pos + 2) end row (col + 2) (pos + 2) (addChunks (JS.Escape 0x09) initPos pos revChunks)+ 0x75 {-u-} ->+ let !pos6 = pos + 6 in+ if end < pos6+ then (# BadString BadStringEscapeHex, pos, row, col #)+ else+ let !code = getEscapedUtf16 src pos in+ if code < 0+ then (# BadString BadStringEscapeHex, pos, row, col #)+ else+ if code < 0xD800 || 0xDBFF < code+ then+ pStringHelp src pos6 end row (col + 6) pos6 $+ addChunks (JS.CodePoint code) initPos pos revChunks+ else+ if 0xDBFF < code+ then (# BadString BadStringEscapeHex, pos, row, col #)+ else+ let !pos12 = pos6 + 6 in+ if pos12 <= end+ && P.unsafeIndex src (pos6 ) == 0x5C {-\-}+ && P.unsafeIndex src (pos6 + 1) == 0x75 {-u-}+ then+ let !pair = getEscapedUtf16 src pos6 in+ if pair < 0 || pair < 0xDC00 || 0xDFFF < pair+ then (# BadString BadStringEscapeHex, pos, row, col #)+ else+ let !point = 0x10000 + 0x400 * (code - 0xD800) + (pair - 0xDC00) in+ pStringHelp src pos12 end row (col + 12) pos12 $+ addChunks (JS.CodePoint point) initPos pos revChunks+ else+ (# BadString BadStringEscapeHex, pos, row, col #)++ _ ->+ (# BadString BadStringEscapeChar, pos, row, col #)++ word ->+ if word < 0x20 then+ (# BadString BadStringControlChar, pos, row, col #)++ else+ let !newPos = pos + P.getCharWidth word in+ pStringHelp src newPos end row (col + 1) initPos revChunks+++finalize :: Int -> Int -> [JS.Chunk] -> [JS.Chunk]+finalize start end revChunks =+ reverse $+ if start == end then+ revChunks+ else+ JS.Slice start (end - start) : revChunks+++addChunks :: JS.Chunk -> Int -> Int -> [JS.Chunk] -> [JS.Chunk]+addChunks chunk start end revChunks =+ if start == end then+ chunk : revChunks+ else+ chunk : JS.Slice start (end - start) : revChunks++++-- GET CODE+--+-- Will be negative for invalid encodings!+--+++getEscapedUtf16 :: ByteArray# -> Int -> Int+getEscapedUtf16 src pos =+ let+ !d1 = toHex 1 (P.unsafeIndex src (pos + 2))+ !d2 = toHex 16 (P.unsafeIndex src (pos + 3))+ !d3 = toHex 256 (P.unsafeIndex src (pos + 4))+ !d4 = toHex 4096 (P.unsafeIndex src (pos + 5))+ in+ d1 + d2 + d3 + d4+++toHex :: Int -> Word8 -> Int+toHex factor word =+ if 0x30 {-0-} <= word && word <= 0x39 {-9-} then+ factor * fromIntegral (word - 0x30)+ else if 0x61 {-a-} <= word && word <= 0x66 {-f-} then+ factor * fromIntegral (word - 0x61)+ else if 0x41 {-A-} <= word && word <= 0x46 {-F-} then+ factor * fromIntegral (word - 0x41)+ else+ -65536++++-- SPACES+++spaces :: Parser ()+spaces =+ P.Parser $ \state@(P.State src pos end row col) cok eok _ _ ->+ let (# newPos, newRow, newCol #) = eatSpaces src pos end row col in+ if pos == newPos then+ eok () state++ else+ let !newState = P.State src newPos end newRow newCol in+ cok () newState+++eatSpaces :: ByteArray# -> Pos -> End -> Row -> Col -> (# Pos, Row, Col #)+eatSpaces src pos end row col =+ if pos >= end then+ (# pos, row, col #)++ else+ case P.unsafeIndex src pos of+ 0x20 {- -} -> eatSpaces src (pos + 1) end row (col + 1)+ 0x09 {-\t-} -> eatSpaces src (pos + 1) end row (col + 1)+ 0x0A {-\n-} -> eatSpaces src (pos + 1) end (row + 1) 1+ 0x0D {-\r-} -> eatSpaces src (pos + 1) end row col+ _ ->+ (# pos, row, col #)++++-- NUMBERS+++pNumber :: (Int -> Int) -> (Float -> Float) -> Parser AST+pNumber signInt signFloat =+ P.Parser $ \(P.State src pos end row col) cok _ cerr eerr ->+ if pos >= end then+ eerr row col NumberStart++ else+ let !word = P.unsafeIndex src pos in+ if not (isDecimalDigit word) then+ eerr row col NumberStart++ else+ let+ outcome =+ let !pos1 = pos + 1 in+ if word == 0x30 {-0-} then+ chompZero src pos1 end+ else+ chompInt src pos1 end (toInt word)+ in+ case outcome of+ BadOutcome newPos problem ->+ let !newCol = col + fromIntegral (newPos - pos) in+ cerr row newCol (NumberProblem problem)++ OkInt newPos n ->+ let !newCol = col + fromIntegral (newPos - pos)+ !integer = Int (signInt n)+ !newState = P.State src newPos end row newCol+ in+ cok integer newState++ OkFloat newPos n ->+ let !newCol = col + fromIntegral (newPos - pos)+ !float = Float (signFloat n)+ !newState = P.State src newPos end row newCol+ in+ cok float newState++++-- CHOMP OUTCOME+++data Outcome+ = BadOutcome Pos NumberProblem+ | OkInt Pos Int+ | OkFloat Pos Float++++-- CHOMP INT+++chompInt :: ByteArray# -> Pos -> End -> Int -> Outcome+chompInt src !pos end !n =+ if pos >= end then+ OkInt pos n++ else+ let !word = P.unsafeIndex src pos in+ if isDecimalDigit word then+ let !pos1 = pos + 1 in+ chompInt src pos1 end (10 * n + toInt word)++ else if word == 0x2E {-.-} then+ let !pos1 = pos + 1 in+ chompFraction src pos1 end n++ else if word == 0x65 {-e-} || word == 0x45 {-E-} then+ chompExponent src (pos + 1) end (fromIntegral n)++ else if isDirtyEnd src pos end word then+ BadOutcome pos NumberEnd++ else+ OkInt pos n++++-- CHOMP FRACTION+++chompFraction :: ByteArray# -> Pos -> End -> Int -> Outcome+chompFraction src pos end !n =+ if pos >= end then+ BadOutcome pos (NumberDot n)++ else+ let !word1 = P.unsafeIndex src pos in+ if isDecimalDigit word1 then+ let !fraction = 1 / 10 * toFloat word1+ !n' = fromIntegral n + fraction+ !pos1 = pos + 1+ in+ chompFractionHelp src pos1 end (-2) n'++ else+ BadOutcome pos (NumberDot n)+++chompFractionHelp :: ByteArray# -> Pos -> End -> Float -> Float -> Outcome+chompFractionHelp src pos end !power !n =+ if pos >= end then+ OkFloat pos n++ else+ let !word = P.unsafeIndex src pos in+ if isDecimalDigit word then+ let !fraction = (10 ** power) * toFloat word+ !n' = n + fraction+ in+ chompFractionHelp src (pos + 1) end (power - 1) n'++ else if word == 0x65 {-e-} || word == 0x45 {-E-} then+ chompExponent src (pos + 1) end n++ else if isDirtyEnd src pos end word then+ BadOutcome pos NumberEnd++ else+ OkFloat pos n++++-- CHOMP EXPONENT+++chompExponent :: ByteArray# -> Pos -> End -> Float -> Outcome+chompExponent src pos end n =+ if pos >= end then+ BadOutcome pos NumberEnd++ else+ let !word = P.unsafeIndex src pos in+ if isDecimalDigit word then+ let !exponent = toInt word in+ chompExponentHelp src (pos + 1) end exponent n++ else if word == 0x2B {- + -} then+ let !pos1 = pos + 1+ !word1 = P.unsafeIndex src pos1+ in+ if pos1 < end && isDecimalDigit word1 then+ let !exponent = toInt word1+ !pos2 = pos + 2+ in+ chompExponentHelp src pos2 end exponent n++ else+ BadOutcome pos NumberEnd++ else if word == 0x2D {- - -} then+ let !pos1 = pos + 1+ !word1 = P.unsafeIndex src pos1+ in+ if pos1 < end && isDecimalDigit word1 then+ let !exponent = toInt word1+ !pos2 = pos + 2+ in+ chompExponentHelp src pos2 end (negate exponent) n++ else+ BadOutcome pos NumberEnd++ else+ BadOutcome pos NumberEnd+++chompExponentHelp :: ByteArray# -> Pos -> End -> Int -> Float -> Outcome+chompExponentHelp src pos end exponent n =+ if pos >= end then+ OkFloat pos (n * 10^exponent)++ else+ let !word = P.unsafeIndex src pos in+ if isDecimalDigit word then+ let !exponent' = 10 * exponent + toInt word+ !pos1 = pos + 1+ in+ chompExponentHelp src pos1 end exponent' n++ else+ OkFloat pos (n * 10^exponent)++++-- CHOMP ZERO+++chompZero :: ByteArray# -> Pos -> End -> Outcome+chompZero src pos end =+ if pos >= end then+ OkInt pos 0+ else+ let !word = P.unsafeIndex src pos in+ if word == 0x2E {-.-} then+ let !pos1 = pos + 1 in+ chompFraction src pos1 end 0++ else if isDecimalDigit word then+ BadOutcome pos NumberNoLeadingZero++ else if isDirtyEnd src pos end word then+ BadOutcome pos NumberEnd++ else+ OkInt pos 0++++-- HELPERS+++{-# INLINE isDecimalDigit #-}+isDecimalDigit :: Word8 -> Bool+isDecimalDigit word =+ word <= 0x39 {-9-} && word >= 0x30 {-0-}+++isDirtyEnd :: ByteArray# -> Pos -> End -> Word8 -> Bool+isDirtyEnd src pos end word =+ P.getInnerWidthHelp src pos end word > 0+++toInt :: Word8 -> Int+toInt word =+ fromIntegral (word - 0x30 {-0-})+++toFloat :: Word8 -> Float+toFloat word =+ fromIntegral (word - 0x30 {-0-})+
+ src/Json/Encode.hs view
@@ -0,0 +1,328 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}++{-|++Module : Json.Encode+Description : Encode JSON.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module Json.Encode+ ( -- * Encoding+ Value, toBuilder+ -- * Primitives+ , string, chars, int, float, bool, null+ -- * Arrays+ , list+ -- * Objects+ , object, dict+ )+ where++-- TODO: add INLINE to all the functions that produce a Value and+-- see the impact in production code. I suspect it will be valuable.+-- I think using the composition operator in their implementations+-- is better for this, but I am not 100% sure.++import qualified Data.ByteString.Builder.Prim as P+import Data.ByteString.Builder.Prim ((>$<), (>*<))+import qualified Data.ByteString.Builder as B+import qualified Data.Char as Char+import qualified Data.Text.Encoding as TE+import Data.Monoid ((<>))+import Prelude hiding (String, Float, null)+import Data.Word (Word8)++import Basics (Float)+import qualified Dict+import qualified List+import qualified String+import String (String)+++-- ENCODER+++{-| Representation of a JSON value that can be turned into a string, written+to a file, or turned into a `Data.ByteString.Builder` value.+-}+newtype Value =+ Value { _toBuilder :: B.Builder }++++-- TO BUILDER+++{-| Convert a `Value` into a bytestring.++ > import Json.Encode as Encode+ >+ > tom : Encode.Value+ > tom =+ > Encode.object+ > [ ( "name", Encode.string "Tom" )+ > , ( "age", Encode.int 42 )+ > ]+ >+ > compact =+ > Encode.toBuilder tom+ > -- {"name":"Tom","age":42}+-}+toBuilder :: Value -> B.Builder+toBuilder (Value builder) =+ builder++++-- STRING+++{-| Turn a `String` into a JSON string.++ > import Json.Encode exposing (encode, string)+ >+ > -- encode 0 (string "") == "\"\""+ > -- encode 0 (string "abc") == "\"abc\""+ > -- encode 0 (string "hello") == "\"hello\""+-}+string :: String -> Value+string str =+ Value $ B.char7 '"' <> escapeString str <> B.char7 '"'+++escapeString :: String -> B.Builder+escapeString str =+ TE.encodeUtf8BuilderEscaped escapeWord8 (String.toTextUtf8 str)+++{-# INLINE escapeWord8 #-}+escapeWord8 :: P.BoundedPrim Word8+escapeWord8 =+ P.condB (> 0x5C {-\-} ) (P.liftFixedToBounded P.word8) $+ P.condB (== 0x5C {-\-} ) (P.liftFixedToBounded (const ('\\','\\') >$< P.char7 >*< P.char7)) $+ P.condB (== 0x22 {-"-} ) (P.liftFixedToBounded (const ('\\','\"') >$< P.char7 >*< P.char7)) $+ P.condB (== 0x2F {-/-} ) (P.liftFixedToBounded (const ('\\','/') >$< P.char7 >*< P.char7)) $+ P.condB (>= 0x20 {- -} ) (P.liftFixedToBounded P.word8) $+ P.condB (== 0x08 {-\b-}) (P.liftFixedToBounded (const ('\\','b') >$< P.char7 >*< P.char7)) $+ P.condB (== 0x09 {-\t-}) (P.liftFixedToBounded (const ('\\','t') >$< P.char7 >*< P.char7)) $+ P.condB (== 0x0A {-\n-}) (P.liftFixedToBounded (const ('\\','n') >$< P.char7 >*< P.char7)) $+ P.condB (== 0x0C {-\f-}) (P.liftFixedToBounded (const ('\\','f') >$< P.char7 >*< P.char7)) $+ P.condB (== 0x0D {-\r-}) (P.liftFixedToBounded (const ('\\','r') >$< P.char7 >*< P.char7)) $+ P.liftFixedToBounded (toLowCode >$< P.word8 >*< P.word8 >*< P.word8 >*< P.word8 >*< P.word8 >*< P.word8)+++{-# INLINE toLowCode #-}+toLowCode :: Word8 -> (Word8,(Word8,(Word8,(Word8,(Word8,Word8)))))+toLowCode code =+ let+ (tens, ones) = divMod code 16+ in+ (0x5C {-\-}, (0x75 {-u-}, (0x30 {-0-}, (0x30 {-0-}, (tens, ones)))))++++-- CHARS+++chars :: [Char] -> Value+chars chrs =+ Value $ B.char7 '"' <> P.primMapListBounded escapeChar chrs <> B.char7 '"'+++{-# INLINE escapeChar #-}+escapeChar :: P.BoundedPrim Char+escapeChar =+ P.condB (> '\\') P.charUtf8 (fromIntegral . Char.ord >$< escapeWord8)++++-- BOOL+++{-| Turn a `Bool` into a JSON boolean.++ > import Json.Encode exposing (encode, bool)+ >+ > -- encode 0 (bool True) == "true"+ > -- encode 0 (bool False) == "false"+-}+bool :: Bool -> Value+bool b =+ if b+ then Value "true"+ else Value "false"++++-- INT+++{-| Turn an `Int` into a JSON number.++ > import Json.Encode exposing (encode, int)+ >+ > -- encode 0 (int 42) == "42"+ > -- encode 0 (int -7) == "-7"+ > -- encode 0 (int 0) == "0"+-}+int :: Int -> Value+int =+ Value . B.intDec++++-- FLOAT+++{-| Turn a `Float` into a JSON number.++ > import Json.Encode exposing (encode, float)+ >+ > -- encode 0 (float 3.14) == "3.14"+ > -- encode 0 (float 1.618) == "1.618"+ > -- encode 0 (float -42) == "-42"+ > -- encode 0 (float NaN) == "null"+ > -- encode 0 (float Infinity) == "null"++**Note:** Floating point numbers are defined in the [IEEE 754 standard](https://en.wikipedia.org/wiki/IEEE_754)+which is hardcoded into almost all CPUs. This standard allows `Infinity` and+`NaN`. [The JSON spec](https://www.json.org/) does not include these values, so we encode them+both as `null`.+-}+float :: Float -> Value+float =+ Value . B.doubleDec++++-- NULL+++{-| Create a JSON `null` value.++ > import Json.Encode exposing (encode, null)+ >+ > -- encode 0 null == "null"+-}+null :: Value+null =+ Value "null"++++-- ARRAYS+++{-| Turn a `List` into a JSON array.++ > import Json.Encode as Encode exposing (bool, encode, int, list, string)+ >+ > -- encode 0 (list int [1,3,4]) == "[1,3,4]"+ > -- encode 0 (list bool [True,False]) == "[true,false]"+ > -- encode 0 (list string ["a","b"]) == """["a","b"]"""+-}+list :: (a -> Value) -> [a] -> Value+list encodeEntry entries =+ case entries of+ [] -> Value (B.string7 "[]")+ x:xs -> Value (encodeSequence arrayOpen arrayClose (_toBuilder . encodeEntry) x xs)+++arrayOpen :: B.Builder+arrayOpen =+ B.string7 "["+++arrayClose :: B.Builder+arrayClose =+ B.char7 ']'++++-- OBJECTS+++{-| Create a JSON object.++ > import Json.Encode as Encode+ >+ > tom : Encode.Value+ > tom =+ > Encode.object+ > [ ( "name", Encode.string "Tom" )+ > , ( "age", Encode.int 42 )+ > ]+ >+ > -- Encode.encode 0 tom == """{"name":"Tom","age":42}"""++-}+object :: [(String, Value)] -> Value+object fields =+ case fields of+ [] -> Value (B.string7 "{}")+ f:fs -> Value (encodeSequence objectOpen objectClose encodeField f fs)+++encodeField :: (String, Value) -> B.Builder+encodeField (key, Value builder) =+ B.char7 '"' <> escapeString key <> B.string7 "\":" <> builder+++objectOpen :: B.Builder+objectOpen =+ B.string7 "{"+++objectClose :: B.Builder+objectClose =+ B.char7 '}'++++{-| Turn a `Dict` into a JSON object.++ > import Dict exposing (Dict)+ > import Json.Encode as Encode+ >+ > people : Dict String Int+ > people =+ > Dict.fromList [ ("Tom",42), ("Sue", 38) ]+ >+ > -- Encode.encode 0 (Encode.dict identity Encode.int people)+ > -- == """{"Tom":42,"Sue":38}"""+-}+dict :: (k -> String) -> (v -> Value) -> Dict.Dict k v -> Value+dict encodeKey encodeValue pairs =+ let+ toPair (key, value) =+ (encodeKey key, encodeValue value)+ in+ object $ List.map toPair (Dict.toList pairs)++++-- ENCODE SEQUENCE+++encodeSequence :: B.Builder -> B.Builder -> (a -> B.Builder) -> a -> [a] -> B.Builder+encodeSequence open close encodeEntry x xs =+ let+ addEntry entry builder =+ comma+ <> encodeEntry entry+ <> builder+ in+ open+ <> encodeEntry x+ <> foldr addEntry close xs+++comma :: B.Builder+comma =+ B.string7 ","
+ src/Json/String.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-}+module Json.String+ ( Chunk(..)+ , toTextUtf8+ )+ where+++import Prelude (($), (+), (<), (=<<), fromIntegral, map, otherwise, sum)+import Data.Bits ((.&.), shiftR)+import qualified Data.Text.Internal as T+import qualified Data.Text.Array as T (Array(Array))+import GHC.Exts+ ( Int(I#)+ , ByteArray#+ , MutableByteArray#+ , newByteArray#+ , unsafeFreezeByteArray#+ , copyByteArray#+ , writeWord8Array#+ )+import GHC.ST (ST(ST), runST)+import GHC.Word (Word8(W8#))++++-- CHUNKS+++data Chunk+ = Slice Int Int+ | Escape Word8+ | CodePoint Int++++-- TO TEXT+++toTextUtf8 :: ByteArray# -> [Chunk] -> T.Text+toTextUtf8 src chunks =+ case chunks of+ [] ->+ T.empty++ [Slice off len] ->+ T.text (T.Array src) off len++ _ ->+ let+ len = sum (map getChunkSize chunks)+ arr = runST (writeChunks src chunks =<< newByteArray len)+ in+ T.text arr 0 len+++writeChunks :: ByteArray# -> [Chunk] -> MBA s -> ST s T.Array+writeChunks src chunks mba =+ go 0 chunks+ where+ go offset chunks =+ case chunks of+ [] ->+ freeze mba++ c:cs ->+ case c of+ Slice off len ->+ do copy src off mba offset len+ go (offset + len) cs++ Escape escape ->+ do writeWord8 mba offset escape+ go (offset + 1) cs++ CodePoint n+ | n < 0x80 ->+ do writeWord8 mba (offset ) (fromIntegral n)+ go (offset + 1) cs++ | n < 0x800 ->+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 6 ) + 0xC0))+ writeWord8 mba (offset + 1) (fromIntegral (( n .&. 0x3F) + 0x80))+ go (offset + 2) cs++ | n < 0x10000 ->+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 12 ) + 0xE0))+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))+ writeWord8 mba (offset + 2) (fromIntegral (( n .&. 0x3F) + 0x80))+ go (offset + 3) cs++ | otherwise ->+ do writeWord8 mba (offset ) (fromIntegral ((shiftR n 18 ) + 0xF0))+ writeWord8 mba (offset + 1) (fromIntegral ((shiftR n 12 .&. 0x3F) + 0x80))+ writeWord8 mba (offset + 2) (fromIntegral ((shiftR n 6 .&. 0x3F) + 0x80))+ writeWord8 mba (offset + 3) (fromIntegral (( n .&. 0x3F) + 0x80))+ go (offset + 4) cs++++-- GET CHUNK SIZE+++getChunkSize :: Chunk -> Int+getChunkSize chunk =+ case chunk of+ Slice _ len -> len+ Escape _ -> 1+ CodePoint code+ | code < 0x80 -> 1+ | code < 0x800 -> 2+ | code < 0x10000 -> 3+ | otherwise -> 4++++-- HELPERS+++data MBA s =+ MBA# (MutableByteArray# s)+++newByteArray :: Int -> ST s (MBA s) -- PERF see if newPinnedByteArray for len > 256 is positive+newByteArray (I# len#) =+ ST $ \s ->+ case newByteArray# len# s of+ (# s, mba# #) -> (# s, MBA# mba# #)+++freeze :: MBA s -> ST s T.Array+freeze (MBA# mba#) =+ ST $ \s ->+ case unsafeFreezeByteArray# mba# s of+ (# s, ba# #) -> (# s, T.Array ba# #)+++copy :: ByteArray# -> Int -> MBA s -> Int -> Int -> ST s ()+copy ba# (I# offset#) (MBA# mba#) (I# i#) (I# len#) =+ ST $ \s ->+ case copyByteArray# ba# offset# mba# i# len# s of+ s -> (# s, () #)+++writeWord8 :: MBA s -> Int -> Word8 -> ST s ()+writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =+ ST $ \s ->+ case writeWord8Array# mba# offset# w# s of+ s -> (# s, () #)
+ src/List.hs view
@@ -0,0 +1,506 @@++{-|++Module : List+Description : Work with lists.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module List+ ( -- * Create+ List, singleton, repeat, range++ -- * Transform+ , map, indexedMap, foldl, foldr, filter, filterMap++ -- * Utilities+ , length, reverse, member, all, any, maximum, minimum, sum, product++ -- * Combine+ , append, concat, concatMap, intersperse, map2, map3, map4, map5++ -- * Sort+ , sort, sortBy, sortWith++ -- * Deconstruct+ , isEmpty, head, tail, take, drop, partition, unzip+ )+where++import Prelude (Applicative, Char, Eq, Functor, Monad, Num, Ord, Show, Bool(..), Int, Ordering, (-), flip, mappend, mconcat)+import Maybe (Maybe (..))+import qualified Prelude+import qualified Data.List+import qualified Data.Maybe+import qualified Internal.Shortcut as Shortcut+++{-| A list.+-}+type List a = [a]++++-- CREATE+++{-| Create a list with only one element:++ > singleton 1234 == [1234]+ > singleton "hi" == ["hi"]++-}+singleton :: a -> List a+singleton value =+ [value]+++{-| Create a list with *n* copies of a value:++ > repeat 3 (0,0) == [(0,0),(0,0),(0,0)]+-}+repeat :: Int -> a -> List a+repeat =+ Data.List.replicate+++{-| Create a list of numbers, every element increasing by one.+You give the lowest and highest number that should be in the list.++ > range 3 6 == [3, 4, 5, 6]+ > range 3 3 == [3]+ > range 6 3 == []+-}+range :: Int -> Int -> List Int+range lo hi =+ [lo .. hi]++++-- TRANSFORM+++{-| Apply a function to every element of a list.++ > map sqrt [1,4,9] == [1,2,3]+ >+ > map not [True,False,True] == [False,True,False]++So `map func [ a, b, c ]` is the same as `[ func a, func b, func c ]`+-}+map :: (a -> b) -> List a -> List b+map =+ Prelude.fmap+++{-| Same as `map` but the function is also applied to the index of each+element (starting at zero).++ > indexedMap Tuple.pair ["Tom","Sue","Bob"] == [ (0,"Tom"), (1,"Sue"), (2,"Bob") ]+-}+indexedMap :: (Int -> a -> b) -> List a -> List b+indexedMap f xs =+ List.map2 f [0 .. (length xs - 1)] xs+++{-| Reduce a list from the left.++ > foldl (+) 0 [1,2,3] == 6+ > foldl (::) [] [1,2,3] == [3,2,1]++So 'foldl step state [1,2,3]' is like saying:++ > state+ > |> step 1+ > |> step 2+ > |> step 3+-}+foldl :: (a -> b -> b) -> b -> List a -> b+foldl func =+ -- Note: This function is implemented using fold' to eagerly evaluate the+ -- accumulator, preventing space leaks.+ Data.List.foldl' (flip func)+++{-| Reduce a list from the right.++ > foldr (+) 0 [1,2,3] == 6+ > foldr (::) [] [1,2,3] == [1,2,3]++So `foldr step state [1,2,3]` is like saying:++ > state+ > |> step 3+ > |> step 2+ > |> step 1++-}+foldr :: (a -> b -> b) -> b -> List a -> b+foldr =+ Data.List.foldr+++{-| Keep elements that satisfy the test.++ > filter isEven [1,2,3,4,5,6] == [2,4,6]+-}+filter :: (a -> Bool) -> List a -> List a+filter =+ Data.List.filter+++{-| Filter out certain values. For example, maybe you have a bunch of strings+from an untrusted source and you want to turn them into numbers:++ > numbers :: List Int+ > numbers =+ > filterMap String.toInt ["3", "hi", "12", "4th", "May"]+ >+ > -- numbers == [3, 12]++-}+filterMap :: (a -> Maybe b) -> List a -> List b+filterMap toMaybe =+ Data.Maybe.mapMaybe (\a -> toHMaybe (toMaybe a))++++-- UTILITIES+++{-| Determine the length of a list.++ > length [1,2,3] == 3+-}+length :: List a -> Int+length =+ Data.List.length+++{-| Reverse a list.++ > reverse [1,2,3,4] == [4,3,2,1]+-}+reverse :: List a -> List a+reverse =+ Data.List.reverse+++{-| Figure out whether a list contains a value.++ > member 9 [1,2,3,4] == False+ > member 4 [1,2,3,4] == True+-}+member :: Prelude.Eq a => a -> List a -> Bool+member =+ Data.List.elem++{-| Determine if all elements satisfy some test.++ > all isEven [2,4] == True+ > all isEven [2,3] == False+ > all isEven [] == True+-}+all :: (a -> Bool) -> List a -> Bool+all =+ Data.List.all+++{-| Determine if any elements satisfy some test.++ > any isEven [2,3] == True+ > any isEven [1,3] == False+ > any isEven [] == False+-}+any :: (a -> Bool) -> List a -> Bool+any =+ Data.List.any+++{-| Find the maximum element in a non-empty list.++ > maximum [1,4,2] == Just 4+ > maximum [] == Nothing+-}+maximum :: Prelude.Ord a => List a -> Maybe a+maximum list =+ case list of+ [] ->+ Nothing++ _ ->+ Just (Data.List.maximum list)+++{-| Find the minimum element in a non-empty list.++ > minimum [3,2,1] == Just 1+ > minimum [] == Nothing+-}+minimum :: Prelude.Ord a => List a -> Maybe a+minimum list =+ case list of+ [] ->+ Nothing++ _ ->+ Just (Data.List.minimum list)+++{-| Get the sum of the list elements.++ > sum [1,2,3] == 6+ > sum [1,1,1] == 3+ > sum [] == 0++-}+sum :: Prelude.Num a => List a -> a+sum =+ Prelude.sum+++{-| Get the product of the list elements.++ > product [2,2,2] == 8+ > product [3,3,3] == 27+ > product [] == 1++-}+product :: Prelude.Num a => List a -> a+product =+ Prelude.product++++-- COMBINE+++{-| Put two lists together.++ > append [1,1,2] [3,5,8] == [1,1,2,3,5,8]+ > append ['a','b'] ['c'] == ['a','b','c']++You can also use [the `(++)` operator](Basics#++) to append lists.+-}+append :: List a -> List a -> List a+append =+ Prelude.mappend+++{-| Concatenate a bunch of lists into a single list:++ > concat [[1,2],[3],[4,5]] == [1,2,3,4,5]+-}+concat :: List (List a) -> List a+concat =+ Prelude.mconcat+++{-| Map a given function onto a list and flatten the resulting lists.++ > concatMap f xs == concat (map f xs)+-}+concatMap :: (a -> List b) -> List a -> List b+concatMap =+ Shortcut.andThen+++{-| Places the given value between all members of the given list.++ > intersperse "on" ["turtles","turtles","turtles"] == ["turtles","on","turtles","on","turtles"]+-}+intersperse :: a -> List a -> List a+intersperse =+ Data.List.intersperse+++{-| Combine two lists, combining them with the given function.+If one list is longer, the extra elements are dropped.++ > totals :: List Int -> List Int -> List Int+ > totals xs ys =+ > List.map2 (+) xs ys+ >+ > -- totals [1,2,3] [4,5,6] == [5,7,9]+ >+ > pairs :: List a -> List b -> List (a,b)+ > pairs xs ys =+ > List.map2 Tuple.pair xs ys+ >+ > -- pairs ["alice","bob","chuck"] [2,5,7,8]+ > -- == [("alice",2),("bob",5),("chuck",7)]++-}+map2 :: (a -> b -> result) -> List a -> List b -> List result+map2 =+ Data.List.zipWith+++{-| -}+map3 :: (a -> b -> c -> result) -> List a -> List b -> List c -> List result+map3 =+ Data.List.zipWith3+++{-| -}+map4 :: (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result+map4 =+ Data.List.zipWith4+++{-| -}+map5 :: (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result+map5 =+ Data.List.zipWith5++++-- SORT+++{-| Sort values from lowest to highest++ sort [3,1,5] == [1,3,5]+-}+sort :: Prelude.Ord a => List a -> List a+sort =+ Data.List.sort+++{-| Sort values by a derived property.++ > alice = { name="Alice", height=1.62 }+ > bob = { name="Bob" , height=1.85 }+ > chuck = { name="Chuck", height=1.76 }+ >+ > sortBy .name [chuck,alice,bob] == [alice,bob,chuck]+ > sortBy .height [chuck,alice,bob] == [alice,chuck,bob]+ >+ > sortBy String.length ["mouse","cat"] == ["cat","mouse"]+-}+sortBy :: Prelude.Ord b => (a -> b) -> List a -> List a+sortBy =+ Data.List.sortOn+++{-| Sort values with a custom comparison function.++ > sortWith flippedComparison [1,2,3,4,5] == [5,4,3,2,1]+ >+ > flippedComparison a b =+ > case compare a b of+ > LT -> GT+ > EQ -> EQ+ > GT -> LT++This is also the most general sort function, allowing you+to define any other: `sort == sortWith compare`+-}+sortWith :: (a -> a -> Ordering) -> List a -> List a+sortWith =+ Data.List.sortBy++++-- DECONSTRUCT+++{-| Determine if a list is empty.++ > isEmpty [] == True++Note: It is usually preferable to use a `case` to test this so you do not+forget to handle the `(x :: xs)` case as well!+-}+isEmpty :: List a -> Bool+isEmpty =+ Data.List.null+++{-| Extract the first element of a list.++ > head [1,2,3] == Just 1+ > head [] == Nothing++Note: It is usually preferable to use a `case` to deconstruct a `List`+because it gives you `(x :: xs)` and you can work with both subparts.+-}+head :: List a -> Maybe a+head xs =+ case xs of+ x : _ ->+ Just x++ [] ->+ Nothing+++{-| Extract the rest of the list.++ > tail [1,2,3] == Just [2,3]+ > tail [] == Nothing++Note: It is usually preferable to use a `case` to deconstruct a `List`+because it gives you `(x :: xs)` and you can work with both subparts.+-}+tail :: List a -> Maybe (List a)+tail list =+ case list of+ _ : xs ->+ Just xs++ [] ->+ Nothing+++{-| Take the first *n* members of a list.++ > take 2 [1,2,3,4] == [1,2]+-}+take :: Int -> List a -> List a+take =+ Data.List.take+++{-| Drop the first *n* members of a list.++ > drop 2 [1,2,3,4] == [3,4]+-}+drop :: Int -> List a -> List a+drop =+ Data.List.drop+++{-| Partition a list based on some test. The first list contains all values+that satisfy the test, and the second list contains all the value that do not.++ > partition (\x -> x < 3) [0,1,2,3,4,5] == ([0,1,2], [3,4,5])+ > partition isEven [0,1,2,3,4,5] == ([0,2,4], [1,3,5])+-}+partition :: (a -> Bool) -> List a -> (List a, List a)+partition =+ Data.List.partition+++{-| Decompose a list of tuples into a tuple of lists.++ > unzip [(0, True), (17, False), (1337, True)] == ([0,17,1337], [True,False,True])+-}+unzip :: List (a, b) -> (List a, List b)+unzip =+ Data.List.unzip++++-- INTERNAL+++toHMaybe :: Maybe a -> Data.Maybe.Maybe a+toHMaybe maybe =+ case maybe of+ Just a -> Data.Maybe.Just a+ Nothing -> Data.Maybe.Nothing
+ src/Maybe.hs view
@@ -0,0 +1,176 @@++{-|++Module : Maybe+Description : A `Maybe` can help you with optional arguments, error handling, and records with optional fields.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++A `Maybe` can help you with optional arguments, error handling, and records with optional fields.++-}++module Maybe+ ( -- * Definition+ Maybe(..)++ -- * Common Helpers+ , withDefault, map, map2, map3, map4, map5++ -- * Chaining Maybes+ , andThen+ )+where++import Prelude (Applicative, Char, Eq, Functor, Monad, Num, Ord, Show, flip, fromIntegral, mappend, mconcat, otherwise, pure)+import qualified Prelude+import qualified Internal.Shortcut as Shortcut+++{-| Represent values that may or may not exist. It can be useful if you have a+record field that is only filled in sometimes. Or if a function takes a value+sometimes, but does not absolutely need it.++ > -- A person, but maybe we do not know their age.+ > data Person = Person+ > { name :: String+ > , age :: Maybe Int+ > }+ >+ > tom = { name = "Tom", age = Just 42 }+ > sue = { name = "Sue", age = Nothing }+-}+data Maybe a+ = Just a+ | Nothing+ deriving (Prelude.Show, Prelude.Eq)+++instance Functor Maybe where+ fmap func maybe =+ case maybe of+ Just a -> Just (func a)+ Nothing -> Nothing+++instance Applicative Maybe where+ pure a =+ Just a++ (<*>) func maybe =+ case (func, maybe) of+ (Just f, Just a) -> Just (f a)+ _ -> Nothing+++instance Monad Maybe where+ maybe >>= func =+ case maybe of+ Just a -> func a+ Nothing -> Nothing+++{-| Provide a default value, turning an optional value into a normal+value. This comes in handy when paired with functions like+[`Dict.get`](Dict#get) which gives back a `Maybe`.++ > withDefault 100 (Just 42) -- 42+ > withDefault 100 Nothing -- 100+ >+ > withDefault "unknown" (Dict.get "Tom" Dict.empty) -- "unknown"++Note: This can be overused! Many cases are better handled by a `case`+expression. And if you end up using `withDefault` a lot, it can be a good sign+that a [custom type](https://guide.elm-lang.org/types/custom_types.html) will clean your code up quite a bit!+-}+withDefault :: a -> Maybe a -> a+withDefault value maybe =+ case maybe of+ Just a -> a+ Nothing -> value+++{-| Transform a `Maybe` value with a given function:++ > map sqrt (Just 9) == Just 3+ > map sqrt Nothing == Nothing++ > map sqrt (String.toFloat "9") == Just 3+ > map sqrt (String.toFloat "x") == Nothing++-}+map :: (a -> b) -> Maybe a -> Maybe b+map =+ Shortcut.map+++{-| Apply a function if all the arguments are `Just` a value.++ > map2 (+) (Just 3) (Just 4) == Just 7+ > map2 (+) (Just 3) Nothing == Nothing+ > map2 (+) Nothing (Just 4) == Nothing+ >+ > map2 (+) (String.toInt "1") (String.toInt "123") == Just 124+ > map2 (+) (String.toInt "x") (String.toInt "123") == Nothing+ > map2 (+) (String.toInt "1") (String.toInt "1.3") == Nothing+-}+map2 :: (a -> b -> value) -> Maybe a -> Maybe b -> Maybe value+map2 =+ Shortcut.map2+++{-|-}+map3 :: (a -> b -> c -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe value+map3 =+ Shortcut.map3+++{-|-}+map4 :: (a -> b -> c -> d -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe d -> Maybe value+map4 =+ Shortcut.map4+++{-|-}+map5 :: (a -> b -> c -> d -> e -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe d -> Maybe e -> Maybe value+map5 =+ Shortcut.map5+++{-| Chain together many computations that may fail. It is helpful to see its+definition:++ > andThen :: (a -> Maybe b) -> Maybe a -> Maybe b+ > andThen callback maybe =+ > case maybe of+ > Just value ->+ > callback value+ >+ > Nothing ->+ > Nothing++This means we only continue with the callback if things are going well. For+example, say you need to parse some user input as a month:++ > parseMonth :: String -> Maybe Int+ > parseMonth userInput =+ > String.toInt userInput+ > |> andThen toValidMonth+ >+ > toValidMonth :: Int -> Maybe Int+ > toValidMonth month =+ > if 1 <= month && month <= 12 then+ > Just month+ > else+ > Nothing++In the `parseMonth` function, if `String.toInt` produces `Nothing` (because+the `userInput` was not an integer) this entire chain of operations will+short-circuit and result in `Nothing`. If `toValidMonth` results in `Nothing`,+again the chain of computations will result in `Nothing`.+-}+andThen :: (a -> Maybe b) -> Maybe a -> Maybe b+andThen =+ Shortcut.andThen
+ src/Parser.hs view
@@ -0,0 +1,493 @@+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns, MagicHash, Rank2Types, UnboxedTuples #-}+module Parser+ ( fromString+ , Parser(..), State(..), Pos, End, Row, Col+ , oneOf, oneOfWithFallback+ , inContext, specialize+ , getPosition, getCol, addLocation, addEnd+ , word1, word2+ , symbol, k4, k5+ , unsafeIndex, isWord, getCharWidth+ , chompInnerChars+ , getUpperWidth+ , getInnerWidth+ , getInnerWidthHelp+ )+ where+++import qualified Data.Char as Char+import qualified Data.Text.Internal as T+import qualified Data.Text.Array as T+import GHC.Exts (Char(C#), Int#, (+#), (-#), chr#, uncheckedIShiftL#, word2Int#)+import GHC.Prim (ByteArray#, indexWord8Array#)+import GHC.Types (Int(I#))+import GHC.Word (Word8(W8#), Word16)+import qualified Parser.Reporting as R+import Prelude hiding (length)++import qualified Result as R+import qualified String++++-- PARSER+++newtype Parser x a =+ Parser (+ forall b.+ State+ -> (a -> State -> b) -- consumed ok+ -> (a -> State -> b) -- empty ok+ -> (Row -> Col -> (Row -> Col -> x) -> b) -- consumed err+ -> (Row -> Col -> (Row -> Col -> x) -> b) -- empty err+ -> b+ )+++data State = -- TODO try taking some out to avoid allocation?+ State+ { _src :: ByteArray#+ , _pos :: {-# UNPACK #-} !Pos+ , _end :: {-# UNPACK #-} !End+ , _row :: {-# UNPACK #-} !Row+ , _col :: {-# UNPACK #-} !Col+ }+++type Pos = Int+type End = Int++type Row = Word16+type Col = Word16++++-- FUNCTOR+++instance Functor (Parser x) where+ {-# INLINE fmap #-}+ fmap f (Parser parser) =+ Parser $ \state cok eok cerr eerr ->+ let+ cok' a s = cok (f a) s+ eok' a s = eok (f a) s+ in+ parser state cok' eok' cerr eerr++++-- APPLICATIVE+++instance Applicative (Parser x) where+ {-# INLINE pure #-}+ pure = return++ {-# INLINE (<*>) #-}+ (<*>) (Parser parserFunc) (Parser parserArg) =+ Parser $ \state cok eok cerr eerr ->+ let+ cokF func s1 =+ let+ cokA arg s2 = cok (func arg) s2+ in+ parserArg s1 cokA cokA cerr cerr++ eokF func s1 =+ let+ cokA arg s2 = cok (func arg) s2+ eokA arg s2 = eok (func arg) s2+ in+ parserArg s1 cokA eokA cerr eerr+ in+ parserFunc state cokF eokF cerr eerr++++-- ONE OF+++{-# INLINE oneOf #-}+oneOf :: (Row -> Col -> x) -> [Parser x a] -> Parser x a+oneOf toError parsers =+ Parser $ \state cok eok cerr eerr ->+ oneOfHelp state cok eok cerr eerr toError parsers+++oneOfHelp+ :: State+ -> (a -> State -> b)+ -> (a -> State -> b)+ -> (Row -> Col -> (Row -> Col -> x) -> b)+ -> (Row -> Col -> (Row -> Col -> x) -> b)+ -> (Row -> Col -> x)+ -> [Parser x a]+ -> b+oneOfHelp state cok eok cerr eerr toError parsers =+ case parsers of+ Parser parser : parsers ->+ let+ eerr' _ _ _ =+ oneOfHelp state cok eok cerr eerr toError parsers+ in+ parser state cok eok cerr eerr'++ [] ->+ let+ (State _ _ _ row col) = state+ in+ eerr row col toError++++-- ONE OF WITH FALLBACK+++{-# INLINE oneOfWithFallback #-}+oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- TODO is this function okay? Worried about allocation/laziness with fallback values.+oneOfWithFallback parsers fallback =+ Parser $ \state cok eok cerr _ ->+ oowfHelp state cok eok cerr parsers fallback+++oowfHelp+ :: State+ -> (a -> State -> b)+ -> (a -> State -> b)+ -> (Row -> Col -> (Row -> Col -> x) -> b)+ -> [Parser x a]+ -> a+ -> b+oowfHelp state cok eok cerr parsers fallback =+ case parsers of+ [] ->+ eok fallback state++ Parser parser : parsers ->+ let+ eerr' _ _ _ =+ oowfHelp state cok eok cerr parsers fallback+ in+ parser state cok eok cerr eerr'++++-- MONAD+++instance Monad (Parser x) where+ {-# INLINE return #-}+ return value =+ Parser $ \state _ eok _ _ ->+ eok value state++ {-# INLINE (>>=) #-}+ (Parser parserA) >>= callback =+ Parser $ \state cok eok cerr eerr ->+ let+ cok' a s =+ case callback a of+ Parser parserB -> parserB s cok cok cerr cerr++ eok' a s =+ case callback a of+ Parser parserB -> parserB s cok eok cerr eerr+ in+ parserA state cok' eok' cerr eerr++++-- FROM STRING+++fromString :: Parser x a -> (Row -> Col -> x) -> String.String -> R.Result x a+fromString (Parser parser) toBadEnd string =+ let+ !(T.Text (T.Array src) pos length) = String.toTextUtf8 string+ toOk' = toOk toBadEnd+ in+ parser (State src pos (pos + length) 1 1) toOk' toOk' toErr toErr+++toOk :: (Row -> Col -> x) -> a -> State -> R.Result x a+toOk toBadEnd !a (State _ pos end row col) =+ if pos == end+ then R.Ok a+ else R.Err (toBadEnd row col)+++toErr :: Row -> Col -> (Row -> Col -> x) -> R.Result x a+toErr row col toError =+ R.Err (toError row col)++++-- POSITION+++getCol :: Parser x Word16+getCol =+ Parser $ \state@(State _ _ _ _ col) _ eok _ _ ->+ eok col state+++{-# INLINE getPosition #-}+getPosition :: Parser x R.Position+getPosition =+ Parser $ \state@(State _ _ _ row col) _ eok _ _ ->+ eok (R.Position row col) state+++addLocation :: Parser x a -> Parser x (R.Located a)+addLocation (Parser parser) =+ Parser $ \state@(State _ _ _ sr sc) cok eok cerr eerr ->+ let+ cok' a s@(State _ _ _ er ec) = cok (R.At (R.Region (R.Position sr sc) (R.Position er ec)) a) s+ eok' a s@(State _ _ _ er ec) = eok (R.At (R.Region (R.Position sr sc) (R.Position er ec)) a) s+ in+ parser state cok' eok' cerr eerr+++addEnd :: R.Position -> a -> Parser x (R.Located a)+addEnd start value =+ Parser $ \state@(State _ _ _ row col) _ eok _ _ ->+ eok (R.at start (R.Position row col) value) state++++-- CONTEXT+++inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a+inContext addContext (Parser parserStart) (Parser parserA) =+ Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->+ let+ cerrA r c tx = cerr row col (addContext (tx r c))+ eerrA r c tx = eerr row col (addContext (tx r c))++ cokS _ s = parserA s cok cok cerrA cerrA+ eokS _ s = parserA s cok eok cerrA eerrA+ in+ parserStart state cokS eokS cerr eerr+++specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a+specialize addContext (Parser parser) =+ Parser $ \state@(State _ _ _ row col) cok eok cerr eerr ->+ let+ cerr' r c tx = cerr row col (addContext (tx r c))+ eerr' r c tx = eerr row col (addContext (tx r c))+ in+ parser state cok eok cerr' eerr'++++-- SYMBOLS+++word1 :: Word8 -> (Row -> Col -> x) -> Parser x ()+word1 word toError =+ Parser $ \(State src pos end row col) cok _ _ eerr ->+ if pos < end && unsafeIndex src pos == word then+ let !newState = State src (pos + 1) end row (col + 1) in+ cok () newState+ else+ eerr row col toError+++word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()+word2 w1 w2 toError =+ Parser $ \(State src pos end row col) cok _ _ eerr ->+ let+ !pos1 = pos + 1+ in+ if pos1 < end && unsafeIndex src pos == w1 && unsafeIndex src pos1 == w2 then+ let !newState = State src (pos + 2) end row (col + 2) in+ cok () newState+ else+ eerr row col toError+++symbol :: Word8 -> (Row -> Col -> x) -> Parser x ()+symbol w1 toError =+ Parser $ \(State src pos end row col) cok _ _ eerr ->+ let !pos1 = pos + 1 in+ if pos1 <= end && unsafeIndex src pos == w1+ then+ let !s = State src pos1 end row (col + 1) in cok () s+ else+ eerr row col toError+++k4 :: Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()+k4 w1 w2 w3 w4 toError =+ Parser $ \(State src pos end row col) cok _ _ eerr ->+ let !pos4 = pos + 4 in+ if pos4 <= end+ && unsafeIndex src (pos ) == w1+ && unsafeIndex src (pos + 1) == w2+ && unsafeIndex src (pos + 2) == w3+ && unsafeIndex src (pos + 3) == w4+ && getInnerWidth src pos4 end == 0+ then+ let !s = State src pos4 end row (col + 4) in cok () s+ else+ eerr row col toError+++k5 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> (Row -> Col -> x) -> Parser x ()+k5 w1 w2 w3 w4 w5 toError =+ Parser $ \(State src pos end row col) cok _ _ eerr ->+ let !pos5 = pos + 5 in+ if pos5 <= end+ && unsafeIndex src (pos ) == w1+ && unsafeIndex src (pos + 1) == w2+ && unsafeIndex src (pos + 2) == w3+ && unsafeIndex src (pos + 3) == w4+ && unsafeIndex src (pos + 4) == w5+ && getInnerWidth src pos5 end == 0+ then+ let !s = State src pos5 end row (col + 5) in cok () s+ else+ eerr row col toError++++-- LOW-LEVEL CHECKS+++{-# INLINE unsafeIndex #-}+unsafeIndex :: ByteArray# -> Pos -> Word8+unsafeIndex src (I# pos) =+ W8# (indexWord8Array# src pos)+++{-# INLINE isWord #-}+isWord :: ByteArray# -> Pos -> End -> Word8 -> Bool+isWord src pos end word =+ pos < end && unsafeIndex src pos == word+++getCharWidth :: Word8 -> Int+getCharWidth word+ | word < 0x80 = 1+ | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits."+ | word < 0xe0 = 2+ | word < 0xf0 = 3+ | word < 0xf8 = 4+ | True = error "Need UTF-8 encoded input. Ran into unrecognized bits."++++-- UPPER CHARS+++{-# INLINE getUpperWidth #-}+getUpperWidth :: ByteArray# -> Pos -> End -> Int+getUpperWidth src pos end =+ if pos < end then+ getUpperWidthHelp src pos end (unsafeIndex src pos)+ else+ 0+++{-# INLINE getUpperWidthHelp #-}+getUpperWidthHelp :: ByteArray# -> Pos -> End -> Word8 -> Int+getUpperWidthHelp src pos _ word+ | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1+ | word < 0xc0 = 0+ | word < 0xe0 = if Char.isUpper (chr2 src pos word) then 2 else 0+ | word < 0xf0 = if Char.isUpper (chr3 src pos word) then 3 else 0+ | word < 0xf8 = if Char.isUpper (chr4 src pos word) then 4 else 0+ | True = 0++++-- INNER CHARS+++chompInnerChars :: ByteArray# -> Pos -> End -> Col -> (# Pos, Col #)+chompInnerChars src !pos end !col =+ let !width = getInnerWidth src pos end in+ if width == 0 then+ (# pos, col #)+ else+ chompInnerChars src (pos + width) end (col + 1)+++getInnerWidth :: ByteArray# -> Pos -> End -> Int+getInnerWidth src pos end =+ if pos < end then+ getInnerWidthHelp src pos end (unsafeIndex src pos)+ else+ 0+++{-# INLINE getInnerWidthHelp #-}+getInnerWidthHelp :: ByteArray# -> Pos -> End -> Word8 -> Int+getInnerWidthHelp src pos _ word+ | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1+ | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1+ | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1+ | word == 0x5F {- _ -} = 1+ | word < 0xc0 = 0+ | word < 0xe0 = if Char.isAlpha (chr2 src pos word) then 2 else 0+ | word < 0xf0 = if Char.isAlpha (chr3 src pos word) then 3 else 0+ | word < 0xf8 = if Char.isAlpha (chr4 src pos word) then 4 else 0+ | True = 0++++-- EXTRACT CHARACTERS+++{-# INLINE chr2 #-}+chr2 :: ByteArray# -> Pos -> Word8 -> Char+chr2 src pos firstWord =+ let+ !i1# = unpack firstWord+ !i2# = unpack (unsafeIndex src (pos + 1))+ !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#+ !c2# = i2# -# 0x80#+ in+ C# (chr# (c1# +# c2#))+++{-# INLINE chr3 #-}+chr3 :: ByteArray# -> Pos -> Word8 -> Char+chr3 src pos firstWord =+ let+ !i1# = unpack firstWord+ !i2# = unpack (unsafeIndex src (pos + 1))+ !i3# = unpack (unsafeIndex src (pos + 2))+ !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#+ !c3# = i3# -# 0x80#+ in+ C# (chr# (c1# +# c2# +# c3#))+++{-# INLINE chr4 #-}+chr4 :: ByteArray# -> Pos -> Word8 -> Char+chr4 src pos firstWord =+ let+ !i1# = unpack firstWord+ !i2# = unpack (unsafeIndex src (pos + 1))+ !i3# = unpack (unsafeIndex src (pos + 2))+ !i4# = unpack (unsafeIndex src (pos + 3))+ !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#+ !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#+ !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#+ !c4# = i4# -# 0x80#+ in+ C# (chr# (c1# +# c2# +# c3# +# c4#))+++unpack :: Word8 -> Int#+unpack (W8# word#) =+ word2Int# word#+
+ src/Parser/Reporting.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -Wall #-}+module Parser.Reporting+ ( Located(..)+ , Position(..)+ , Region(..)+ , traverse+ , toValue+ , merge+ , at+ , toRegion+ , mergeRegions+ , zero+ , one+ )+ where+++import Prelude hiding (traverse)+import Control.Monad (liftM2)+import Data.Binary (Binary, get, put)+import Data.Word (Word16)++++-- LOCATED+++data Located a =+ At Region a -- TODO see if unpacking region is helpful+++instance Functor Located where+ fmap f (At region a) =+ At region (f a)+++traverse :: (Functor f) => (a -> f b) -> Located a -> f (Located b)+traverse func (At region value) =+ At region <$> func value+++toValue :: Located a -> a+toValue (At _ value) =+ value+++merge :: Located a -> Located b -> value -> Located value+merge (At r1 _) (At r2 _) value =+ At (mergeRegions r1 r2) value++++-- POSITION+++data Position =+ Position+ {-# UNPACK #-} !Word16+ {-# UNPACK #-} !Word16+ deriving (Eq)+++at :: Position -> Position -> a -> Located a+at start end a =+ At (Region start end) a++++-- REGION+++data Region = Region Position Position+ deriving (Eq)+++toRegion :: Located a -> Region+toRegion (At region _) =+ region+++mergeRegions :: Region -> Region -> Region+mergeRegions (Region start _) (Region _ end) =+ Region start end+++zero :: Region+zero =+ Region (Position 0 0) (Position 0 0)+++one :: Region+one =+ Region (Position 1 1) (Position 1 1)+++instance Binary Region where+ put (Region a b) = put a >> put b+ get = liftM2 Region get get+++instance Binary Position where+ put (Position a b) = put a >> put b+ get = liftM2 Position get get+
+ src/Result.hs view
@@ -0,0 +1,225 @@++{-|++Module : Result+Description : A `Result` is the result of a computation that may fail. This is a great way to manage errors.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++A `Result` is the result of a computation that may fail. This is a great way to manage errors.++-}++module Result+ ( Result(..)++ -- * Mapping+ , map, map2, map3, map4, map5++ -- * Chaining+ , andThen++ -- * Handling Errors+ , withDefault, toMaybe, fromMaybe, mapError++ -- * Conversions from Haskell Types+ , fromEither+ )+where++import Prelude (Applicative, Char, Eq, Functor, Monad, Num, Ord, Show, flip, fromIntegral, mappend, mconcat, otherwise, pure, (<*>), (>>=), fmap)+import Maybe (Maybe(Just, Nothing))+import qualified Data.Either+import qualified Internal.Shortcut as Shortcut+++{-| A `Result` is either `Ok` meaning the computation succeeded, or it is an+`Err` meaning that there was some failure.+-}+data Result error success+ = Ok success+ | Err error+ deriving (Prelude.Show, Prelude.Eq)+++instance Functor (Result error) where+ fmap func result =+ case result of+ Ok success -> Ok (func success)+ Err error -> Err error+++instance Applicative (Result error) where+ pure = Ok+ (<*>) r1 r2 =+ case (r1, r2) of+ (Ok func, Ok a) -> Ok (func a)+ (Err err, _) -> Err err+ (Ok _, Err err) -> Err err+++instance Monad (Result error) where+ (>>=) result func =+ case result of+ Ok success -> func success+ Err error -> Err error+++{-| If the result is `Ok` return the value, but if the result is an `Err` then+return a given default value. The following examples try to parse integers.++ > Result.withDefault 0 (Ok 123) == 123+ > Result.withDefault 0 (Err "no") == 0+-}+withDefault :: a -> Result b a -> a+withDefault fallback result =+ case result of+ Ok success -> success+ Err _ -> fallback+++{-| Apply a function to a result. If the result is `Ok`, it will be converted.+If the result is an `Err`, the same error value will propagate through.++ map sqrt (Ok 4.0) == Ok 2.0+ map sqrt (Err "bad input") == Err "bad input"+-}+map :: (a -> b) -> Result c a -> Result c b+map =+ Shortcut.map+++{-| Apply a function if both results are `Ok`. If not, the first `Err` will+propagate through.++ > map2 max (Ok 42) (Ok 13) == Ok 42+ > map2 max (Err "x") (Ok 13) == Err "x"+ > map2 max (Ok 42) (Err "y") == Err "y"+ > map2 max (Err "x") (Err "y") == Err "x"++This can be useful if you have two computations that may fail, and you want+to put them together quickly.+-}+map2 :: (a -> b -> c) -> Result err a -> Result err b -> Result err c+map2 =+ Shortcut.map2+++{-|-}+map3 :: (a -> b -> c -> d) -> Result err a -> Result err b -> Result err c -> Result err d+map3 =+ Shortcut.map3+++{-|-}+map4 :: (a -> b -> c -> d -> e) -> Result err a -> Result err b -> Result err c -> Result err d -> Result err e+map4 =+ Shortcut.map4+++{-|-}+map5 :: (a -> b -> c -> d -> e -> f) -> Result err a -> Result err b -> Result err c -> Result err d -> Result err e -> Result err f+map5 =+ Shortcut.map5+++{-| Chain together a sequence of computations that may fail. It is helpful+to see its definition:++ > andThen :: (a -> Result e b) -> Result e a -> Result e b+ > andThen callback result =+ > case result of+ > Ok value -> callback value+ > Err msg -> Err msg++This means we only continue with the callback if things are going well. For+example, say you need to use (`toInt :: String -> Result String Int`) to parse+a month and make sure it is between 1 and 12:++ > toValidMonth :: Int -> Result String Int+ > toValidMonth month =+ > if month >= 1 && month <= 12+ > then Ok month+ > else Err "months must be between 1 and 12"++ > toMonth :: String -> Result String Int+ > toMonth rawString =+ > toInt rawString+ > |> andThen toValidMonth++ > -- toMonth "4" == Ok 4+ > -- toMonth "9" == Ok 9+ > -- toMonth "a" == Err "cannot parse to an Int"+ > -- toMonth "0" == Err "months must be between 1 and 12"++This allows us to come out of a chain of operations with quite a specific error+message. It is often best to create a custom type that explicitly represents+the exact ways your computation may fail. This way it is easy to handle in your+code.+-}+andThen :: (a -> Result c b) -> Result c a -> Result c b+andThen =+ Shortcut.andThen+++{-| Transform an `Err` value. For example, say the errors we get have too much+information:++ > parseInt :: String -> Result ParseError Int+ >+ > data ParseError = ParseError+ > { message :: String+ > , code :: Int+ > , position :: (Int,Int)+ > }+ >+ > mapError message (parseInt "123") == Ok 123+ > mapError message (parseInt "abc") == Err "char 'a' is not a number"+-}+mapError :: (a -> b) -> Result a c -> Result b c+mapError func result =+ case result of+ Ok success -> Ok success+ Err error -> Err (func error)+++{-| Convert to a simpler `Maybe` if the actual error message is not needed or+you need to interact with some code that primarily uses maybes.++ > parseInt :: String -> Result ParseError Int+ >+ > maybeParseInt :: String -> Maybe Int+ > maybeParseInt string =+ > toMaybe (parseInt string)+-}+toMaybe :: Result a b -> Maybe b+toMaybe result =+ case result of+ Ok success -> Just success+ Err _ -> Nothing+++{-| Convert from a simple `Maybe` to interact with some code that primarily+uses `Results`.++ > parseInt :: String -> Maybe Int+ >+ > resultParseInt :: String -> Result String Int+ > resultParseInt string =+ > fromMaybe ("error parsing string: " ++ toString string) (parseInt string)+-}+fromMaybe :: a -> Maybe b -> Result a b+fromMaybe error maybe =+ case maybe of+ Just something -> Ok something+ Nothing -> Err error+++{-| -}+fromEither :: Data.Either.Either x a -> Result x a+fromEither either =+ case either of+ Data.Either.Right a -> Ok a+ Data.Either.Left x -> Err x
+ src/Server.hs view
@@ -0,0 +1,256 @@+{-|++Module : Server+Description : Run a server.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module Server (listen, get, post, text, json, file, body) where++import qualified Control.Exception.Safe as Control+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Maybe as HMaybe+import qualified Data.Either as Either+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Base64 as Base64+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Encoding as Encoding+import qualified Data.Text.Encoding.Error as Encoding+import qualified Data.Time.Clock.POSIX as POSIX+import qualified Data.CaseInsensitive as CI+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Middleware.Static as Static+import qualified Network.Wai.Middleware.RequestLogger as RequestLogger+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Types.Method as Method+import qualified Network.HTTP.Types.Header as Header+import qualified Prelude+import qualified Maybe+import qualified String+import qualified Debug+import qualified List+import qualified Tuple+import qualified Http+import qualified Result+import qualified Dict+import qualified Task+import qualified Terminal+import qualified Url+import qualified Url.Parser as Parser+import qualified Interop+import qualified Json.Encode as E+import qualified Json.Decode as D+import Cherry.Prelude+import Url.Parser (Parser)+++{-| -}+type Port =+ Int+++{-| -}+listen :: Port -> String -> List Route -> Task String ()+listen port public routes =+ let log =+ RequestLogger.logStdoutDev++ static =+ Static.staticPolicy (Static.addBase (String.toList public))++ listen_ =+ Warp.run port application_+ |> Interop.enter+ |> Task.mapError (\_ -> "Could not start server.")++ application_ =+ application public routes+ |> log+ |> static+ in do+ Terminal.write (String.concat [ "Listening on port ", String.fromInt port, "..." ])+ listen_+++{-| -}+newtype Route =+ Route (Http.Request -> Url.Url -> Maybe (Task String Http.Response))+++{-| -}+get :: Parser a (Task String Http.Response) -> (Http.Request -> a) -> Route+get parser handler =+ Route <| \request url ->+ if Wai.requestMethod request == Method.methodGet then+ Parser.parse (Parser.map (handler request) parser) url+ else+ Nothing+++{-| -}+post :: Parser a (Task String Http.Response) -> (Http.Request -> a) -> Route+post parser handler =+ Route <| \request url ->+ if Wai.requestMethod request == Method.methodPost then+ Parser.parse (Parser.map (handler request) parser) url+ else+ Nothing+++{-| -}+text :: Int -> String -> Http.Response+text statusNo string =+ Wai.responseLBS (statusCode statusNo) [] (String.toLazyByteString string)+++{-| -}+json :: Int -> E.Value -> Http.Response+json statusNo value =+ Wai.responseBuilder (statusCode statusNo) [] (E.toBuilder value)+++{-| -}+file :: Int -> String -> Http.Response+file statusNo path =+ Wai.responseFile (statusCode statusNo) [] (String.toList path) HMaybe.Nothing++++-- HELPERS+++{-| -}+body :: D.Decoder a -> Http.Request -> Task.Task String a+body decoder request =+ let getChunks :: List B.ByteString -> Task.Task String B.ByteString+ getChunks chunks =+ Wai.getRequestBodyChunk request+ |> Interop.enter+ |> Task.mapError (\_ -> "Body could not be parsed")+ |> Task.andThen (\chunk ->+ if chunk == B.empty+ then Task.succeed (B.concat (List.reverse chunks))+ else getChunks (chunk : chunks)+ )++ decode bs =+ String.fromByteString bs+ |> D.fromString decoder+ |> fromResult++ fromResult result =+ case result of+ Ok v -> Task.succeed v+ Err e -> Task.fail "Body could not be parsed"+ in+ getChunks []+ |> Task.andThen decode++++-- INTERNAL+++application :: String -> List Route -> Wai.Application+application public routes request respond =+ let url = requestToUrl request+ allRoutes = collectRoutes public routes+ in+ findResponse public url request allRoutes+ |> Task.attempt+ |> Interop.andThen (toSafeResponse >> respond)+++requestToUrl :: Http.Request -> Url.Url+requestToUrl request =+ let toPath request =+ Wai.rawPathInfo request+ |> String.fromByteString++ toQuery request =+ Wai.rawQueryString request+ |> B.tail+ |> String.fromByteString+ |> nothingIfEmpty++ nothingIfEmpty string =+ if String.isEmpty string then+ Nothing+ else+ Just string+ in+ Url.Url+ { Url.path = toPath request+ , Url.query = toQuery request+ }+++findResponse :: String -> Url.Url -> Http.Request -> List Route -> Task String Http.Response+findResponse public url request remaining =+ case remaining of+ Route next : rest ->+ case next request url of+ Just response -> response+ Nothing -> findResponse public url request rest++ [] ->+ Task.succeed (serve404 public)+++collectRoutes :: String -> List Route -> List Route+collectRoutes public routes =+ routes ++ [ homeRoute public ]+++homeRoute :: String -> Route+homeRoute public =+ get Parser.top <| \_ ->+ Task.succeed (serveIndex public)+++statusCode :: Int -> HTTP.Status+statusCode statusNo =+ case statusNo of+ 200 -> HTTP.status200+ 404 -> HTTP.status404+ 401 -> HTTP.status401+ 501 -> HTTP.status501+ _ -> HTTP.status404 -- TODO++++-- RESPONSES+++serveIndex :: String -> Http.Response+serveIndex public =+ file 200 (String.concat [ public, "/index.html" ])+++serve404 :: String -> Http.Response+serve404 public =+ file 404 (String.concat [ public, "/404.html" ])+++internalError :: String -> Http.Response+internalError err =+ Wai.responseLBS HTTP.status500 [] (String.toLazyByteString err)+++notFound :: Http.Response+notFound =+ Wai.responseLBS HTTP.status404 [] "Route not found"+++toSafeResponse :: Result String Http.Response -> Http.Response+toSafeResponse result =+ case result of+ Result.Ok response -> response+ Result.Err msg -> internalError msg
+ src/Set.hs view
@@ -0,0 +1,176 @@++{-|++Module : Set+Description : Work with sets.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module Set+ ( Set++ -- * Build+ , empty, singleton, insert, remove++ -- * Query+ , isEmpty, member, size++ -- * Combine+ , union, intersect, diff++ -- * Lists+ , toList, fromList++ -- * Transform+ , map, foldl, foldr, filter, partition+ )+where++import Basics ((>>), Bool, Int)+import List (List)+import qualified Data.Set+import qualified Prelude+++{-| Represents a set of unique values. So `(Set Int)` is a set of integers and+`(Set String)` is a set of strings.+-}+type Set t =+ Data.Set.Set t+++{-| Create an empty set.+-}+empty :: Set a+empty =+ Data.Set.empty+++{-| Create a set with one value.+-}+singleton :: comparable -> Set comparable+singleton =+ Data.Set.singleton+++{-| Insert a value into a set.+-}+insert :: Prelude.Ord comparable => comparable -> Set comparable -> Set comparable+insert =+ Data.Set.insert+++{-| Remove a value from a set. If the value is not found, no changes are made.+-}+remove :: Prelude.Ord comparable => comparable -> Set comparable -> Set comparable+remove =+ Data.Set.delete+++{-| Determine if a set is empty.+-}+isEmpty :: Set a -> Bool+isEmpty =+ Data.Set.null+++{-| Determine if a value is in a set.+-}+member :: Prelude.Ord comparable => comparable -> Set comparable -> Bool+member =+ Data.Set.member+++{-| Determine the number of elements in a set.+-}+size :: Set a -> Int+size =+ Data.Set.size >> Prelude.fromIntegral+++{-| Get the union of two sets. Keep all values.+-}+union :: Prelude.Ord comparable => Set comparable -> Set comparable -> Set comparable+union =+ Data.Set.union+++{-| Get the intersection of two sets. Keeps values that appear in both sets.+-}+intersect :: Prelude.Ord comparable => Set comparable -> Set comparable -> Set comparable+intersect =+ Data.Set.intersection+++{-| Get the difference between the first set and the second. Keeps values+that do not appear in the second set.+-}+diff :: Prelude.Ord comparable => Set comparable -> Set comparable -> Set comparable+diff =+ Data.Set.difference+++{-| Convert a set into a list, sorted from lowest to highest.+-}+toList :: Set a -> List a+toList =+ Data.Set.toAscList+++{-| Convert a list into a set, removing any duplicates.+-}+fromList :: Prelude.Ord comparable => List comparable -> Set comparable+fromList =+ Data.Set.fromList+++{-| Fold over the values in a set, in order from lowest to highest.+-}+foldl :: (a -> b -> b) -> b -> Set a -> b+foldl func =+ Data.Set.foldl' (Prelude.flip func)+++{-| Fold over the values in a set, in order from highest to lowest.+-}+foldr :: (a -> b -> b) -> b -> Set a -> b+foldr =+ Data.Set.foldr'+++{-| Map a function onto a set, creating a new set with no duplicates.+-}+map :: Prelude.Ord comparable2 => (comparable -> comparable2) -> Set comparable -> Set comparable2+map =+ Data.Set.map+++{-| Only keep elements that pass the given test.++ > import Set exposing (Set)+ >+ > numbers :: Set Int+ > numbers =+ > Set.fromList [-2,-1,0,1,2]+ >+ > positives :: Set Int+ > positives =+ > Set.filter (\x -> x > 0) numbers+ >+ > -- positives == Set.fromList [1,2]+-}+filter :: (comparable -> Bool) -> Set comparable -> Set comparable+filter =+ Data.Set.filter+++{-| Create two new sets. The first contains all the elements that passed the+given test, and the second contains all the elements that did not.+-}+partition :: (comparable -> Bool) -> Set comparable -> (Set comparable, Set comparable)+partition =+ Data.Set.partition
+ src/String.hs view
@@ -0,0 +1,680 @@++{-|++Module : String+Description : A built-in representation for efficient string manipulation. `String` values are *not* lists of characters.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}++module String+ ( -- * String+ String, isEmpty, length, reverse, repeat, replace++ -- * Building and Splitting+ , append, concat, split, join, words, lines++ -- * Get Substrings+ , slice, left, right, dropLeft, dropRight++ -- * Check for Substrings+ , contains, startsWith, endsWith, indexes, indices++ -- * Int Conversions+ , toInt, fromInt++ -- * Float Conversions+ , toFloat, fromFloat++ -- * Char Conversions+ , fromChar, cons, uncons++ -- * List Conversions+ , toList, fromList++ -- * Formatting+ -- Cosmetic operations such as padding with extra characters or trimming whitespace.+ , toUpper, toLower, pad, padLeft, padRight, trim, trimLeft, trimRight++ -- * Higher-Order Functions+ , map, filter, foldl, foldr, any, all++ -- * Conversions to Haskell Types+ , toBuilder, toTextUtf8, fromTextUtf8+ , fromByteString, toByteString, fromLazyByteString, toLazyByteString+ )+where++import Prelude (Bool, Float, Int, (+), (<), Show, show)+import Char (Char)+import List (List)+import Maybe (Maybe(..))+import qualified Prelude+import qualified Data.ByteString.Builder as HB+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.String as HS+import qualified Data.Text as HT+import qualified Data.Text.Encoding as HTE+import qualified Data.Text.Internal.Search as HTIS+import qualified Data.Maybe as HM+import qualified Text.Read as HTR+import qualified List as List++++{-| A `String` is a chunk of text:++ > "Hello!"+ > "How are you?"+ > "🙈🙉🙊"+ >+ > -- strings with escape characters+ > "this\n\t\"that\""+ > "\u{1F648}\u{1F649}\u{1F64A}" -- "🙈🙉🙊"+ >+ > -- multiline strings+ > """Triple double quotes let you+ > create "multiline strings" which+ > can have unescaped quotes and newlines.+ > """++A `String` can represent any sequence of [unicode characters](https://en.wikipedia.org/wiki/Unicode). You can use+the unicode escapes from `\u{0000}` to `\u{10FFFF}` to represent characters+by their code point. You can also include the unicode characters directly.+Using the escapes can be better if you need one of the many whitespace+characters with different widths.++-}++newtype String =+ String HT.Text+ deriving (Prelude.Eq, Prelude.Ord)+++instance HS.IsString String where+ fromString = fromList++instance Show String where+ show (String s) = show s+++{-| Determine if a string is empty.++ > isEmpty "" == True+ > isEmpty "the world" == False+-}+isEmpty :: String -> Bool+isEmpty (String s) =+ HT.null s+++{-| Get the length of a string.++ > length "innumerable" == 11+ > length "" == 0+-}+length :: String -> Int+length (String s) =+ HT.length s+++{-| Reverse a string.++ > reverse "stressed" == "desserts"+-}+reverse :: String -> String+reverse (String s) =+ String (HT.reverse s)+++{-| Repeat a string *n* times.++ > repeat 3 "ha" == "hahaha"+-}+repeat :: Int -> String -> String+repeat n (String s) =+ String (HT.replicate n s)+++{-| Replace all occurrences of some substring.++ > replace "." "-" "Json.Decode.succeed" == "Json-Decode-succeed"+ > replace "," "/" "a,b,c,d,e" == "a/b/c/d/e"+-}+replace :: String -> String -> String -> String+replace (String before) (String after) (String string) =+ String (HT.replace before after string)++++-- BUILDING AND SPLITTING+++{-| Append two strings. You can also use [the `(++)` operator](Basics#++) to do this.++ > append "butter" "fly" == "butterfly"+-}+append :: String -> String -> String+append (String a) (String b) =+ String (HT.append a b)+++{-| Concatenate many strings into one.++ > concat ["never","the","less"] == "nevertheless"+-}+concat :: List String -> String+concat strings =+ String (HT.concat (List.map (\(String s) -> s) strings))+++{-| Split a string using a given separator.++ > split "," "cat,dog,cow" == ["cat","dog","cow"]+ > split "/" "home/evan/Desktop/" == ["home","evan","Desktop", ""]+-}+split :: String -> String -> List String+split (String sep) (String string) =+ if HT.null sep+ then List.map fromChar (HT.unpack string)+ else List.map String (HT.splitOn sep string)+ -- docs say that HT.splitOn will crash on empty strings+ -- https://hackage.haskell.org/package/text-utf8-1.2.3.0/docs/Data-Text.html#v:splitOn+++{-| Put many strings together with a given separator.++ > join "a" ["H","w","ii","n"] == "Hawaiian"+ > join " " ["cat","dog","cow"] == "cat dog cow"+ > join "/" ["home","evan","Desktop"] == "home/evan/Desktop"+-}+join :: String -> List String -> String+join (String sep) strings =+ String (HT.intercalate sep (List.map (\(String s) -> s) strings))+++{-| Break a string into words, splitting on chunks of whitespace.++ > words "How are \t you? \n Good?" == ["How","are","you?","Good?"]+-}+words :: String -> List String+words (String s) =+ List.map String (HT.words s)+++{-| Break a string into lines, splitting on newlines.++ > lines "How are you?\nGood?" == ["How are you?", "Good?"]+-}+lines :: String -> List String+lines (String s) =+ List.map String (HT.lines s)++++-- SUBSTRINGS+++{-| Take a substring given a start and end index. Negative indexes+ are taken starting from the *end* of the list.++ > slice 7 9 "snakes on a plane!" == "on"+ > slice 0 6 "snakes on a plane!" == "snakes"+ > slice 0 -7 "snakes on a plane!" == "snakes on a"+ > slice -6 -1 "snakes on a plane!" == "plane"+-}+slice :: Int -> Int -> String -> String+slice start end (String str) =+ let+ len = HT.length str++ normalize value =+ clamp 0 len (if value < 0 then len + value else value)++ lo = normalize start+ hi = normalize end+ in+ if lo < hi+ then String (HT.drop lo (HT.take hi str))+ else String HT.empty+++clamp :: Int -> Int -> Int -> Int+clamp lo hi n =+ if n < lo then+ lo+ else if hi < n then+ hi+ else+ n+++{-| Take *n* characters from the left side of a string.++ > left 2 "Mulder" == "Mu"+-}+left :: Int -> String -> String+left n (String s) =+ String (HT.take n s)+++{-| Take *n* characters from the right side of a string.++ > right 2 "Scully" == "ly"+-}+right :: Int -> String -> String+right n (String s) =+ String (HT.takeEnd n s)+++{-| Drop *n* characters from the left side of a string.++ > dropLeft 2 "The Lone Gunmen" == "e Lone Gunmen"+-}+dropLeft :: Int -> String -> String+dropLeft n (String s) =+ String (HT.drop n s)+++{-| Drop *n* characters from the right side of a string.++ > dropRight 2 "Cigarette Smoking Man" == "Cigarette Smoking M"+-}+dropRight :: Int -> String -> String+dropRight n (String s) =+ String (HT.dropEnd n s)++++-- DETECT SUBSTRINGS+++{-| See if the second string contains the first one.++ > contains "the" "theory" == True+ > contains "hat" "theory" == False+ > contains "THE" "theory" == False+-}+contains :: String -> String -> Bool+contains (String sub) (String string) =+ HT.isInfixOf sub string+++{-| See if the second string starts with the first one.++ > startsWith "the" "theory" == True+ > startsWith "ory" "theory" == False+-}+startsWith :: String -> String -> Bool+startsWith (String start) (String string) =+ HT.isPrefixOf start string+++{-| See if the second string ends with the first one.++ > endsWith "the" "theory" == False+ > endsWith "ory" "theory" == True+-}+endsWith :: String -> String -> Bool+endsWith (String end) (String string) =+ HT.isSuffixOf end string+++{-| Get all of the indexes for a substring in another string.++ > indexes "i" "Mississippi" == [1,4,7,10]+ > indexes "ss" "Mississippi" == [2,5]+ > indexes "needle" "haystack" == []+-}+indexes :: String -> String -> List Int+indexes (String sub) (String str) =+ HTIS.indices sub str+++{-| Alias for `indexes`.+-}+indices :: String -> String -> List Int+indices =+ indexes++++-- FORMATTING+++{-| Convert a string to all upper case. Useful for case-insensitive comparisons+ and VIRTUAL YELLING.++ > toUpper "skinner" == "SKINNER"+-}+toUpper :: String -> String+toUpper (String s) =+ String (HT.toUpper s)+++{-| Convert a string to all lower case. Useful for case-insensitive comparisons.++ > toLower "X-FILES" == "x-files"+-}+toLower :: String -> String+toLower (String s) =+ String (HT.toLower s)+++{-| Pad a string on both sides until it has a given length.++ > pad 5 ' ' "1" == " 1 "+ > pad 5 ' ' "11" == " 11 "+ > pad 5 ' ' "121" == " 121 "+-}+pad :: Int -> Char -> String -> String+pad n char (String str) =+ String (HT.center n char str)+++{-| Pad a string on the left until it has a given length.++ > padLeft 5 '.' "1" == "....1"+ > padLeft 5 '.' "11" == "...11"+ > padLeft 5 '.' "121" == "..121"+-}+padLeft :: Int -> Char -> String -> String+padLeft n char (String str) =+ String (HT.justifyRight n char str)+++{-| Pad a string on the right until it has a given length.++ > padRight 5 '.' "1" == "1...."+ > padRight 5 '.' "11" == "11..."+ > padRight 5 '.' "121" == "121.."+-}+padRight :: Int -> Char -> String -> String+padRight n char (String str) =+ String (HT.justifyLeft n char str)+++{-| Get rid of whitespace on both sides of a string.++ > trim " hats \n" == "hats"+-}+trim :: String -> String+trim (String str) =+ String (HT.strip str)+++{-| Get rid of whitespace on the left of a string.++ > trimLeft " hats \n" == "hats \n"+-}+trimLeft :: String -> String+trimLeft (String str) =+ String (HT.stripStart str)+++{-| Get rid of whitespace on the right of a string.++ > trimRight " hats \n" == " hats"+-}+trimRight :: String -> String+trimRight (String str) =+ String (HT.stripEnd str)++++-- INT CONVERSIONS+++{-| Try to convert a string into an int, failing on improperly formatted strings.++ > String.toInt "123" == Just 123+ > String.toInt "-42" == Just -42+ > String.toInt "3.1" == Nothing+ > String.toInt "31a" == Nothing++If you are extracting a number from some raw user input, you will typically+want to use [`Maybe.withDefault`](Maybe#withDefault) to handle bad data:++ > Maybe.withDefault 0 (String.toInt "42") == 42+ > Maybe.withDefault 0 (String.toInt "ab") == 0+-}+toInt :: String -> Maybe Int+toInt str =+ case toList str of+ '+':chars -> safeRead chars+ chars -> safeRead chars+++safeRead :: (Prelude.Read a) => List Char -> Maybe a+safeRead chars =+ case HTR.readMaybe chars of+ HM.Just a -> Just a+ HM.Nothing -> Nothing+++{-| Convert an `Int` to a `String`.++ > String.fromInt 123 == "123"+ > String.fromInt -42 == "-42"++-}+fromInt :: Int -> String+fromInt n =+ fromList (Prelude.show n)++++-- FLOAT CONVERSIONS+++{-| Try to convert a string into a float, failing on improperly formatted strings.++ > String.toFloat "123" == Just 123.0+ > String.toFloat "-42" == Just -42.0+ > String.toFloat "3.1" == Just 3.1+ > String.toFloat "31a" == Nothing++If you are extracting a number from some raw user input, you will typically+want to use [`Maybe.withDefault`](Maybe#withDefault) to handle bad data:++ > Maybe.withDefault 0 (String.toFloat "42.5") == 42.5+ > Maybe.withDefault 0 (String.toFloat "cats") == 0+-}+toFloat :: String -> Maybe Float+toFloat str =+ case toList str of+ '+':chars -> safeRead chars+ '.':chars -> safeRead ('0':'.':chars)+ chars -> safeRead chars+++{-| Convert a `Float` to a `String`.++ > String.fromFloat 123 == "123"+ > String.fromFloat -42 == "-42"+ > String.fromFloat 3.9 == "3.9"+-}+fromFloat :: Float -> String+fromFloat n =+ fromList (Prelude.show n)++++-- LIST CONVERSIONS+++{-| Convert a String to a list of characters.++ > toList "abc" == ['a','b','c']+ > toList "🙈🙉🙊" == ['🙈','🙉','🙊']+-}+toList :: String -> List Char+toList (String str) =+ HT.unpack str+++{-| Convert a list of characters into a String. Can be useful if you+ want to create a string primarily by consing, perhaps for decoding+ something.++ > fromList ['a','b','c'] == "abc"+ > fromList ['🙈','🙉','🙊'] == "🙈🙉🙊"+-}+fromList :: List Char -> String+fromList chars =+ String (HT.pack chars)++++-- CHAR CONVERSIONS+++{-| Create a String from a given character.++ > fromChar 'a' == "a"+-}+fromChar :: Char -> String+fromChar char =+ String (HT.singleton char)+++{-| Add a character to the beginning of a String.++ > cons 'T' "he truth is out there" == "The truth is out there"+-}+cons :: Char -> String -> String+cons char (String str) =+ String (HT.cons char str)+++{-| Split a non-empty String into its head and tail. This lets you+pattern match on strings exactly as you would with lists.++ > uncons "abc" == Just ('a',"bc")+ > uncons "" == Nothing+-}+uncons :: String -> Maybe (Char, String)+uncons (String str) =+ case HT.uncons str of+ HM.Just (c,s) -> Just (c, String s)+ HM.Nothing -> Nothing++++-- HIGHER-ORDER FUNCTIONS+++{-| Transform every character in a String++ > map (\c -> if c == '/' then '.' else c) "a/b/c" == "a.b.c"+-}+map :: (Char -> Char) -> String -> String+map func (String str) =+ String (HT.map func str)+++{-| Keep only the characters that pass the test.++ > filter isDigit "R2-D2" == "22"+-}+filter :: (Char -> Bool) -> String -> String+filter isGood (String str) =+ String (HT.filter isGood str)+++{-| Reduce a String from the left.++ > foldl cons "" "time" == "emit"+-}+foldl :: (Char -> b -> b) -> b -> String -> b+foldl step state (String str) =+ HT.foldl' (Prelude.flip step) state str+++{-| Reduce a String from the right.++ > foldr cons "" "time" == "time"+-}+foldr :: (Char -> b -> b) -> b -> String -> b+foldr step state (String str) =+ HT.foldr step state str+++{-| Determine whether *any* characters pass the test.++ > any isDigit "90210" == True+ > any isDigit "R2-D2" == True+ > any isDigit "heart" == False+-}+any :: (Char -> Bool) -> String -> Bool+any isGood (String str) =+ HT.any isGood str+++{-| Determine whether *all* characters pass the test.++ > all isDigit "90210" == True+ > all isDigit "R2-D2" == False+ > all isDigit "heart" == False+-}+all :: (Char -> Bool) -> String -> Bool+all isGood (String str) =+ HT.all isGood str++++-- CONVERSION TO HASKELL TYPES+++{-| It is pretty common to use `Data.ByteString.Builder` when generating output+so this function is compatible with that system, and fast!+-}+toBuilder :: String -> HB.Builder+toBuilder (String str) =+ HTE.encodeUtf8Builder str+++{-| -}+fromByteString :: B.ByteString -> String+fromByteString bs =+ fromList (B.unpack bs)+++{-| -}+toByteString :: String -> B.ByteString+toByteString s =+ B.pack (toList s)+++{-| -}+fromLazyByteString :: BL.ByteString -> String+fromLazyByteString bs =+ fromByteString (BL.toStrict bs)+++{-| -}+toLazyByteString :: String -> BL.ByteString+toLazyByteString s =+ BL.fromStrict (B.pack (toList s))++++{-| Convert to a `Text` value as defined in the `text-utf8` package.++You can do more conversions from there if needed.+-}+toTextUtf8 :: String -> HT.Text+toTextUtf8 (String str) =+ str+++{-| Convert from a `Text` value as defined in the `text-utf8` package.+-}+fromTextUtf8 :: HT.Text -> String+fromTextUtf8 =+ String+
+ src/Task.hs view
@@ -0,0 +1,113 @@++{-|++Module : Task+Description : Tasks make it easy to describe asynchronous operations that may fail, like HTTP requests or writing to a database.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++Use tasks to get values that can change over time, like getting the current time,+fetching data from an external server, talking to the database etc.++-}++module Task+ ( Task, Task.perform, Task.attempt++ -- * Chains+ , andThen, Task.succeed, Task.fail, Task.sequence++ -- * Maps+ , map, map2, map3, map4, map5, map6++ -- * Errors+ , Task.onError, Task.mapError++ ) where++import qualified Internal.Task as Task+import qualified Internal.Shortcut as Shortcut+import Basics+import Internal.Task (Task)+import Prelude (IO)+++-- MAPS+++{-| Transform a task. Maybe you want to use [`elm/time`][time] to figure+out what time it will be in one hour:++ > timeInOneHour :: Task x Time.Posix+ > timeInOneHour =+ > Task.map addAnHour Time.now+ >+ > addAnHour :: Time.Posix -> Time.Posix+ > addAnHour time =+ > Time.millisToPosix (Time.posixToMillis time + 60 * 60 * 1000)++-}+map :: (a -> b) -> Task x a -> Task x b+map =+ Shortcut.map+++{-| Put the results of two tasks together.++ > newsfeed :: Task x Newsfeed+ > newsfeed =+ > Task.map2 combine getUser getNews++-}+map2 :: (a -> b -> result) -> Task x a -> Task x b -> Task x result+map2 =+ Shortcut.map2+++{-| -}+map3 :: (a -> b -> c -> result) -> Task x a -> Task x b -> Task x c -> Task x result+map3 =+ Shortcut.map3+++{-| -}+map4 :: (a -> b -> c -> d -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x result+map4 =+ Shortcut.map4+++{-| -}+map5 :: (a -> b -> c -> d -> e -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x e -> Task x result+map5 =+ Shortcut.map5+++{-| -}+map6 :: (a -> b -> c -> d -> e -> f -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x e -> Task x f -> Task x result+map6 =+ Shortcut.map6+++{-| Chain together a task and a callback. The first task will run, and if it is+successful, you give the result to the callback resulting in another task. This+task then gets run. We could use this to make a task that resolves an hour from+now:++ > write :: Keys -> Task x ()+ > write keys =+ > Http.get (http keys) "/username"+ > |> Task.andThen Terminal.write++As an alternative, you can use this special syntax:++ > write :: Keys -> Task x ()+ > write keys = do+ > username <- Http.get (http keys) "/username"+ > Terminal.write username++-}+andThen :: (a -> Task x b) -> Task x a -> Task x b+andThen =+ Shortcut.andThen
+ src/Terminal.hs view
@@ -0,0 +1,48 @@++{-|++Module : Terminal+Description : Read and write to the terminal.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++Read and write to the terminal.++-}++module Terminal (write, read) where++import qualified List+import qualified String+import qualified Internal.Task as Task+import qualified Internal.Utils as U+import qualified Data.Text.IO as IO+import Prelude (return, getContents)+import Basics+import Maybe (Maybe (..))+import Result (Result (..))+import String (String)+import Dict (Dict)+import List (List)+import Array (Array)+import Task (Task)+import Set (Set)+import Char (Char)+++{-| -}+write :: String -> Task x ()+write string =+ Task.Task <| do+ IO.putStrLn (String.toTextUtf8 string)+ return (Ok ())+++{-| -}+read :: Task x String+read =+ Task.Task <| do+ contents <- IO.getLine+ return (Ok (String.fromTextUtf8 contents))
+ src/Tuple.hs view
@@ -0,0 +1,123 @@++{-|++Module : Tuples+Description : Work with several values without creating a new data structure.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++There is built-in syntax for tuples, so you can define 2D points like this:++ > origin :: (Float, Float)+ > origin =+ > (0, 0)+ >+ > position :: (Float, Float)+ > position =+ > (3, 4)++This module is a bunch of helpers for working with 2-tuples.++Note 1: For more complex data, it is best to switch to records. So instead+of representing a 3D point as `(3,4,5)` and not having any helper functions,+represent it as `{ x = 3, y = 4, z = 5 }` and use all the built-in record+syntax!++Note 2: If your record contains a bunch of `Bool` and `Maybe` values,+you may want to upgrade to union types. Check out [Joël’s post](https://robots.thoughtbot.com/modeling-with-union-types) for more+info on this.++-}++module Tuple+ ( -- * Create+ pair+ -- * Access+ , first, second+ -- * Map+ , mapFirst, mapSecond, mapBoth+ )+where+++-- CREATE+++{-| Create a 2-tuple.++ > -- pair 3 4 == (3, 4)+ >+ > zip :: List a -> List b -> List (a, b)+ > zip xs ys =+ > List.map2 Tuple.pair xs ys+-}+pair :: a -> b -> (a, b)+pair a b =+ (a, b)++++-- ACCESS+++{-| Extract the first value from a tuple.++ > first (3, 4) == 3+ > first ("john", "doe") == "john"+-}+first :: (a, b) -> a+first (x, _) =+ x+++{-| Extract the second value from a tuple.++ > second (3, 4) == 4+ > second ("john", "doe") == "doe"++-}+second :: (a, b) -> b+second (_, y) =+ y++++-- MAP+++{-| Transform the first value in a tuple.++ > import String+ >+ > mapFirst String.reverse ("stressed", 16) == ("desserts", 16)+ > mapFirst String.length ("stressed", 16) == (8, 16)++-}+mapFirst :: (a -> x) -> (a, b) -> (x, b)+mapFirst func (x, y) =+ (func x, y)+++{-| Transform the second value in a tuple.++ > mapSecond sqrt ("stressed", 16) == ("stressed", 4)+ > mapSecond negate ("stressed", 16) == ("stressed", -16)++-}+mapSecond :: (b -> y) -> (a, b) -> (a, y)+mapSecond func (x, y) =+ (x, func y)+++{-| Transform both parts of a tuple.++ > import String+ >+ > mapBoth String.reverse sqrt ("stressed", 16) == ("desserts", 4)+ > mapBoth String.length negate ("stressed", 16) == (8, -16)+-}+mapBoth :: (a -> x) -> (b -> y) -> (a, b) -> (x, y)+mapBoth funcA funcB (x, y) =+ (funcA x, funcB y)
+ src/Url.hs view
@@ -0,0 +1,117 @@+{-|++Module : Url+Description : Work with URLs.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++-}+++module Url+ ( Url(..)+ , percentEncode+ , percentDecode+ ) where++import qualified Prelude+import qualified Network.HTTP.Types.URI as URI+import qualified Maybe+import qualified List+import qualified String+import qualified Dict+import Cherry.Prelude+++-- URL+++{-| In [the URI spec](https://tools.ietf.org/html/rfc3986), Tim Berners-Lee+says a URL looks like this:++```+ https://example.com:8042/over/there?name=ferret#nose+ \___/ \______________/\_________/ \_________/ \__/+ | | | | |+ scheme authority path query fragment+```++When you are creating a single-page app with [`Browser.fullscreen`][fs], you+use the [`Url.Parser`](Url-Parser) module to turn a `Url` into even nicer data.++If you want to create your own URLs, check out the [`Url.Builder`](Url-Builder)+module as well!++[fs]: /packages/elm/browser/latest/Browser#fullscreen++**Note:** This is a subset of all the full possibilities listed in the URI+spec. Specifically, it does not accept the `userinfo` segment you see in email+addresses like `tom@example.com`.+-}+data Url = Url+ { path :: String+ , query :: Maybe String+ }++++-- PERCENT ENCODING+++{-| **Use [Url.Builder](Url-Builder) instead!** Functions like `absolute`,+`relative`, and `crossOrigin` already do this automatically! `percentEncode`+is only available so that extremely custom cases are possible, if needed.+Percent-encoding is how [the official URI spec][uri] “escapes” special+characters. You can still represent a `?` even though it is reserved for+queries.+This function exists in case you want to do something extra custom. Here are+some examples:+ -- standard ASCII encoding+ percentEncode "hat" == "hat"+ percentEncode "to be" == "to%20be"+ percentEncode "99%" == "99%25"+ -- non-standard, but widely accepted, UTF-8 encoding+ percentEncode "$" == "%24"+ percentEncode "¢" == "%C2%A2"+ percentEncode "€" == "%E2%82%AC"+This is the same behavior as JavaScript's [`encodeURIComponent`][js] function,+and the rules are described in more detail officially [here][s2] and with some+notes about Unicode [here][wiki].+[js]: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/encodeURIComponent+[uri]: https://tools.ietf.org/html/rfc3986+[s2]: https://tools.ietf.org/html/rfc3986#section-2.1+[wiki]: https://en.wikipedia.org/wiki/Percent-encoding+-}+percentEncode :: String -> String+percentEncode =+ String.toByteString >> URI.urlEncode False >> String.fromByteString+++{-| **Use [Url.Parser](Url-Parser) instead!** It will decode query+parameters appropriately already! `percentDecode` is only available so that+extremely custom cases are possible, if needed.+Check out the `percentEncode` function to learn about percent-encoding.+This function does the opposite! Here are the reverse examples:+ -- ASCII+ percentDecode "99%25" == Just "hat"+ percentDecode "to%20be" == Just "to be"+ percentDecode "hat" == Just "99%"+ -- UTF-8+ percentDecode "%24" == Just "$"+ percentDecode "%C2%A2" == Just "¢"+ percentDecode "%E2%82%AC" == Just "€"+Why is it a `Maybe` though? Well, these strings come from strangers on the+internet as a bunch of bits and may have encoding problems. For example:+ percentDecode "%" == Nothing -- not followed by two hex digits+ percentDecode "%XY" == Nothing -- not followed by two HEX digits+ percentDecode "%C2" == Nothing -- half of the "¢" encoding "%C2%A2"+This is the same behavior as JavaScript's [`decodeURIComponent`][js] function.+[js]: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/decodeURIComponent+-}+percentDecode :: String -> Maybe String+percentDecode =+ String.toByteString >> URI.urlDecode False >> String.fromByteString >> Just++
+ src/Url/Builder.hs view
@@ -0,0 +1,235 @@+{-|++Module : Url.Builder+Description : Build URLs.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++In [the URI spec](https://tools.ietf.org/html/rfc3986), Tim Berners-Lee+says a URL looks like this:++```+ https://example.com:8042/over/there?name=ferret#nose+ \___/ \______________/\_________/ \_________/ \__/+ | | | | |+ scheme authority path query fragment+```++This module helps you create these!++-}++module Url.Builder+ ( absolute, relative, crossOrigin, custom, Root(..)+ , QueryParameter, string, int, toQuery+ ) where+++import qualified Url+import qualified Prelude+import qualified Maybe+import qualified String+import qualified List+import qualified Tuple+import qualified Result+import qualified Dict+import qualified Task+import qualified Terminal+import Cherry.Prelude++++-- BUILDERS+++{-| Create an absolute URL:++ absolute [] []+ -- "/"++ absolute [ "packages", "elm", "core" ] []+ -- "/packages/elm/core"++ absolute [ "blog", String.fromInt 42 ] []+ -- "/blog/42"++ absolute [ "products" ] [ string "search" "hat", int "page" 2 ]+ -- "/products?search=hat&page=2"++Notice that the URLs start with a slash!+-}+absolute :: List String -> List QueryParameter -> String+absolute pathSegments parameters =+ "/" ++ String.join "/" pathSegments ++ toQuery parameters+++{-| Create a relative URL:++ relative [] []+ -- ""++ relative [ "elm", "core" ] []+ -- "elm/core"++ relative [ "blog", String.fromInt 42 ] []+ -- "blog/42"++ relative [ "products" ] [ string "search" "hat", int "page" 2 ]+ -- "products?search=hat&page=2"++Notice that the URLs **do not** start with a slash!+-}+relative :: List String -> List QueryParameter -> String+relative pathSegments parameters =+ String.join "/" pathSegments ++ toQuery parameters+++{-| Create a cross-origin URL.++ crossOrigin "https://example.com" [ "products" ] []+ -- "https://example.com/products"++ crossOrigin "https://example.com" [] []+ -- "https://example.com/"++ crossOrigin+ "https://example.com:8042"+ [ "over", "there" ]+ [ string "name" "ferret" ]+ -- "https://example.com:8042/over/there?name=ferret"++**Note:** Cross-origin requests are slightly restricted for security.+For example, the [same-origin policy][sop] applies when sending HTTP requests,+so the appropriate `Access-Control-Allow-Origin` header must be enabled on the+*server* to get things working. Read more about the security rules [here][cors].++[sop]: https://developer.mozilla.org/en-US/docs/Web/Security/Same-origin_policy+[cors]: https://developer.mozilla.org/en-US/docs/Web/HTTP/Access_control_CORS+-}+crossOrigin :: String -> List String -> List QueryParameter -> String+crossOrigin prePath pathSegments parameters =+ prePath ++ "/" ++ String.join "/" pathSegments ++ toQuery parameters++++-- CUSTOM BUILDER+++{-| Specify whether a [`custom`](#custom) URL is absolute, relative, or+cross-origin.+-}+data Root = Absolute | Relative | CrossOrigin String+++{-| Create custom URLs that may have a hash on the end:++ custom Absolute+ [ "packages", "elm", "core", "latest", "String" ]+ []+ (Just "length")+ -- "/packages/elm/core/latest/String#length"++ custom Relative [ "there" ] [ string "name" "ferret" ] Nothing+ -- "there?name=ferret"++ custom+ (CrossOrigin "https://example.com:8042")+ [ "over", "there" ]+ [ string "name" "ferret" ]+ (Just "nose")+ -- "https://example.com:8042/over/there?name=ferret#nose"+-}+custom :: Root -> List String -> List QueryParameter -> Maybe String -> String+custom root pathSegments parameters maybeFragment =+ let+ fragmentless =+ rootToPrePath root ++ String.join "/" pathSegments ++ toQuery parameters+ in+ case maybeFragment of+ Nothing ->+ fragmentless++ Just fragment ->+ fragmentless ++ "#" ++ fragment+++rootToPrePath :: Root -> String+rootToPrePath root =+ case root of+ Absolute ->+ "/"++ Relative ->+ ""++ CrossOrigin prePath ->+ prePath ++ "/"++++-- QUERY PARAMETERS+++{-| Represents query parameter. Builder functions like `absolute` percent-encode+all the query parameters they get, so you do not need to worry about it!+-}+data QueryParameter =+ QueryParameter String String+++{-| Create a percent-encoded query parameter.++ absolute ["products"] [ string "search" "hat" ]+ -- "/products?search=hat"++ absolute ["products"] [ string "search" "coffee table" ]+ -- "/products?search=coffee%20table"+-}+string :: String -> String -> QueryParameter+string key value =+ QueryParameter (Url.percentEncode key) (Url.percentEncode value)+++{-| Create a percent-encoded query parameter.++ absolute ["products"] [ string "search" "hat", int "page" 2 ]+ -- "/products?search=hat&page=2"++Writing `int key n` is the same as writing `string key (String.fromInt n)`.+So this is just a convenience function, making your code a bit shorter!+-}+int :: String -> Int -> QueryParameter+int key value =+ QueryParameter (Url.percentEncode key) (String.fromInt value)+++{-| Convert a list of query parameters to a percent-encoded query. This+function is used by `absolute`, `relative`, etc.++ toQuery [ string "search" "hat" ]+ -- "?search=hat"++ toQuery [ string "search" "coffee table" ]+ -- "?search=coffee%20table"++ toQuery [ string "search" "hat", int "page" 2 ]+ -- "?search=hat&page=2"++ toQuery []+ -- ""+-}+toQuery :: List QueryParameter -> String+toQuery parameters =+ case parameters of+ [] ->+ ""++ _ ->+ "?" ++ String.join "&" (List.map toQueryPair parameters)+++toQueryPair :: QueryParameter -> String+toQueryPair (QueryParameter key value) =+ key ++ "=" ++ value
+ src/Url/Parser.hs view
@@ -0,0 +1,429 @@+{-|++Module : Url.Parser+Description : Parse URLs.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX+++In [the URI spec](https://tools.ietf.org/html/rfc3986), Tim Berners-Lee+says a URL looks like this:+```+ https://example.com:8042/over/there?name=ferret#nose+ \___/ \______________/\_________/ \_________/ \__/+ | | | | |+ scheme authority path query fragment+```+This module is primarily for parsing the `path` part.++-}++module Url.Parser+ ( Parser, string, int, s+ , (</>), map, oneOf, top, custom+ , (<?>), query+ , parse+ ) where+++import qualified Prelude+import qualified Maybe+import qualified Dict+import qualified List+import qualified String+import qualified Url+import qualified Url.Parser.Query as Query+import qualified Url.Parser.Internal as Q+import Prelude (Ordering(..))+import Cherry.Prelude+import Url (Url)++++-- INFIX TABLE+++infixr 7 </>+(</>) = slash++infixl 8 <?>+(<?>) = questionMark++++-- PARSERS+++{-| Turn URLs like `/blog/42/cat-herding-techniques` into nice Elm data.+-}+newtype Parser a b =+ Parser (State a -> List (State b))+++data State value = State+ { visited :: List String+ , unvisited :: List String+ , params :: Dict String (List String)+ , value :: value+ }++++-- PARSE SEGMENTS+++{-| Parse a segment of the path as a `String`.+ -- /alice/ ==> Just "alice"+ -- /bob ==> Just "bob"+ -- /42/ ==> Just "42"+ -- / ==> Nothing+-}+string :: Parser (String -> a) a+string =+ custom "STRING" Just+++{-| Parse a segment of the path as an `Int`.+ -- /alice/ ==> Nothing+ -- /bob ==> Nothing+ -- /42/ ==> Just 42+ -- / ==> Nothing+-}+int :: Parser (Int -> a) a+int =+ custom "NUMBER" String.toInt+++{-| Parse a segment of the path if it matches a given string. It is almost+always used with [`</>`](#</>) or [`oneOf`](#oneOf). For example:+ blog :: Parser (Int -> a) a+ blog =+ s "blog" </> int+ -- /blog/42 ==> Just 42+ -- /tree/42 ==> Nothing+The path segment must be an exact match!+-}+s :: String -> Parser a a+s str =+ Parser <| \state ->+ case unvisited state of+ [] ->+ []++ next : rest ->+ if next == str then+ [ State (next : visited state) rest (params state) (value state) ]++ else+ []+++{-| Create a custom path segment parser. Here is how it is used to define the+`int` parser:+ int :: Parser (Int -> a) a+ int =+ custom "NUMBER" String.toInt+You can use it to define something like “only CSS files” like this:+ css :: Parser (String -> a) a+ css =+ custom "CSS_FILE" <| \segment ->+ if String.endsWith ".css" segment then+ Just segment+ else+ Nothing+-}+custom :: String -> (String -> Maybe a) -> Parser (a -> b) b+custom tipe stringToSomething =+ Parser <| \state ->+ case unvisited state of+ [] ->+ []++ next : rest ->+ case stringToSomething next of+ Just nextValue ->+ [ State (next : visited state) rest (params state) (value state <| nextValue) ]++ Nothing ->+ []++++-- COMBINING PARSERS+++{-| Parse a path with multiple segments.+ blog :: Parser (Int -> a) a+ blog =+ s "blog" </> int+ -- /blog/35/ ==> Just 35+ -- /blog/42 ==> Just 42+ -- /blog/ ==> Nothing+ -- /42/ ==> Nothing+ search :: Parser (String -> a) a+ search =+ s "search" </> string+ -- /search/wolf/ ==> Just "wolf"+ -- /search/frog ==> Just "frog"+ -- /search/ ==> Nothing+ -- /wolf/ ==> Nothing+-}+slash :: Parser a b -> Parser b c -> Parser a c+slash (Parser parseBefore) (Parser parseAfter) =+ Parser <| \state ->+ List.concatMap parseAfter (parseBefore state)+++{-| Transform a path parser.++ type alias Comment = { user :: String, id :: Int }++ userAndId :: Parser (String -> Int -> a) a+ userAndId =+ s "user" </> string </> s "comment" </> int++ comment :: Parser (Comment -> a) a+ comment =+ map Comment userAndId+ -- /user/bob/comment/42 ==> Just { user = "bob", id = 42 }+ -- /user/tom/comment/35 ==> Just { user = "tom", id = 35 }+ -- /user/sam/ ==> Nothing+-}+map :: a -> Parser a b -> Parser (b -> c) c+map subValue (Parser parseArg) =+ Parser <| \state ->+ List.map (mapState (value state)) <| parseArg <|+ State (visited state) (unvisited state) (params state) subValue+++mapState :: (a -> b) -> State a -> State b+mapState func state =+ State (visited state) (unvisited state) (params state) (func (value state))+++{-| Try a bunch of different path parsers.+ type Route+ = Topic String+ | Blog Int+ | User String+ | Comment String Int+ route :: Parser (Route -> a) a+ route =+ oneOf+ [ map Topic (s "topic" </> string)+ , map Blog (s "blog" </> int)+ , map User (s "user" </> string)+ , map Comment (s "user" </> string </> s "comment" </> int)+ ]+ -- /topic/wolf ==> Just (Topic "wolf")+ -- /topic/ ==> Nothing+ -- /blog/42 ==> Just (Blog 42)+ -- /blog/wolf ==> Nothing+ -- /user/sam/ ==> Just (User "sam")+ -- /user/bob/comment/42 ==> Just (Comment "bob" 42)+ -- /user/tom/comment/35 ==> Just (Comment "tom" 35)+ -- /user/ ==> Nothing+If there are multiple parsers that could succeed, the first one wins.+-}+oneOf :: List (Parser a b) -> Parser a b+oneOf parsers =+ Parser <| \state ->+ List.concatMap (\(Parser parser) -> parser state) parsers+++{-| A parser that does not consume any path segments.+ type Route = Overview | Post Int+ blog :: Parser (BlogRoute -> a) a+ blog =+ s "blog" </>+ oneOf+ [ map Overview top+ , map Post (s "post" </> int)+ ]+ -- /blog/ ==> Just Overview+ -- /blog/post/42 ==> Just (Post 42)+-}+top :: Parser a a+top =+ Parser <| \state -> [state]++++-- QUERY+++{-| The [`Url.Parser.Query`](Url-Parser-Query) module defines its own+[`Parser`](Url-Parser-Query#Parser) type. This function helps you use those+with normal parsers. For example, maybe you want to add a search feature to+your blog website:+ import Url.Parser.Query as Query+ type Route+ = Overview (Maybe String)+ | Post Int+ blog :: Parser (Route -> a) a+ blog =+ oneOf+ [ map Overview (s "blog" <?> Query.string "q")+ , map Post (s "blog" </> int)+ ]+ -- /blog/ ==> Just (Overview Nothing)+ -- /blog/?q=wolf ==> Just (Overview (Just "wolf"))+ -- /blog/wolf ==> Nothing+ -- /blog/42 ==> Just (Post 42)+ -- /blog/42?q=wolf ==> Just (Post 42)+ -- /blog/42/wolf ==> Nothing+-}+questionMark :: Parser a (query -> b) -> Query.Parser query -> Parser a b+questionMark parser queryParser =+ slash parser (query queryParser)+++{-| The [`Url.Parser.Query`](Url-Parser-Query) module defines its own+[`Parser`](Url-Parser-Query#Parser) type. This function is a helper to convert+those into normal parsers.+ import Url.Parser.Query as Query+ -- the following expressions are both the same!+ --+ -- s "blog" <?> Query.string "search"+ -- s "blog" </> query (Query.string "search")+This may be handy if you need query parameters but are not parsing any path+segments.+-}+query :: Query.Parser query -> Parser (query -> a) a+query (Q.Parser queryParser) =+ Parser <| \state ->+ [ State (visited state) (unvisited state) (params state) (value state <| queryParser (params state))+ ]++++-- PARSE+++{-| Actually run a parser! You provide some [`Url`](Url#Url) that+represent a valid URL. From there `parse` runs your parser on the path, query+parameters, and fragment.+ import Url+ import Url.Parser exposing (Parser, parse, int, map, oneOf, s, top)+ type Route = Home | Blog Int | NotFound+ route :: Parser (Route -> a) a+ route =+ oneOf+ [ map Home top+ , map Blog (s "blog" </> int)+ ]+ toRoute :: String -> Route+ toRoute string =+ case Url.fromString string of+ Nothing ->+ NotFound+ Just url ->+ Maybe.withDefault NotFound (parse route url)+ -- toRoute "/blog/42" == NotFound+ -- toRoute "https://example.com/" == Home+ -- toRoute "https://example.com/blog" == NotFound+ -- toRoute "https://example.com/blog/42" == Blog 42+ -- toRoute "https://example.com/blog/42/" == Blog 42+ -- toRoute "https://example.com/blog/42#wolf" == Blog 42+ -- toRoute "https://example.com/blog/42?q=wolf" == Blog 42+ -- toRoute "https://example.com/settings" == NotFound+Functions like `toRoute` are useful when creating single-page apps with+[`Browser.fullscreen`][fs]. I use them in `init` and `onNavigation` to handle+the initial URL and any changes.+[fs]: /packages/elm/browser/latest/Browser#fullscreen+-}+parse :: Parser (a -> a) a -> Url -> Maybe a+parse (Parser parser) url =+ getFirstMatch <| parser <|+ State [] (preparePath (Url.path url)) (prepareQuery (Url.query url)) identity+++getFirstMatch :: List (State a) -> Maybe a+getFirstMatch states =+ case states of+ [] ->+ Nothing++ state : rest ->+ case unvisited state of+ [] ->+ Just (value state)++ [""] ->+ Just (value state)++ _ ->+ getFirstMatch rest++++-- PREPARE PATH+++preparePath :: String -> List String+preparePath path =+ case String.split "/" path of+ "" : segments ->+ removeFinalEmpty segments++ segments ->+ removeFinalEmpty segments+++removeFinalEmpty :: List String -> List String+removeFinalEmpty segments =+ case segments of+ [] ->+ []++ "" : [] ->+ []++ segment : rest ->+ segment : removeFinalEmpty rest++++-- PREPARE QUERY+++prepareQuery :: Maybe String -> Dict String (List String)+prepareQuery maybeQuery =+ case maybeQuery of+ Nothing ->+ Dict.empty++ Just qry ->+ List.foldr addParam Dict.empty (String.split "&" qry)+++addParam :: String -> Dict String (List String) -> Dict String (List String)+addParam segment dict =+ case String.split "=" segment of+ [rawKey, rawValue] ->+ case Url.percentDecode rawKey of+ Nothing ->+ dict++ Just key ->+ case Url.percentDecode rawValue of+ Nothing ->+ dict++ Just value ->+ Dict.update key (addToParametersHelp value) dict++ _ ->+ dict+++addToParametersHelp :: a -> Maybe (List a) -> Maybe (List a)+addToParametersHelp value maybeList =+ case maybeList of+ Nothing ->+ Just [value]++ Just list ->+ Just (value : list)
+ src/Url/Parser/Internal.hs view
@@ -0,0 +1,13 @@+module Url.Parser.Internal+ ( QueryParser(..)+ ) where+++import Cherry.Prelude+import qualified Prelude+import qualified Dict+import qualified List+++newtype QueryParser a =+ Parser (Dict.Dict String (List String) -> a)
+ src/Url/Parser/Query.hs view
@@ -0,0 +1,283 @@+{-|++Module : Url.Parser.Query+Description : Build URL queries.+License : BSD 3+Maintainer : terezasokol@gmail.com+Stability : experimental+Portability : POSIX++In [the URI spec](https://tools.ietf.org/html/rfc3986), Tim Berners-Lee+says a URL looks like this:++```+ https://example.com:8042/over/there?name=ferret#nose+ \___/ \______________/\_________/ \_________/ \__/+ | | | | |+ scheme authority path query fragment+```++This module is for parsing the `query` part.++In this library, a valid query looks like `?search=hats&page=2` where each+query parameter has the format `key=value` and is separated from the next+parameter by the `&` character.++-}++module Url.Parser.Query+ ( Parser, string, int, enum, custom+ , map, map2, map3, map4, map5, map6, map7, map8+ ) where+++import qualified Prelude+import qualified Dict+import qualified Maybe+import qualified List+import qualified String+import qualified Url.Parser.Internal as Q+import Cherry.Prelude+import Url (Url)++++-- PARSERS+++{-| Parse a query like `?search=hat&page=2` into nice Elm data.+-}+type Parser a =+ Q.QueryParser a++++-- PRIMITIVES+++{-| Handle `String` parameters.++ search :: Parser (Maybe String)+ search =+ string "search"++ -- ?search=cats == Just "cats"+ -- ?search=42 == Just "42"+ -- ?branch=left == Nothing+ -- ?search=cats&search=dogs == Nothing++Check out [`custom`](#custom) if you need to handle multiple `search`+parameters for some reason.+-}+string :: String -> Parser (Maybe String)+string key =+ custom key <| \stringList ->+ case stringList of+ [str] ->+ Just str++ _ ->+ Nothing+++{-| Handle `Int` parameters. Maybe you want to show paginated search results:++ page :: Parser (Maybe Int)+ page =+ int "page"++ -- ?page=2 == Just 2+ -- ?page=17 == Just 17+ -- ?page=two == Nothing+ -- ?sort=date == Nothing+ -- ?page=2&page=3 == Nothing++Check out [`custom`](#custom) if you need to handle multiple `page` parameters+or something like that.+-}+int :: String -> Parser (Maybe Int)+int key =+ custom key <| \stringList ->+ case stringList of+ [str] ->+ String.toInt str++ _ ->+ Nothing+++{-| Handle enumerated parameters. Maybe you want a true-or-false parameter:++ import Dict++ debug :: Parser (Maybe Bool)+ debug =+ enum "debug" (Dict.fromList [ ("true", True), ("false", False) ])++ -- ?debug=true == Just True+ -- ?debug=false == Just False+ -- ?debug=1 == Nothing+ -- ?debug=0 == Nothing+ -- ?true=true == Nothing+ -- ?debug=true&debug=true == Nothing++You could add `0` and `1` to the dictionary if you want to handle those as+well. You can also use [`map`](#map) to say `map (Result.withDefault False) debug`+to get a parser of type `Parser Bool` that swallows any errors and defaults to+`False`.++**Note:** Parameters like `?debug` with no `=` are not supported by this library.+-}+enum :: String -> Dict.Dict String a -> Parser (Maybe a)+enum key dict =+ custom key <| \stringList ->+ case stringList of+ [str] ->+ Dict.get str dict++ _ ->+ Nothing++++-- CUSTOM PARSERS+++{-| Create a custom query parser. The [`string`](#string), [`int`](#int), and+[`enum`](#enum) parsers are defined using this function. It can help you handle+anything though!++Say you are unlucky enough to need to handle `?post=2&post=7` to show a couple+posts on screen at once. You could say:++ posts :: Parser (Maybe (List Int))+ posts =+ custom "post" (List.maybeMap String.toInt)++ -- ?post=2 == [2]+ -- ?post=2&post=7 == [2, 7]+ -- ?post=2&post=x == [2]+ -- ?hats=2 == []+-}+custom :: String -> (List String -> a) -> Parser a+custom key func =+ Q.Parser <| \dict ->+ func (Maybe.withDefault [] (Dict.get key dict))++++-- MAPPING+++{-| Transform a parser in some way. Maybe you want your `page` query parser to+default to `1` if there is any problem?++ page :: Parser Int+ page =+ map (Result.withDefault 1) (int "page")++-}+map :: (a -> b) -> Parser a -> Parser b+map func (Q.Parser a) =+ Q.Parser <| \dict -> func (a dict)+++{-| Combine two parsers. A query like `?search=hats&page=2` could be parsed+with something like this:++ type alias Query =+ { search :: Maybe String+ , page :: Maybe Int+ }++ query :: Parser Query+ query =+ map2 Query (string "search") (int "page")++-}+map2 :: (a -> b -> result) -> Parser a -> Parser b -> Parser result+map2 func (Q.Parser a) (Q.Parser b) =+ Q.Parser <| \dict ->+ func (a dict) (b dict)+++{-| Combine three parsers. A query like `?search=hats&page=2&sort=ascending`+could be parsed with something like this:++ import Dict++ type alias Query =+ { search :: Maybe String+ , page :: Maybe Int+ , sort :: Maybe Order+ }++ type Order = Ascending | Descending++ query :: Parser Query+ query =+ map3 Query (string "search") (int "page") (enum "sort" order)++ order :: Dict.Dict String Order+ order =+ Dict.fromList+ [ ( "ascending", Ascending )+ , ( "descending", Descending )+ ]+-}+map3 :: (a -> b -> c -> result) -> Parser a -> Parser b -> Parser c -> Parser result+map3 func (Q.Parser a) (Q.Parser b) (Q.Parser c) =+ Q.Parser <| \dict ->+ func (a dict) (b dict) (c dict)+++{-|-}+map4 :: (a -> b -> c -> d -> result) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser result+map4 func (Q.Parser a) (Q.Parser b) (Q.Parser c) (Q.Parser d) =+ Q.Parser <| \dict ->+ func (a dict) (b dict) (c dict) (d dict)++++{-|-}+map5 :: (a -> b -> c -> d -> e -> result) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser result+map5 func (Q.Parser a) (Q.Parser b) (Q.Parser c) (Q.Parser d) (Q.Parser e) =+ Q.Parser <| \dict ->+ func (a dict) (b dict) (c dict) (d dict) (e dict)+++{-|-}+map6 :: (a -> b -> c -> d -> e -> f -> result) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser result+map6 func (Q.Parser a) (Q.Parser b) (Q.Parser c) (Q.Parser d) (Q.Parser e) (Q.Parser f) =+ Q.Parser <| \dict ->+ func (a dict) (b dict) (c dict) (d dict) (e dict) (f dict)++++{-|-}+map7 :: (a -> b -> c -> d -> e -> f -> g -> result) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g -> Parser result+map7 func (Q.Parser a) (Q.Parser b) (Q.Parser c) (Q.Parser d) (Q.Parser e) (Q.Parser f) (Q.Parser g) =+ Q.Parser <| \dict ->+ func (a dict) (b dict) (c dict) (d dict) (e dict) (f dict) (g dict)++++{-| If you need higher than eight, you can define a function like this:++ apply :: Parser a -> Parser (a -> b) -> Parser b+ apply argParser funcParser =+ map2 (<|) funcParser argParser++And then you can chain it to do as many of these as you would like:++ map func (string "search")+ |> apply (int "page")+ |> apply (int "per-page")++-}+map8 :: (a -> b -> c -> d -> e -> f -> g -> h -> result) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g -> Parser h -> Parser result+map8 func (Q.Parser a) (Q.Parser b) (Q.Parser c) (Q.Parser d) (Q.Parser e) (Q.Parser f) (Q.Parser g) (Q.Parser h) =+ Q.Parser <| \dict ->+ func (a dict) (b dict) (c dict) (d dict) (e dict) (f dict) (g dict) (h dict)++
+ tests/Main.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Test.Hspec+import qualified Data.Map.Strict as Map+import qualified Json.Decode as Decode+import Cherry.Prelude (Result(..))+++main :: IO ()+main = hspec $ do+ describe "Cherry.Json.Decode" $ do+ it "can decode a string" $+ let bytestring = "\"string\""+ decoder = Decode.string+ in+ Decode.fromString decoder bytestring `shouldBe` Ok "string"++ it "can decode an int" $+ let bytestring = "12"+ decoder = Decode.int+ in+ Decode.fromString decoder bytestring `shouldBe` Ok 12++ it "can decode a negative int" $+ let bytestring = "-4"+ decoder = Decode.int+ in+ Decode.fromString decoder bytestring `shouldBe` Ok (negate 4)++ it "can decode a large int" $+ let bytestring = "1801439850948"+ decoder = Decode.int+ in+ Decode.fromString decoder bytestring `shouldBe` Ok 1801439850948++ it "can decode a negative large int" $+ let bytestring = "-1801439850948"+ decoder = Decode.int+ in+ Decode.fromString decoder bytestring `shouldBe` Ok (negate 1801439850948)++ it "can decode an exponent" $+ let bytestring = "2e8"+ decoder = Decode.float+ in+ Decode.fromString decoder bytestring `shouldBe` Ok 2.0e8++ it "can decode a whole float" $+ let bytestring = "0.4"+ decoder = Decode.float+ in+ Decode.fromString decoder bytestring `shouldBe` Ok 0.4++ it "can decode a negative whole float" $+ let bytestring = "-0.4"+ decoder = Decode.float+ in+ Decode.fromString decoder bytestring `shouldBe` Ok (negate 0.4)++ it "can decode a float" $+ let bytestring = "4.2"+ decoder = Decode.float+ in+ Decode.fromString decoder bytestring `shouldBe` Ok 4.2++ it "can decode a negative float" $+ let bytestring = "-4.2"+ decoder = Decode.float+ in+ Decode.fromString decoder bytestring `shouldBe` Ok (negate 4.2)++ it "can decode a large float" $+ let bytestring = "0.1274960773527468635486"+ decoder = Decode.float+ in+ Decode.fromString decoder bytestring `shouldBe` Ok 0.12749607735274687++ it "can decode true" $+ let bytestring = "true"+ decoder = Decode.bool+ in+ Decode.fromString decoder bytestring `shouldBe` Ok True++ it "can decode false" $+ let bytestring = "false"+ decoder = Decode.bool+ in+ Decode.fromString decoder bytestring `shouldBe` Ok False++ it "can decode null" $+ let bytestring = "null"+ decoder = Decode.null 0+ in+ Decode.fromString decoder bytestring `shouldBe` Ok (0 :: Int)++ it "can decode a tuple" $+ let bytestring = "[1, false]"+ decoder = Decode.pair Decode.int Decode.bool+ in+ Decode.fromString decoder bytestring `shouldBe` Ok (1, False)++ it "can decode an object" $+ let bytestring = "{ \"property\": 13 }"+ decoder = Decode.field "property" Decode.int+ in+ Decode.fromString decoder bytestring `shouldBe` Ok 13++ it "can decode an object with several properties" $+ let bytestring = "{ \"name\": \"Tereza\", \"age\": 24 }"+ decoder =+ Decode.map2 (,)+ (Decode.field "name" Decode.string)+ (Decode.field "age" Decode.int)+ in+ Decode.fromString decoder bytestring `shouldBe` Ok ( "Tereza", 24 )+++ it "can decode a dict" $+ let bytestring = "{ \"a\": \"1\", \"b\": \"2\" }"+ decoder = Decode.dict Decode.string+ in+ Decode.fromString decoder bytestring `shouldBe` Ok (Map.fromList [ ( "a", "1" ), ( "b", "2" ) ])