diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for cherry-core + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# cherry-core +🍒 A library with basic functions and logging helpers. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cherry-core-alpha.cabal b/cherry-core-alpha.cabal new file mode 100644 --- /dev/null +++ b/cherry-core-alpha.cabal @@ -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.* diff --git a/src/Array.hs b/src/Array.hs new file mode 100644 --- /dev/null +++ b/src/Array.hs @@ -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 diff --git a/src/Basics.hs b/src/Basics.hs new file mode 100644 --- /dev/null +++ b/src/Basics.hs @@ -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 diff --git a/src/Bitwise.hs b/src/Bitwise.hs new file mode 100644 --- /dev/null +++ b/src/Bitwise.hs @@ -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 diff --git a/src/Char.hs b/src/Char.hs new file mode 100644 --- /dev/null +++ b/src/Char.hs @@ -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' diff --git a/src/Cherry/Prelude.hs b/src/Cherry/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Cherry/Prelude.hs @@ -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) diff --git a/src/Debug.hs b/src/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Debug.hs @@ -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) diff --git a/src/Dict.hs b/src/Dict.hs new file mode 100644 --- /dev/null +++ b/src/Dict.hs @@ -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 diff --git a/src/Environment.hs b/src/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Environment.hs @@ -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) + diff --git a/src/File.hs b/src/File.hs new file mode 100644 --- /dev/null +++ b/src/File.hs @@ -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)) diff --git a/src/Http.hs b/src/Http.hs new file mode 100644 --- /dev/null +++ b/src/Http.hs @@ -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) diff --git a/src/Internal/Shortcut.hs b/src/Internal/Shortcut.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Shortcut.hs @@ -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 + + diff --git a/src/Internal/Task.hs b/src/Internal/Task.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Task.hs @@ -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 + + + diff --git a/src/Internal/Utils.hs b/src/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Utils.hs @@ -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 diff --git a/src/Interop.hs b/src/Interop.hs new file mode 100644 --- /dev/null +++ b/src/Interop.hs @@ -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 diff --git a/src/Json/Decode.hs b/src/Json/Decode.hs new file mode 100644 --- /dev/null +++ b/src/Json/Decode.hs @@ -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-}) + diff --git a/src/Json/Encode.hs b/src/Json/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Json/Encode.hs @@ -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 "," diff --git a/src/Json/String.hs b/src/Json/String.hs new file mode 100644 --- /dev/null +++ b/src/Json/String.hs @@ -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, () #) diff --git a/src/List.hs b/src/List.hs new file mode 100644 --- /dev/null +++ b/src/List.hs @@ -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 diff --git a/src/Maybe.hs b/src/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Maybe.hs @@ -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 diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -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# + diff --git a/src/Parser/Reporting.hs b/src/Parser/Reporting.hs new file mode 100644 --- /dev/null +++ b/src/Parser/Reporting.hs @@ -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 + diff --git a/src/Result.hs b/src/Result.hs new file mode 100644 --- /dev/null +++ b/src/Result.hs @@ -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 diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 --- /dev/null +++ b/src/Server.hs @@ -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 diff --git a/src/Set.hs b/src/Set.hs new file mode 100644 --- /dev/null +++ b/src/Set.hs @@ -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 diff --git a/src/String.hs b/src/String.hs new file mode 100644 --- /dev/null +++ b/src/String.hs @@ -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 + diff --git a/src/Task.hs b/src/Task.hs new file mode 100644 --- /dev/null +++ b/src/Task.hs @@ -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 diff --git a/src/Terminal.hs b/src/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Terminal.hs @@ -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)) diff --git a/src/Tuple.hs b/src/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Tuple.hs @@ -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) diff --git a/src/Url.hs b/src/Url.hs new file mode 100644 --- /dev/null +++ b/src/Url.hs @@ -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 + + diff --git a/src/Url/Builder.hs b/src/Url/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Url/Builder.hs @@ -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 diff --git a/src/Url/Parser.hs b/src/Url/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Url/Parser.hs @@ -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) diff --git a/src/Url/Parser/Internal.hs b/src/Url/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Url/Parser/Internal.hs @@ -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) diff --git a/src/Url/Parser/Query.hs b/src/Url/Parser/Query.hs new file mode 100644 --- /dev/null +++ b/src/Url/Parser/Query.hs @@ -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) + + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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" ) ])