0 | module Prelude.Types
   1 |
   2 | import Builtin
   3 | import Prelude.Basics
   4 | import Prelude.EqOrd
   5 | import Prelude.Interfaces
   6 | import Prelude.Num
   7 | import Prelude.Uninhabited
   8 |
   9 | %default total
  10 |
  11 | -----------
  12 | -- NATS ---
  13 | -----------
  14 |
  15 | ||| Natural numbers: unbounded, unsigned integers which can be pattern matched.
  16 | public export
  17 | data Nat =
  18 |   ||| Zero.
  19 |     Z
  20 |   | ||| Successor.
  21 |   S Nat
  22 |
  23 | %name Nat k, j, i
  24 |
  25 | -- This is used in the compiler as an efficient substitute for integerToNat.
  26 | prim__integerToNat : Integer -> Nat
  27 | prim__integerToNat i
  28 |   = if intToBool (prim__lte_Integer 0 i)
  29 |       then believe_me i
  30 |       else Z
  31 |
  32 | public export
  33 | integerToNat : Integer -> Nat
  34 | integerToNat 0 = Z -- Force evaluation and hence caching of x at compile time
  35 | integerToNat x
  36 |   = if intToBool (prim__lte_Integer x 0)
  37 |        then Z
  38 |        else S (assert_total (integerToNat (prim__sub_Integer x 1)))
  39 |
  40 | -- %builtin IntegerToNatural Prelude.Types.integerToNat
  41 |
  42 | -- Define separately so we can spot the name when optimising Nats
  43 | ||| Add two natural numbers.
  44 | ||| @ x the number to case-split on
  45 | ||| @ y the other number
  46 | public export
  47 | plus : (x : Nat) -> (y : Nat) -> Nat
  48 | plus Z y = y
  49 | plus (S k) y = S (plus k y)
  50 |
  51 | ||| Subtract natural numbers.
  52 | ||| If the second number is larger than the first, return 0.
  53 | public export
  54 | minus : (left : Nat) -> Nat -> Nat
  55 | minus Z        right     = Z
  56 | minus left     Z         = left
  57 | minus (S left) (S right) = minus left right
  58 |
  59 | ||| Multiply natural numbers.
  60 | public export
  61 | mult : (x : Nat) -> Nat -> Nat
  62 | mult Z y = Z
  63 | mult (S k) y = plus y (mult k y)
  64 |
  65 | public export
  66 | Num Nat where
  67 |   (+) = plus
  68 |   (*) = mult
  69 |
  70 |   fromInteger x = integerToNat x
  71 |
  72 | -- used for nat hack
  73 | public export
  74 | equalNat : (m, n : Nat) -> Bool
  75 | equalNat Z Z = True
  76 | equalNat (S j) (S k) = equalNat j k
  77 | equalNat _ _ = False
  78 |
  79 | public export
  80 | Eq Nat where
  81 |   (==) = equalNat
  82 |
  83 | -- used for nat hack
  84 | public export
  85 | compareNat : (m, n : Nat) -> Ordering
  86 | compareNat Z Z = EQ
  87 | compareNat Z (S k) = LT
  88 | compareNat (S k) Z = GT
  89 | compareNat (S j) (S k) = compareNat j k
  90 |
  91 | public export
  92 | Ord Nat where
  93 |   compare = compareNat
  94 |
  95 | public export
  96 | natToInteger : Nat -> Integer
  97 | natToInteger Z = 0
  98 | natToInteger (S k) = 1 + natToInteger k
  99 |                          -- integer (+) may be non-linear in second
 100 |                          -- argument
 101 |
 102 | -- %builtin NaturalToInteger Prelude.Types.natToInteger
 103 |
 104 | ||| Counts the number of elements that satisfy a predicate.
 105 | public export
 106 | count : Foldable t => (predicate : a -> Bool) -> t a -> Nat
 107 | count predicate = foldMap @{%search} @{Additive} (\x => if predicate x then 1 else 0)
 108 |
 109 | -----------
 110 | -- PAIRS --
 111 | -----------
 112 |
 113 | %inline
 114 | public export
 115 | Bifunctor Pair where
 116 |   bimap f g (x, y) = (f x, g y)
 117 |
 118 | %inline
 119 | public export
 120 | Bifoldable Pair where
 121 |   bifoldr f g acc (x, y) = f x (g y acc)
 122 |   bifoldl f g acc (x, y) = g (f acc x) y
 123 |   binull _ = False
 124 |
 125 | %inline
 126 | public export
 127 | Bitraversable Pair where
 128 |   bitraverse f g (a,b) = [| (,) (f a) (g b) |]
 129 |
 130 | %inline
 131 | public export
 132 | Functor (Pair a) where
 133 |   map = mapSnd
 134 |
 135 | %inline
 136 | public export
 137 | Foldable (Pair a) where
 138 |   foldr op init (_, x) = x `op` init
 139 |   foldl op init (_, x) = init `op` x
 140 |   null _ = False
 141 |
 142 | %inline
 143 | public export
 144 | Traversable (Pair a) where
 145 |   traverse f (l, r) = (l,) <$> f r
 146 |
 147 | %inline
 148 | public export
 149 | Monoid a => Applicative (Pair a) where
 150 |   pure = (neutral,)
 151 |   (a1,f) <*> (a2,v) = (a1 <+> a2, f v)
 152 |
 153 | %inline
 154 | public export
 155 | Monoid a => Monad (Pair a) where
 156 |   (a1,a) >>= f = let (a2,b) = f a in (a1 <+> a2, b)
 157 |
 158 | -----------
 159 | -- MAYBE --
 160 | -----------
 161 |
 162 | ||| An optional value.  This can be used to represent the possibility of
 163 | ||| failure, where a function may return a value, or not.
 164 | public export
 165 | data Maybe : (ty : Type) -> Type where
 166 |   ||| No value stored
 167 |   Nothing : Maybe ty
 168 |
 169 |   ||| A value of type `ty` is stored
 170 |   Just : (x : ty) -> Maybe ty
 171 |
 172 | public export
 173 | Uninhabited (Nothing = Just x) where
 174 |   uninhabited Refl impossible
 175 |
 176 | public export
 177 | Uninhabited (Just x = Nothing) where
 178 |   uninhabited Refl impossible
 179 |
 180 | public export
 181 | maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b
 182 | maybe n j Nothing  = n
 183 | maybe n j (Just x) = j x
 184 |
 185 | ||| Execute an applicative expression when the Maybe is Just
 186 | %inline public export
 187 | whenJust : Applicative f => Maybe a -> (a -> f ()) -> f ()
 188 | whenJust (Just a) k = k a
 189 | whenJust Nothing k = pure ()
 190 |
 191 | public export
 192 | Eq a => Eq (Maybe a) where
 193 |   Nothing  == Nothing  = True
 194 |   Nothing  == (Just _) = False
 195 |   (Just _) == Nothing  = False
 196 |   (Just a) == (Just b) = a == b
 197 |
 198 | public export
 199 | Ord a => Ord (Maybe a) where
 200 |   compare Nothing  Nothing  = EQ
 201 |   compare Nothing  (Just _) = LT
 202 |   compare (Just _) Nothing  = GT
 203 |   compare (Just a) (Just b) = compare a b
 204 |
 205 | public export
 206 | Semigroup (Maybe a) where
 207 |   Nothing   <+> m = m
 208 |   (Just x)  <+> _ = Just x
 209 |
 210 | public export
 211 | Monoid (Maybe a) where
 212 |   neutral = Nothing
 213 |
 214 | public export
 215 | Functor Maybe where
 216 |   map f (Just x) = Just (f x)
 217 |   map f Nothing  = Nothing
 218 |
 219 | public export
 220 | Applicative Maybe where
 221 |   pure = Just
 222 |
 223 |   Just f <*> Just a = Just (f a)
 224 |   _      <*> _      = Nothing
 225 |
 226 | public export
 227 | Alternative Maybe where
 228 |   empty = Nothing
 229 |
 230 |   (Just x) <|> _ = Just x
 231 |   Nothing  <|> v = v
 232 |
 233 | public export
 234 | Monad Maybe where
 235 |   Nothing  >>= k = Nothing
 236 |   (Just x) >>= k = k x
 237 |
 238 | public export
 239 | Foldable Maybe where
 240 |   foldr _ z Nothing  = z
 241 |   foldr f z (Just x) = f x z
 242 |   null Nothing = True
 243 |   null (Just _) = False
 244 |
 245 | public export
 246 | Traversable Maybe where
 247 |   traverse f Nothing = pure Nothing
 248 |   traverse f (Just x) = Just <$> f x
 249 |
 250 | -----------------
 251 | -- EQUIVALENCE --
 252 | -----------------
 253 |
 254 | public export
 255 | record (<=>) (a, b : Type) where
 256 |   constructor MkEquivalence
 257 |   leftToRight : a -> b
 258 |   rightToLeft : b -> a
 259 |
 260 | ---------
 261 | -- DEC --
 262 | ---------
 263 |
 264 | ||| Decidability.  A decidable property either holds or is a contradiction.
 265 | public export
 266 | data Dec : Type -> Type where
 267 |   ||| The case where the property holds.
 268 |   ||| @ prf the proof
 269 |   Yes : (prf : prop) -> Dec prop
 270 |
 271 |   ||| The case where the property holding would be a contradiction.
 272 |   ||| @ contra a demonstration that prop would be a contradiction
 273 |   No  : (contra : Not prop) -> Dec prop
 274 |
 275 | export Uninhabited (Yes p === No q) where uninhabited eq impossible
 276 | export Uninhabited (No p === Yes q) where uninhabited eq impossible
 277 |
 278 | public export
 279 | viaEquivalence : a <=> b -> Dec a -> Dec b
 280 | viaEquivalence f (Yes a) = Yes (f .leftToRight a)
 281 | viaEquivalence f (No na) = No (na . f .rightToLeft)
 282 |
 283 | ------------
 284 | -- EITHER --
 285 | ------------
 286 |
 287 | ||| A sum type.
 288 | public export
 289 | data Either : (a : Type) -> (b : Type) -> Type where
 290 |   ||| One possibility of the sum, conventionally used to represent errors.
 291 |   Left : forall a, b. (x : a) -> Either a b
 292 |
 293 |   ||| The other possibility, conventionally used to represent success.
 294 |   Right : forall a, b. (x : b) -> Either a b
 295 |
 296 | export Uninhabited (Left p === Right q) where uninhabited eq impossible
 297 | export Uninhabited (Right p === Left q) where uninhabited eq impossible
 298 |
 299 | export
 300 | Either (Uninhabited a) (Uninhabited b) => Uninhabited (a, b) where
 301 |   uninhabited (x, _) @{Left  _} = uninhabited x
 302 |   uninhabited (_, y) @{Right _} = uninhabited y
 303 |
 304 | export
 305 | Uninhabited a => Uninhabited b => Uninhabited (Either a b) where
 306 |   uninhabited (Left l)  = uninhabited l
 307 |   uninhabited (Right r) = uninhabited r
 308 |
 309 | ||| Simply-typed eliminator for Either.
 310 | ||| @ f the action to take on Left
 311 | ||| @ g the action to take on Right
 312 | ||| @ e the sum to analyze
 313 | public export
 314 | either : (f : Lazy (a -> c)) -> (g : Lazy (b -> c)) -> (e : Either a b) -> c
 315 | either l r (Left x) = l x
 316 | either l r (Right x) = r x
 317 |
 318 | public export
 319 | (Eq a, Eq b) => Eq (Either a b) where
 320 |   Left x == Left x' = x == x'
 321 |   Right x == Right x' = x == x'
 322 |   _ == _ = False
 323 |
 324 | public export
 325 | (Ord a, Ord b) => Ord (Either a b) where
 326 |   compare (Left x) (Left x') = compare x x'
 327 |   compare (Left _) (Right _) = LT
 328 |   compare (Right _) (Left _) = GT
 329 |   compare (Right x) (Right x') = compare x x'
 330 |
 331 | %inline
 332 | public export
 333 | Functor (Either e) where
 334 |   map f (Left x) = Left x
 335 |   map f (Right x) = Right (f x)
 336 |
 337 | %inline
 338 | public export
 339 | Bifunctor Either where
 340 |   bimap f _ (Left x) = Left (f x)
 341 |   bimap _ g (Right y) = Right (g y)
 342 |
 343 | %inline
 344 | public export
 345 | Bifoldable Either where
 346 |   bifoldr f _ acc (Left a)  = f a acc
 347 |   bifoldr _ g acc (Right b) = g b acc
 348 |
 349 |   bifoldl f _ acc (Left a)  = f acc a
 350 |   bifoldl _ g acc (Right b) = g acc b
 351 |
 352 |   binull _ = False
 353 |
 354 | %inline
 355 | public export
 356 | Bitraversable Either where
 357 |   bitraverse f _ (Left a)  = Left <$> f a
 358 |   bitraverse _ g (Right b) = Right <$> g b
 359 |
 360 | %inline
 361 | public export
 362 | Applicative (Either e) where
 363 |   pure = Right
 364 |
 365 |   (Left a) <*> _          = Left a
 366 |   (Right f) <*> (Right r) = Right (f r)
 367 |   (Right _) <*> (Left l)  = Left l
 368 |
 369 | public export
 370 | Monad (Either e) where
 371 |   (Left n) >>= _ = Left n
 372 |   (Right r) >>= f = f r
 373 |
 374 | public export
 375 | Foldable (Either e) where
 376 |   foldr f acc (Left _) = acc
 377 |   foldr f acc (Right x) = f x acc
 378 |   null (Left _) = True
 379 |   null (Right _) = False
 380 |
 381 | public export
 382 | Traversable (Either e) where
 383 |   traverse f (Left x)  = pure (Left x)
 384 |   traverse f (Right x) = Right <$> f x
 385 |
 386 | -----------
 387 | -- LISTS --
 388 | -----------
 389 |
 390 | public export
 391 | Eq a => Eq (List a) where
 392 |   [] == [] = True
 393 |   x :: xs == y :: ys = x == y && xs == ys
 394 |   _ == _ = False
 395 |
 396 | public export
 397 | Ord a => Ord (List a) where
 398 |   compare [] [] = EQ
 399 |   compare [] (x :: xs) = LT
 400 |   compare (x :: xs) [] = GT
 401 |   compare (x :: xs) (y ::ys)
 402 |      = case compare x y of
 403 |             EQ => compare xs ys
 404 |             c => c
 405 |
 406 | namespace SnocList
 407 |
 408 |   export infixl 7 <><
 409 |   export infixr 6 <>>
 410 |
 411 |   ||| 'fish': Action of lists on snoc-lists
 412 |   public export
 413 |   (<><) : SnocList a -> List a -> SnocList a
 414 |   sx <>< [] = sx
 415 |   sx <>< (x :: xs) = sx :< x <>< xs
 416 |
 417 |   ||| 'chips': Action of snoc-lists on lists
 418 |   public export
 419 |   (<>>) : SnocList a -> List a -> List a
 420 |   Lin       <>> xs = xs
 421 |   (sx :< x) <>> xs = sx <>> x :: xs
 422 |
 423 |   public export
 424 |   (++) : (sx, sy : SnocList a) -> SnocList a
 425 |   (++) sx Lin = sx
 426 |   (++) sx (sy :< y) = (sx ++ sy) :< y
 427 |
 428 |   public export
 429 |   length : SnocList a -> Nat
 430 |   length Lin = Z
 431 |   length (sx :< x) = S $ length sx
 432 |
 433 |   ||| Filters a snoc-list according to a simple classifying function
 434 |   public export
 435 |   filter : (a -> Bool) -> SnocList a -> SnocList a
 436 |   filter f [<]     = [<]
 437 |   filter f (xs:<x) = let rest = filter f xs in if f x then rest :< x else rest
 438 |
 439 |   ||| Apply a partial function to the elements of a list, keeping the ones at which
 440 |   ||| it is defined.
 441 |   public export
 442 |   mapMaybe : (a -> Maybe b) -> SnocList a -> SnocList b
 443 |   mapMaybe f [<]       = [<]
 444 |   mapMaybe f (sx :< x) = case f x of
 445 |     Nothing => mapMaybe f sx
 446 |     Just j  => mapMaybe f sx :< j
 447 |
 448 |   ||| Reverse the second snoclist, prepending its elements to the first.
 449 |   public export
 450 |   reverseOnto : SnocList a -> SnocList a -> SnocList a
 451 |   reverseOnto acc Lin       = acc
 452 |   reverseOnto acc (sx :< x) = reverseOnto (acc :< x) sx
 453 |
 454 |   ||| Reverses the given list.
 455 |   public export
 456 |   reverse : SnocList a -> SnocList a
 457 |   reverse = reverseOnto Lin
 458 |
 459 |   ||| Tail-recursive append. Uses of (++) are automatically transformed to
 460 |   ||| this. The only reason this is exported is that the proof of equivalence
 461 |   ||| lives in a different module.
 462 |   public export
 463 |   tailRecAppend : (sx, sy : SnocList a) -> SnocList a
 464 |   tailRecAppend sx sy = reverseOnto sx (reverse sy)
 465 |
 466 |   -- Always use tailRecAppend at runtime. Data.SnocList.tailRecAppendIsAppend
 467 |   -- proves these are equivalent.
 468 |   %transform "tailRecAppendSnocList" SnocList.(++) = SnocList.tailRecAppend
 469 |
 470 |   ||| Returns the first argument plus the length of the second.
 471 |   public export
 472 |   lengthPlus : Nat -> SnocList a -> Nat
 473 |   lengthPlus n Lin       = n
 474 |   lengthPlus n (sx :< _) = lengthPlus (S n) sx
 475 |
 476 |   ||| `length` implementation that uses tail recursion. Exported so
 477 |   ||| lengthTRIsLength can see it.
 478 |   public export
 479 |   lengthTR : SnocList a -> Nat
 480 |   lengthTR = lengthPlus Z
 481 |
 482 |   -- Data.List.lengthTRIsLength proves these are equivalent.
 483 |   %transform "tailRecLengthSnocList" SnocList.length = SnocList.lengthTR
 484 |
 485 |   ||| Utility for implementing `mapMaybeTR`
 486 |   public export
 487 |   mapMaybeAppend : List b -> (a -> Maybe b) -> SnocList a -> SnocList b
 488 |   mapMaybeAppend xs f (sx :< x) = case f x of
 489 |     Just v  => mapMaybeAppend (v :: xs) f sx
 490 |     Nothing => mapMaybeAppend xs f sx
 491 |   mapMaybeAppend xs f Lin       = Lin <>< xs
 492 |
 493 |   ||| Tail recursive version of `mapMaybe`. This is automatically used
 494 |   ||| at runtime due to a `transform` rule.
 495 |   public export %inline
 496 |   mapMaybeTR : (a -> Maybe b) -> SnocList a -> SnocList b
 497 |   mapMaybeTR = mapMaybeAppend []
 498 |
 499 |   -- Data.List.mapMaybeTRIsMapMaybe proves these are equivalent.
 500 |   %transform "tailRecMapMaybeSnocList" SnocList.mapMaybe = SnocList.mapMaybeTR
 501 |
 502 |   ||| Utility for implementing `filterTR`
 503 |   public export
 504 |   filterAppend : List a -> (a -> Bool) -> SnocList a -> SnocList a
 505 |   filterAppend xs f (sx :< x) = case f x of
 506 |     True  => filterAppend (x :: xs) f sx
 507 |     False => filterAppend xs f sx
 508 |   filterAppend xs f Lin       = Lin <>< xs
 509 |
 510 |   ||| Tail recursive version of `filter`. This is automatically used
 511 |   ||| at runtime due to a `transform` rule.
 512 |   public export %inline
 513 |   filterTR : (a -> Bool) -> SnocList a -> SnocList a
 514 |   filterTR = filterAppend []
 515 |
 516 |   -- Data.List.listTRIsList proves these are equivalent.
 517 |   %transform "tailRecFilterSnocList" SnocList.filter = SnocList.filterTR
 518 |
 519 | namespace List
 520 |
 521 |   ||| Concatenate one list with another.
 522 |   public export
 523 |   (++) : (xs, ys : List a) -> List a
 524 |   [] ++ ys = ys
 525 |   (x :: xs) ++ ys = x :: xs ++ ys
 526 |
 527 |   ||| Returns the length of the list.
 528 |   public export
 529 |   length : List a -> Nat
 530 |   length []        = Z
 531 |   length (x :: xs) = S (length xs)
 532 |
 533 |   ||| Applied to a predicate and a list, returns the list of those elements that
 534 |   ||| satisfy the predicate.
 535 |   public export
 536 |   filter : (p : a -> Bool) -> List a -> List a
 537 |   filter p [] = []
 538 |   filter p (x :: xs)
 539 |      = if p x
 540 |           then x :: filter p xs
 541 |           else filter p xs
 542 |
 543 |   ||| Apply a partial function to the elements of a list, keeping the ones at which it is defined.
 544 |   public export
 545 |   mapMaybe : (a -> Maybe b) -> List a -> List b
 546 |   mapMaybe f []      = []
 547 |   mapMaybe f (x::xs) =
 548 |     case f x of
 549 |       Nothing => mapMaybe f xs
 550 |       Just j  => j :: mapMaybe f xs
 551 |
 552 |   ||| Reverse the second list, prepending its elements to the first.
 553 |   public export
 554 |   reverseOnto : List a -> List a -> List a
 555 |   reverseOnto acc [] = acc
 556 |   reverseOnto acc (x::xs) = reverseOnto (x::acc) xs
 557 |
 558 |   ||| Reverses the given list.
 559 |   public export
 560 |   reverse : List a -> List a
 561 |   reverse = reverseOnto []
 562 |
 563 |   ||| Tail-recursive append. Uses of (++) are automatically transformed to
 564 |   ||| this. The only reason this is exported is that the proof of equivalence
 565 |   ||| lives in a different module.
 566 |   public export
 567 |   tailRecAppend : (xs, ys : List a) -> List a
 568 |   tailRecAppend xs ys = reverseOnto ys (reverse xs)
 569 |
 570 |   -- Always use tailRecAppend at runtime. Data.List.tailRecAppendIsAppend
 571 |   -- proves these are equivalent.
 572 |   %transform "tailRecAppend" List.(++) = List.tailRecAppend
 573 |
 574 |   ||| Returns the first argument plus the length of the second.
 575 |   public export
 576 |   lengthPlus : Nat -> List a -> Nat
 577 |   lengthPlus n [] = n
 578 |   lengthPlus n (x::xs) = lengthPlus (S n) xs
 579 |
 580 |   ||| `length` implementation that uses tail recursion. Exported so
 581 |   ||| lengthTRIsLength can see it.
 582 |   public export
 583 |   lengthTR : List a -> Nat
 584 |   lengthTR = lengthPlus Z
 585 |
 586 |   -- Data.List.lengthTRIsLength proves these are equivalent.
 587 |   %transform "tailRecLength" List.length = List.lengthTR
 588 |
 589 |   public export
 590 |   mapImpl : (a -> b) -> List a -> List b
 591 |   mapImpl f [] = []
 592 |   mapImpl f (x :: xs) = f x :: mapImpl f xs
 593 |
 594 |   ||| Utility for implementing `mapTR`
 595 |   public export
 596 |   mapAppend : SnocList b -> (a -> b) -> List a -> List b
 597 |   mapAppend sx f (x :: xs) = mapAppend (sx :< f x) f xs
 598 |   mapAppend sx f []        = sx <>> []
 599 |
 600 |   ||| Tail recursive version of `map`. This is automatically used
 601 |   ||| at runtime due to a `transform` rule.
 602 |   public export %inline
 603 |   mapTR : (a -> b) -> List a -> List b
 604 |   mapTR = mapAppend Lin
 605 |
 606 |   -- Data.List.mapTRIsMap proves these are equivalent.
 607 |   %transform "tailRecMap" mapImpl = List.mapTR
 608 |
 609 |   ||| Utility for implementing `mapMaybeTR`
 610 |   public export
 611 |   mapMaybeAppend : SnocList b -> (a -> Maybe b) -> List a -> List b
 612 |   mapMaybeAppend sx f (x :: xs) = case f x of
 613 |     Just v  => mapMaybeAppend (sx :< v) f xs
 614 |     Nothing => mapMaybeAppend sx f xs
 615 |   mapMaybeAppend sx f []        = sx <>> []
 616 |
 617 |   ||| Tail recursive version of `mapMaybe`. This is automatically used
 618 |   ||| at runtime due to a `transform` rule.
 619 |   public export %inline
 620 |   mapMaybeTR : (a -> Maybe b) -> List a -> List b
 621 |   mapMaybeTR = mapMaybeAppend Lin
 622 |
 623 |   -- Data.List.mapMaybeTRIsMapMaybe proves these are equivalent.
 624 |   %transform "tailRecMapMaybe" List.mapMaybe = List.mapMaybeTR
 625 |
 626 |   ||| Utility for implementing `filterTR`
 627 |   public export
 628 |   filterAppend : SnocList a -> (a -> Bool) -> List a -> List a
 629 |   filterAppend sx f (x :: xs) = case f x of
 630 |     True  => filterAppend (sx :< x) f xs
 631 |     False => filterAppend sx f xs
 632 |   filterAppend sx f []        = sx <>> []
 633 |
 634 |   ||| Tail recursive version of `filter`. This is automatically used
 635 |   ||| at runtime due to a `transform` rule.
 636 |   public export %inline
 637 |   filterTR : (a -> Bool) -> List a -> List a
 638 |   filterTR = filterAppend Lin
 639 |
 640 |   -- Data.List.listTRIsList proves these are equivalent.
 641 |   %transform "tailRecFilter" List.filter = List.filterTR
 642 |
 643 | public export %inline
 644 | Functor List where
 645 |   map = mapImpl
 646 |
 647 | public export
 648 | Semigroup (List a) where
 649 |   (<+>) = (++)
 650 |
 651 | public export
 652 | Monoid (List a) where
 653 |   neutral = []
 654 |
 655 | public export
 656 | Foldable List where
 657 |   foldr c n [] = n
 658 |   foldr c n (x::xs) = c x (foldr c n xs)
 659 |
 660 |   foldl f q [] = q
 661 |   foldl f q (x::xs) = foldl f (f q x) xs
 662 |
 663 |   null [] = True
 664 |   null (_::_) = False
 665 |
 666 |   toList = id
 667 |
 668 |   foldMap f = foldl (\acc, elem => acc <+> f elem) neutral
 669 |
 670 | public export
 671 | listBindOnto : (a -> List b) -> List b -> List a -> List b
 672 | listBindOnto f xs []        = reverse xs
 673 | listBindOnto f xs (y :: ys) = listBindOnto f (reverseOnto xs (f y)) ys
 674 |
 675 | -- tail recursive O(n) implementation of `(>>=)` for `List`
 676 | public export
 677 | listBind : List a -> (a -> List b) -> List b
 678 | listBind as f = listBindOnto f Nil as
 679 |
 680 | public export
 681 | Applicative List where
 682 |   pure x = [x]
 683 |   fs <*> vs = listBind fs (\f => map f vs)
 684 |
 685 | public export
 686 | Alternative List where
 687 |   empty = []
 688 |   xs <|> ys = xs ++ ys
 689 |
 690 | public export
 691 | Monad List where
 692 |   (>>=) = listBind
 693 |
 694 | public export
 695 | Traversable List where
 696 |   traverse f [] = pure []
 697 |   traverse f (x::xs) = [| f x :: traverse f xs |]
 698 |
 699 | public export
 700 | Eq a => Eq (SnocList a) where
 701 |   (==) Lin Lin = True
 702 |   (==) (sx :< x) (sy :< y) = x == y && sx == sy
 703 |   (==) _ _ = False
 704 |
 705 | public export
 706 | Ord a => Ord (SnocList a) where
 707 |   compare Lin Lin = EQ
 708 |   compare Lin (sx :< x) = LT
 709 |   compare (sx :< x) Lin = GT
 710 |   compare (sx :< x) (sy :< y)
 711 |     = case compare sx sy of
 712 |         EQ => compare x y
 713 |         c  => c
 714 |
 715 | -- This works quickly because when string-concat builds the result, it allocates
 716 | -- enough room in advance so there's only one allocation, rather than lots!
 717 | --
 718 | -- Like fastUnpack, this function won't reduce at compile time.
 719 | -- If you need to concatenate strings at compile time, use Prelude.concat.
 720 | %foreign
 721 |   "scheme:string-concat"
 722 |   "RefC:fastConcat"
 723 |   "javascript:lambda:(xs)=>__prim_idris2js_array(xs).join('')"
 724 | export
 725 | fastConcat : List String -> String
 726 |
 727 | %transform "fastConcat" concat {t = List} {a = String} = fastConcat
 728 |
 729 | ||| Check if something is a member of a list using a custom comparison.
 730 | public export
 731 | elemBy : Foldable t => (a -> a -> Bool) -> a -> t a -> Bool
 732 | elemBy p e = any (p e)
 733 |
 734 | ||| Check if something is a member of a list using the default Boolean equality.
 735 | public export
 736 | elem : Foldable t => Eq a => a -> t a -> Bool
 737 | elem = elemBy (==)
 738 |
 739 | ||| Lookup a value at a given position
 740 | export
 741 | getAt : Nat -> List a -> Maybe a
 742 | getAt Z     (x :: xs) = Just x
 743 | getAt (S k) (x :: xs) = getAt k xs
 744 | getAt _     []        = Nothing
 745 |
 746 | -------------
 747 | -- STREAMS --
 748 | -------------
 749 |
 750 | namespace Stream
 751 |   ||| An infinite stream.
 752 |   public export
 753 |   data Stream : Type -> Type where
 754 |        (::) : a -> Inf (Stream a) -> Stream a
 755 |
 756 | %name Stream xs, ys, zs
 757 |
 758 | public export
 759 | Functor Stream where
 760 |   map f (x :: xs) = f x :: map f xs
 761 |
 762 | ||| The first element of an infinite stream.
 763 | public export
 764 | head : Stream a -> a
 765 | head (x :: xs) = x
 766 |
 767 | ||| All but the first element.
 768 | public export
 769 | tail : Stream a -> Stream a
 770 | tail (x :: xs) = xs
 771 |
 772 | ||| Take precisely n elements from the stream.
 773 | ||| @ n how many elements to take
 774 | ||| @ xs the stream
 775 | public export
 776 | take : (n : Nat) -> (xs : Stream a) -> List a
 777 | take Z xs = []
 778 | take (S k) (x :: xs) = x :: take k xs
 779 |
 780 | -------------
 781 | -- STRINGS --
 782 | -------------
 783 |
 784 | namespace String
 785 |   public export
 786 |   (++) : (x : String) -> (y : String) -> String
 787 |   x ++ y = prim__strAppend x y
 788 |
 789 |   ||| Returns the length of the string.
 790 |   |||
 791 |   ||| ```idris example
 792 |   ||| length ""
 793 |   ||| ```
 794 |   ||| ```idris example
 795 |   ||| length "ABC"
 796 |   ||| ```
 797 |   public export
 798 |   length : String -> Nat
 799 |   length str = fromInteger (prim__cast_IntInteger (prim__strLength str))
 800 |
 801 | ||| Reverses the elements within a string.
 802 | |||
 803 | ||| ```idris example
 804 | ||| reverse "ABC"
 805 | ||| ```
 806 | ||| ```idris example
 807 | ||| reverse ""
 808 | ||| ```
 809 | public export
 810 | reverse : String -> String
 811 | reverse = prim__strReverse
 812 |
 813 | ||| Returns a substring of a given string
 814 | |||
 815 | ||| @ index The (zero based) index of the string to extract.  If this is beyond
 816 | |||         the end of the string, the function returns the empty string.
 817 | ||| @ len The desired length of the substring.  Truncated if this exceeds the
 818 | |||       length of the input
 819 | ||| @ subject The string to return a portion of
 820 | public export
 821 | substr : (index : Nat) -> (len : Nat) -> (subject : String) -> String
 822 | substr s e subj
 823 |     = if natToInteger s < natToInteger (length subj)
 824 |          then prim__strSubstr (prim__cast_IntegerInt (natToInteger s))
 825 |                               (prim__cast_IntegerInt (natToInteger e))
 826 |                               subj
 827 |          else ""
 828 |
 829 | ||| Adds a character to the front of the specified string.
 830 | |||
 831 | ||| ```idris example
 832 | ||| strCons 'A' "B"
 833 | ||| ```
 834 | ||| ```idris example
 835 | ||| strCons 'A' ""
 836 | ||| ```
 837 | public export
 838 | strCons : Char -> String -> String
 839 | strCons = prim__strCons
 840 |
 841 | public export
 842 | strUncons : String -> Maybe (Char, String)
 843 | strUncons "" = Nothing
 844 | strUncons str = assert_total $ Just (prim__strHead str, prim__strTail str)
 845 |
 846 | ||| Turns a list of characters into a string.
 847 | public export
 848 | pack : List Char -> String
 849 | pack [] = ""
 850 | pack (x :: xs) = strCons x (pack xs)
 851 |
 852 | %foreign
 853 |     "scheme:string-pack"
 854 |     "RefC:fastPack"
 855 |     "javascript:lambda:(xs)=>__prim_idris2js_array(xs).join('')"
 856 | export
 857 | fastPack : List Char -> String
 858 |
 859 | -- always use 'fastPack' at run time
 860 | %transform "fastPack" pack = fastPack
 861 |
 862 | ||| Turns a string into a list of characters.
 863 | |||
 864 | ||| ```idris example
 865 | ||| unpack "ABC"
 866 | ||| ```
 867 | public export
 868 | unpack : String -> List Char
 869 | unpack str = go [] (length str)
 870 |   where
 871 |     go : List Char -> Nat -> List Char
 872 |     go cs 0     = cs
 873 |     go cs (S k) =
 874 |       let ix := prim__cast_IntegerInt $ natToInteger k
 875 |        in go (assert_total (prim__strIndex str ix) :: cs) k
 876 |
 877 | -- This function runs fast when compiled but won't compute at compile time.
 878 | -- If you need to unpack strings at compile time, use Prelude.unpack.
 879 | %foreign
 880 |   "scheme:string-unpack"
 881 |   "RefC:fastUnpack"
 882 |   "javascript:lambda:(str)=>__prim_js2idris_array(Array.from(str))"
 883 | export
 884 | fastUnpack : String -> List Char
 885 |
 886 | -- always use 'fastPack' at run time
 887 | %transform "fastUnpack" unpack = fastUnpack
 888 |
 889 | public export
 890 | Semigroup String where
 891 |   (<+>) = (++)
 892 |
 893 | public export
 894 | Monoid String where
 895 |   neutral = ""
 896 |
 897 | ----------------
 898 | -- CHARACTERS --
 899 | ----------------
 900 |
 901 | ||| Returns true if the character is in the range [A-Z].
 902 | public export
 903 | isUpper : Char -> Bool
 904 | isUpper x = x >= 'A' && x <= 'Z'
 905 |
 906 | ||| Returns true if the character is in the range [a-z].
 907 | public export
 908 | isLower : Char -> Bool
 909 | isLower x = x >= 'a' && x <= 'z'
 910 |
 911 | ||| Returns true if the character is in the ranges [A-Z][a-z].
 912 | public export
 913 | isAlpha : Char -> Bool
 914 | isAlpha x = isUpper x || isLower x
 915 |
 916 | ||| Returns true if the character is in the range [0-9].
 917 | public export
 918 | isDigit : Char -> Bool
 919 | isDigit x = (x >= '0' && x <= '9')
 920 |
 921 | ||| Returns true if the character is in the ranges [A-Z][a-z][0-9].
 922 | public export
 923 | isAlphaNum : Char -> Bool
 924 | isAlphaNum x = isDigit x || isAlpha x
 925 |
 926 | ||| Returns true if the character is a whitespace character.
 927 | public export
 928 | isSpace : Char -> Bool
 929 | isSpace ' '    = True
 930 | isSpace '\t'   = True
 931 | isSpace '\r'   = True
 932 | isSpace '\n'   = True
 933 | isSpace '\f'   = True
 934 | isSpace '\v'   = True
 935 | isSpace '\xa0' = True
 936 | isSpace _      = False
 937 |
 938 | ||| Returns true if the character represents a new line.
 939 | public export
 940 | isNL : Char -> Bool
 941 | isNL '\r' = True
 942 | isNL '\n' = True
 943 | isNL _    = False
 944 |
 945 | ||| Convert a letter to the corresponding upper-case letter, if any.
 946 | ||| Non-letters are ignored.
 947 | public export
 948 | toUpper : Char -> Char
 949 | toUpper x
 950 |     = if (isLower x)
 951 |          then prim__cast_IntChar (prim__cast_CharInt x - 32)
 952 |          else x
 953 |
 954 | ||| Convert a letter to the corresponding lower-case letter, if any.
 955 | ||| Non-letters are ignored.
 956 | public export
 957 | toLower : Char -> Char
 958 | toLower x
 959 |     = if (isUpper x)
 960 |          then prim__cast_IntChar (prim__cast_CharInt x + 32)
 961 |          else x
 962 |
 963 | ||| Returns true if the character is a hexadecimal digit i.e. in the range
 964 | ||| [0-9][a-f][A-F].
 965 | public export
 966 | isHexDigit : Char -> Bool
 967 | isHexDigit x = isDigit x || ('a' <= x && x <= 'f') || ('A' <= x && x <= 'F')
 968 |
 969 | ||| Returns true if the character is an octal digit.
 970 | public export
 971 | isOctDigit : Char -> Bool
 972 | isOctDigit x = (x >= '0' && x <= '7')
 973 |
 974 | ||| Returns true if the character is a control character.
 975 | public export
 976 | isControl : Char -> Bool
 977 | isControl x
 978 |     = (x >= '\x0000' && x <= '\x001f')
 979 |        || (x >= '\x007f' && x <= '\x009f')
 980 |
 981 | ||| Convert the number to its backend dependent (usually Unicode) Char
 982 | ||| equivalent.
 983 | public export
 984 | chr : Int -> Char
 985 | chr = prim__cast_IntChar
 986 |
 987 | ||| Return the backend dependent (usually Unicode) numerical equivalent of the Char.
 988 | public export
 989 | ord : Char -> Int
 990 | ord = prim__cast_CharInt
 991 |
 992 | -----------------------
 993 | -- DOUBLE PRIMITIVES --
 994 | -----------------------
 995 |
 996 | public export
 997 | pi : Double
 998 | pi = 3.14159265358979323846
 999 |
1000 | public export
1001 | euler : Double
1002 | euler = 2.7182818284590452354
1003 |
1004 | public export
1005 | exp : Double -> Double
1006 | exp x = prim__doubleExp x
1007 |
1008 | public export
1009 | log : Double -> Double
1010 | log x = prim__doubleLog x
1011 |
1012 | public export
1013 | pow : Double -> Double -> Double
1014 | pow x y = prim__doublePow x y
1015 |
1016 | public export
1017 | sin : Double -> Double
1018 | sin x = prim__doubleSin x
1019 |
1020 | public export
1021 | cos : Double -> Double
1022 | cos x = prim__doubleCos x
1023 |
1024 | public export
1025 | tan : Double -> Double
1026 | tan x = prim__doubleTan x
1027 |
1028 | public export
1029 | asin : Double -> Double
1030 | asin x = prim__doubleASin x
1031 |
1032 | public export
1033 | acos : Double -> Double
1034 | acos x = prim__doubleACos x
1035 |
1036 | public export
1037 | atan : Double -> Double
1038 | atan x = prim__doubleATan x
1039 |
1040 | public export
1041 | sinh : Double -> Double
1042 | sinh x = (exp x - exp (-x)) / 2
1043 |
1044 | public export
1045 | cosh : Double -> Double
1046 | cosh x = (exp x + exp (-x)) / 2
1047 |
1048 | public export
1049 | tanh : Double -> Double
1050 | tanh x = sinh x / cosh x
1051 |
1052 | public export
1053 | sqrt : Double -> Double
1054 | sqrt x = prim__doubleSqrt x
1055 |
1056 | public export
1057 | floor : Double -> Double
1058 | floor x = prim__doubleFloor x
1059 |
1060 | public export
1061 | ceiling : Double -> Double
1062 | ceiling x = prim__doubleCeiling x
1063 |
1064 | ------------
1065 | -- RANGES --
1066 | ------------
1067 |
1068 | -- These functions are here to support the range syntax:
1069 | -- range expressions like `[a..b]` are desugared to `rangeFromXXX` calls.
1070 |
1071 | public export
1072 | countFrom : n -> (n -> n) -> Stream n
1073 | countFrom start diff = start :: countFrom (diff start) diff
1074 |
1075 | public export
1076 | covering
1077 | takeUntil : (n -> Bool) -> Stream n -> List n
1078 | takeUntil p (x :: xs)
1079 |     = if p x
1080 |          then [x]
1081 |          else x :: takeUntil p xs
1082 |
1083 | public export
1084 | covering
1085 | takeBefore : (n -> Bool) -> Stream n -> List n
1086 | takeBefore p (x :: xs)
1087 |     = if p x
1088 |          then []
1089 |          else x :: takeBefore p xs
1090 |
1091 | public export
1092 | interface Range a where
1093 |   constructor MkRange
1094 |   rangeFromTo : a -> a -> List a
1095 |   rangeFromThenTo : a -> a -> a -> List a
1096 |
1097 |   rangeFrom : a -> Stream a
1098 |   rangeFromThen : a -> a -> Stream a
1099 |
1100 | -- Idris 1 went to great lengths to prove that these were total. I don't really
1101 | -- think it's worth going to those lengths! Let's keep it simple and assert.
1102 | public export
1103 | Range Nat where
1104 |   rangeFromTo x y = case compare x y of
1105 |     LT => assert_total $ takeUntil (>= y) (countFrom x S)
1106 |     EQ => pure x
1107 |     GT => assert_total $ takeUntil (<= y) (countFrom x (\n => minus n 1))
1108 |   rangeFromThenTo x y z = case compare x y of
1109 |     LT => if z >= x
1110 |              then assert_total $ takeBefore (> z) (countFrom x (plus (minus y x)))
1111 |              else Nil
1112 |     EQ => if x == z then pure x else Nil
1113 |     GT => assert_total $ takeBefore (< z) (countFrom x (\n => minus n (minus x y)))
1114 |   rangeFrom x = countFrom x S
1115 |   rangeFromThen x y
1116 |       = if y > x
1117 |            then countFrom x (plus (minus y x))
1118 |            else countFrom x (\n => minus n (minus x y))
1119 |
1120 | public export
1121 | (Integral a, Ord a, Neg a) => Range a where
1122 |   rangeFromTo x y = case compare x y of
1123 |     LT => assert_total $ takeUntil (>= y) (countFrom x (+1))
1124 |     EQ => pure x
1125 |     GT => assert_total $ takeUntil (<= y) (countFrom x (\x => x-1))
1126 |   rangeFromThenTo x y z = case compare (z - x) (z - y) of
1127 |     -- Go down
1128 |     LT => assert_total $ takeBefore (< z) (countFrom x (\n => n - (x - y)))
1129 |     -- Meaningless
1130 |     EQ => if x == y && y == z then pure x else Nil
1131 |     -- Go up
1132 |     GT => assert_total $ takeBefore (> z) (countFrom x (+ (y-x)))
1133 |   rangeFrom x = countFrom x (1+)
1134 |   rangeFromThen x y
1135 |       = if y > x
1136 |            then countFrom x (+ (y - x))
1137 |            else countFrom x (\n => n - (x - y))
1138 |
1139 | public export
1140 | Range Char where
1141 |   rangeFromTo x y = map chr $ rangeFromTo (ord x) (ord y)
1142 |   rangeFromThenTo x y z = map chr $ rangeFromThenTo (ord x) (ord y) (ord z)
1143 |   rangeFrom x = map chr $ rangeFrom (ord x)
1144 |   rangeFromThen x y = map chr $ rangeFromThen (ord x) (ord y)
1145 |