mirror of
https://github.com/edwinb/Idris2-boot.git
synced 2024-12-30 00:04:55 +03:00
ecb5cb1e40
Also fix a bug where the elaborator state wasn't updated on completing the delayed elaborator, which could cause issues with implicitly bound names in particular.
1157 lines
24 KiB
Idris
1157 lines
24 KiB
Idris
module Prelude
|
|
|
|
import public Builtin
|
|
import public PrimIO
|
|
|
|
{-
|
|
The Prelude is minimal (since it is effectively part of the language
|
|
specification, this seems to be desirable - we should, nevertheless, aim to
|
|
provide a good selection of base libraries). A rule of thumb is that it should
|
|
contain the basic functions required by almost any non-trivial program.
|
|
|
|
As such, it should contain:
|
|
|
|
- Anything the elaborator can desugar to (e.g. pairs, unit, =, laziness)
|
|
- Basic types Bool, Nat, List, Dec, Maybe, Either
|
|
- The most important utility functions: id, the, composition, etc
|
|
- Interfaces for arithmetic and implementations for the primitives and
|
|
basic types
|
|
- Char and String manipulation
|
|
- Show, Eq, Ord, and implementations for all types in the prelude
|
|
- Interfaces and functions for basic proof (cong, Uninhabited, etc) --
|
|
- Semigroup, Monoid
|
|
- Functor, Applicative, Monad and related functions
|
|
- Foldable
|
|
- [TODO: Enum for range syntax]
|
|
- Console IO
|
|
|
|
Everything else should be in the base libraries, and imported as required.
|
|
In particular, proofs of Nat/List properties that almost never get used in
|
|
practice would probably be better in base libraries.
|
|
|
|
(These guidelines will probably get revised a few times.)
|
|
-}
|
|
|
|
-- Numerical operators
|
|
infix 6 ==, /=, <, <=, >, >=
|
|
infixl 7 <<, >> -- unused
|
|
infixl 8 +, -
|
|
infixl 9 *, /
|
|
|
|
-- Boolean operators
|
|
infixr 4 &&
|
|
infixr 5 ||
|
|
|
|
-- List and String operators
|
|
infixr 7 ::, ++
|
|
|
|
-- Functor/Applicative/Monad/Algebra operators
|
|
infixl 1 >>=
|
|
infixr 2 <|>
|
|
infixl 3 <*>, *>, <*
|
|
infixr 4 <$>
|
|
infixl 6 <+>
|
|
|
|
-- Utility operators
|
|
infixr 9 .
|
|
infixr 0 $
|
|
|
|
infixl 9 `div`, `mod`
|
|
|
|
-----------------------
|
|
-- UTILITY FUNCTIONS --
|
|
-----------------------
|
|
|
|
public export %inline
|
|
the : (0 a : Type) -> (1 x : a) -> a
|
|
the _ x = x
|
|
|
|
public export %inline
|
|
id : (x : a) -> a
|
|
id x = x
|
|
|
|
public export %inline
|
|
const : a -> b -> a
|
|
const x = \value => x
|
|
|
|
public export %inline
|
|
(.) : (b -> c) -> (a -> b) -> a -> c
|
|
(.) f g = \x => f (g x)
|
|
|
|
public export
|
|
flip : (f : a -> b -> c) -> b -> a -> c
|
|
flip f x y = f y x
|
|
|
|
public export
|
|
apply : (a -> b) -> a -> b
|
|
apply f a = f a
|
|
|
|
-- $ is compiled specially to shortcut any tricky unification issues, but if
|
|
-- it did have a type this is what it would be, and it might be useful to
|
|
-- use directly sometimes (e.g. in higher order functions)
|
|
public export
|
|
($) : forall a, b . ((x : a) -> b x) -> (x : a) -> b x
|
|
($) f a = f a
|
|
|
|
-------------------
|
|
-- PROOF HELPERS --
|
|
-------------------
|
|
|
|
public export
|
|
cong : {0 f : t -> u} -> a = b -> f a = f b
|
|
cong Refl = Refl
|
|
|
|
public export
|
|
interface Uninhabited t where
|
|
uninhabited : t -> Void
|
|
|
|
%extern
|
|
public export
|
|
void : Void -> a
|
|
|
|
export
|
|
Uninhabited Void where
|
|
uninhabited = id
|
|
|
|
public export
|
|
absurd : Uninhabited t => (h : t) -> a
|
|
absurd h = void (uninhabited h)
|
|
|
|
public export
|
|
Not : Type -> Type
|
|
Not x = x -> Void
|
|
|
|
--------------
|
|
-- BOOLEANS --
|
|
--------------
|
|
|
|
public export
|
|
data Bool = True | False
|
|
|
|
public export
|
|
not : Bool -> Bool
|
|
not True = False
|
|
not False = True
|
|
|
|
public export
|
|
(&&) : Bool -> Lazy Bool -> Bool
|
|
(&&) True x = x
|
|
(&&) False x = False
|
|
|
|
public export
|
|
(||) : Bool -> Lazy Bool -> Bool
|
|
(||) True x = True
|
|
(||) False x = x
|
|
|
|
%inline
|
|
public export
|
|
intToBool : Int -> Bool
|
|
intToBool 0 = False
|
|
intToBool x = True
|
|
|
|
------------------------
|
|
-- EQUALITY, ORDERING --
|
|
------------------------
|
|
|
|
public export
|
|
interface Eq ty where
|
|
(==) : ty -> ty -> Bool
|
|
(/=) : ty -> ty -> Bool
|
|
|
|
x == y = not (x /= y)
|
|
x /= y = not (x == y)
|
|
|
|
public export
|
|
Eq () where
|
|
_ == _ = True
|
|
|
|
public export
|
|
Eq Bool where
|
|
True == True = True
|
|
False == False = True
|
|
_ == _ = False
|
|
|
|
public export
|
|
Eq Int where
|
|
x == y = intToBool (prim__eq_Int x y)
|
|
|
|
public export
|
|
Eq Integer where
|
|
x == y = intToBool (prim__eq_Integer x y)
|
|
|
|
public export
|
|
Eq Double where
|
|
x == y = intToBool (prim__eq_Double x y)
|
|
|
|
public export
|
|
Eq Char where
|
|
x == y = intToBool (prim__eq_Char x y)
|
|
|
|
public export
|
|
Eq String where
|
|
x == y = intToBool (prim__eq_String x y)
|
|
|
|
public export
|
|
Eq a => Eq b => Eq (a, b) where
|
|
(x1, y1) == (x2, y2) = x1 == x2 && y1 == y2
|
|
|
|
public export
|
|
data Ordering = LT | EQ | GT
|
|
|
|
public export
|
|
Eq Ordering where
|
|
LT == LT = True
|
|
EQ == EQ = True
|
|
GT == GT = True
|
|
_ == _ = False
|
|
|
|
public export
|
|
interface Eq ty => Ord ty where
|
|
compare : ty -> ty -> Ordering
|
|
|
|
(<) : ty -> ty -> Bool
|
|
(<) x y = compare x y == LT
|
|
|
|
(>) : ty -> ty -> Bool
|
|
(>) x y = compare x y == GT
|
|
|
|
(<=) : ty -> ty -> Bool
|
|
(<=) x y = compare x y /= GT
|
|
|
|
(>=) : ty -> ty -> Bool
|
|
(>=) x y = compare x y /= LT
|
|
|
|
max : ty -> ty -> ty
|
|
max x y = if x > y then x else y
|
|
|
|
min : ty -> ty -> ty
|
|
min x y = if (x < y) then x else y
|
|
|
|
public export
|
|
Ord () where
|
|
compare _ _ = EQ
|
|
|
|
public export
|
|
Ord Bool where
|
|
compare False False = EQ
|
|
compare False True = LT
|
|
compare True False = GT
|
|
compare True True = EQ
|
|
|
|
public export
|
|
Ord Int where
|
|
compare x y = if x < y then LT else if x == y then EQ else GT
|
|
|
|
(<) x y = intToBool (prim__lt_Int x y)
|
|
(<=) x y = intToBool (prim__lte_Int x y)
|
|
(>) x y = intToBool (prim__gt_Int x y)
|
|
(>=) x y = intToBool (prim__gte_Int x y)
|
|
|
|
public export
|
|
Ord Integer where
|
|
compare x y = if x < y then LT else if x == y then EQ else GT
|
|
|
|
(<) x y = intToBool (prim__lt_Integer x y)
|
|
(<=) x y = intToBool (prim__lte_Integer x y)
|
|
(>) x y = intToBool (prim__gt_Integer x y)
|
|
(>=) x y = intToBool (prim__gte_Integer x y)
|
|
|
|
public export
|
|
Ord Double where
|
|
compare x y = if x < y then LT else if x == y then EQ else GT
|
|
|
|
(<) x y = intToBool (prim__lt_Double x y)
|
|
(<=) x y = intToBool (prim__lte_Double x y)
|
|
(>) x y = intToBool (prim__gt_Double x y)
|
|
(>=) x y = intToBool (prim__gte_Double x y)
|
|
|
|
public export
|
|
Ord String where
|
|
compare x y = if x < y then LT else if x == y then EQ else GT
|
|
|
|
(<) x y = intToBool (prim__lt_String x y)
|
|
(<=) x y = intToBool (prim__lte_String x y)
|
|
(>) x y = intToBool (prim__gt_String x y)
|
|
(>=) x y = intToBool (prim__gte_String x y)
|
|
|
|
public export
|
|
Ord Char where
|
|
compare x y = if x < y then LT else if x == y then EQ else GT
|
|
|
|
(<) x y = intToBool (prim__lt_Char x y)
|
|
(<=) x y = intToBool (prim__lte_Char x y)
|
|
(>) x y = intToBool (prim__gt_Char x y)
|
|
(>=) x y = intToBool (prim__gte_Char x y)
|
|
|
|
public export
|
|
Ord a => Ord b => Ord (a, b) where
|
|
compare (x1, y1) (x2, y2)
|
|
= if x1 /= x2 then compare x1 x2
|
|
else compare y1 y2
|
|
|
|
------------------------
|
|
-- NUMERIC INTERFACES --
|
|
------------------------
|
|
|
|
%integerLit fromInteger
|
|
|
|
public export
|
|
interface Num ty where
|
|
(+) : ty -> ty -> ty
|
|
(*) : ty -> ty -> ty
|
|
fromInteger : Integer -> ty
|
|
|
|
%allow_overloads fromInteger
|
|
|
|
public export
|
|
interface Num ty => Neg ty where
|
|
negate : ty -> ty
|
|
(-) : ty -> ty -> ty
|
|
|
|
public export
|
|
interface Num ty => Abs ty where
|
|
abs : ty -> ty
|
|
|
|
public export
|
|
interface Num ty => Fractional ty where
|
|
(/) : ty -> ty -> ty
|
|
recip : ty -> ty
|
|
|
|
recip x = 1 / x
|
|
|
|
public export
|
|
interface Num ty => Integral ty where
|
|
div : ty -> ty -> ty
|
|
mod : ty -> ty -> ty
|
|
|
|
----- instances for primitives
|
|
-- Integer
|
|
|
|
public export
|
|
Num Integer where
|
|
(+) = prim__add_Integer
|
|
(*) = prim__mul_Integer
|
|
fromInteger = id
|
|
|
|
Neg Integer where
|
|
negate x = prim__sub_Integer 0 x
|
|
(-) = prim__sub_Integer
|
|
|
|
Abs Integer where
|
|
abs x = if x < 0 then -x else x
|
|
|
|
Integral Integer where
|
|
div x y
|
|
= case y == 0 of
|
|
False => prim__div_Integer x y
|
|
mod x y
|
|
= case y == 0 of
|
|
False => prim__mod_Integer x y
|
|
|
|
-- This allows us to pick integer as a default at the end of elaboration if
|
|
-- all other possibilities fail. I don't plan to provide a nicer syntax for
|
|
-- this...
|
|
%defaulthint
|
|
public export
|
|
defaultInteger : Num Integer
|
|
defaultInteger = %search
|
|
|
|
-- Int
|
|
|
|
public export
|
|
Num Int where
|
|
(+) = prim__add_Int
|
|
(*) = prim__mul_Int
|
|
fromInteger = prim__cast_IntegerInt
|
|
|
|
Neg Int where
|
|
negate x = prim__sub_Int 0 x
|
|
(-) = prim__sub_Int
|
|
|
|
Abs Int where
|
|
abs x = if x < 0 then -x else x
|
|
|
|
Integral Int where
|
|
div x y
|
|
= case y == 0 of
|
|
False => prim__div_Int x y
|
|
mod x y
|
|
= case y == 0 of
|
|
False => prim__mod_Int x y
|
|
|
|
-- Double
|
|
|
|
public export
|
|
Num Double where
|
|
(+) = prim__add_Double
|
|
(*) = prim__mul_Double
|
|
fromInteger = prim__cast_IntegerDouble
|
|
|
|
Neg Double where
|
|
negate x = prim__negate_Double x
|
|
(-) = prim__sub_Double
|
|
|
|
Abs Double where
|
|
abs x = if x < 0 then -x else x
|
|
|
|
Fractional Double where
|
|
(/) = prim__div_Double
|
|
|
|
-------------
|
|
-- ALGEBRA --
|
|
-------------
|
|
|
|
public export
|
|
interface Semigroup ty where
|
|
(<+>) : ty -> ty -> ty
|
|
|
|
public export
|
|
interface Semigroup ty => Monoid ty where
|
|
neutral : ty
|
|
|
|
---------------------------------
|
|
-- FUNCTOR, APPLICATIVE, MONAD --
|
|
---------------------------------
|
|
|
|
public export
|
|
interface Functor f where
|
|
map : (a -> b) -> f a -> f b
|
|
|
|
public export
|
|
(<$>) : Functor f => (func : a -> b) -> f a -> f b
|
|
(<$>) func x = map func x
|
|
|
|
public export
|
|
interface Functor f => Applicative f where
|
|
pure : a -> f a
|
|
(<*>) : f (a -> b) -> f a -> f b
|
|
|
|
public export
|
|
(<*) : Applicative f => f a -> f b -> f a
|
|
a <* b = map const a <*> b
|
|
|
|
public export
|
|
(*>) : Applicative f => f a -> f b -> f b
|
|
a *> b = map (const id) a <*> b
|
|
|
|
%allow_overloads pure
|
|
%allow_overloads (<*)
|
|
%allow_overloads (*>)
|
|
|
|
public export
|
|
interface Applicative f => Alternative f where
|
|
empty : f a
|
|
(<|>) : f a -> f a -> f a
|
|
|
|
public export
|
|
interface Applicative m => Monad m where
|
|
(>>=) : m a -> (a -> m b) -> m b
|
|
join : m (m a) -> m a
|
|
|
|
-- default implementations
|
|
(>>=) x f = join (f <$> x)
|
|
join x = x >>= id
|
|
|
|
%allow_overloads (>>=)
|
|
|
|
public export
|
|
guard : Alternative f => Bool -> f ()
|
|
guard x = if x then pure () else empty
|
|
|
|
public export
|
|
when : Applicative f => Bool -> Lazy (f ()) -> f ()
|
|
when True f = f
|
|
when False f = pure ()
|
|
|
|
---------------------------
|
|
-- FOLDABLE, TRAVERSABLE --
|
|
---------------------------
|
|
|
|
public export
|
|
interface Foldable (t : Type -> Type) where
|
|
foldr : (func : elem -> acc -> acc) -> (init : acc) -> (input : t elem) -> acc
|
|
foldl : (func : acc -> elem -> acc) -> (init : acc) -> (input : t elem) -> acc
|
|
foldl f z t = foldr (flip (.) . flip f) id t z
|
|
|
|
public export
|
|
concat : (Foldable t, Monoid a) => t a -> a
|
|
concat = foldr (<+>) neutral
|
|
|
|
public export
|
|
concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m
|
|
concatMap f = foldr ((<+>) . f) neutral
|
|
|
|
public export
|
|
and : Foldable t => t (Lazy Bool) -> Bool
|
|
and = foldl (&&) True
|
|
|
|
public export
|
|
or : Foldable t => t (Lazy Bool) -> Bool
|
|
or = foldl (||) False
|
|
|
|
public export
|
|
any : Foldable t => (a -> Bool) -> t a -> Bool
|
|
any p = foldl (\x,y => x || p y) False
|
|
|
|
public export
|
|
all : Foldable t => (a -> Bool) -> t a -> Bool
|
|
all p = foldl (\x,y => x && p y) True
|
|
|
|
public export
|
|
sum : (Foldable t, Num a) => t a -> a
|
|
sum = foldr (+) 0
|
|
|
|
public export
|
|
product : (Foldable t, Num a) => t a -> a
|
|
product = foldr (*) 1
|
|
|
|
-----------
|
|
-- NATS ---
|
|
-----------
|
|
|
|
public export
|
|
data Nat = Z | S Nat
|
|
|
|
%name Nat k, j, i
|
|
|
|
public export
|
|
integerToNat : Integer -> Nat
|
|
integerToNat x
|
|
= if intToBool (prim__eq_Integer x 0)
|
|
then Z
|
|
else S (assert_total (integerToNat (prim__sub_Integer x 1)))
|
|
|
|
-- Define separately so we can spot the name when optimising Nats
|
|
public export
|
|
plus : Nat -> Nat -> Nat
|
|
plus Z y = y
|
|
plus (S k) y = S (plus k y)
|
|
|
|
public export
|
|
mult : Nat -> Nat -> Nat
|
|
mult Z y = Z
|
|
mult (S k) y = plus y (mult k y)
|
|
|
|
public export
|
|
Num Nat where
|
|
(+) = plus
|
|
(*) = mult
|
|
|
|
fromInteger x = integerToNat x
|
|
|
|
public export
|
|
Eq Nat where
|
|
Z == Z = True
|
|
S j == S k = j == k
|
|
_ == _ = False
|
|
|
|
public export
|
|
Ord Nat where
|
|
compare Z Z = EQ
|
|
compare Z (S k) = LT
|
|
compare (S k) Z = GT
|
|
compare (S j) (S k) = compare j k
|
|
|
|
public export
|
|
natToInteger : Nat -> Integer
|
|
natToInteger Z = 0
|
|
natToInteger (S k) = 1 + natToInteger k
|
|
|
|
-----------
|
|
-- MAYBE --
|
|
-----------
|
|
|
|
public export
|
|
data Maybe : (ty : Type) -> Type where
|
|
Nothing : Maybe ty
|
|
Just : (1 x : ty) -> Maybe ty
|
|
|
|
public export
|
|
maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b
|
|
maybe n j Nothing = n
|
|
maybe n j (Just x) = j x
|
|
|
|
public export
|
|
Eq a => Eq (Maybe a) where
|
|
Nothing == Nothing = True
|
|
Nothing == (Just _) = False
|
|
(Just _) == Nothing = False
|
|
(Just a) == (Just b) = a == b
|
|
|
|
public export
|
|
Ord a => Ord (Maybe a) where
|
|
compare Nothing Nothing = EQ
|
|
compare Nothing (Just _) = LT
|
|
compare (Just _) Nothing = GT
|
|
compare (Just a) (Just b) = compare a b
|
|
|
|
public export
|
|
Semigroup (Maybe a) where
|
|
Nothing <+> m = m
|
|
(Just x) <+> _ = Just x
|
|
|
|
public export
|
|
Monoid (Maybe a) where
|
|
neutral = Nothing
|
|
|
|
public export
|
|
Functor Maybe where
|
|
map f (Just x) = Just (f x)
|
|
map f Nothing = Nothing
|
|
|
|
public export
|
|
Applicative Maybe where
|
|
pure = Just
|
|
|
|
Just f <*> Just a = Just (f a)
|
|
_ <*> _ = Nothing
|
|
|
|
public export
|
|
Alternative Maybe where
|
|
empty = Nothing
|
|
|
|
(Just x) <|> _ = Just x
|
|
Nothing <|> v = v
|
|
|
|
public export
|
|
Monad Maybe where
|
|
Nothing >>= k = Nothing
|
|
(Just x) >>= k = k x
|
|
|
|
public export
|
|
Foldable Maybe where
|
|
foldr _ z Nothing = z
|
|
foldr f z (Just x) = f x z
|
|
|
|
---------
|
|
-- DEC --
|
|
---------
|
|
|
|
public export
|
|
data Dec : Type -> Type where
|
|
Yes : (prf : prop) -> Dec prop
|
|
No : (contra : prop -> Void) -> Dec prop
|
|
|
|
------------
|
|
-- EITHER --
|
|
------------
|
|
|
|
public export
|
|
data Either : (a : Type) -> (b : Type) -> Type where
|
|
Left : forall a, b. (1 x : a) -> Either a b
|
|
Right : forall a, b. (1 x : b) -> Either a b
|
|
|
|
public export
|
|
either : Lazy (a -> c) -> Lazy (b -> c) -> Either a b -> c
|
|
either l r (Left x) = l x
|
|
either l r (Right x) = r x
|
|
|
|
public export
|
|
(Eq a, Eq b) => Eq (Either a b) where
|
|
Left x == Left x' = x == x'
|
|
Right x == Right x' = x == x'
|
|
_ == _ = False
|
|
|
|
public export
|
|
Functor (Either e) where
|
|
map f (Left x) = Left x
|
|
map f (Right x) = Right (f x)
|
|
|
|
public export
|
|
Applicative (Either e) where
|
|
pure = Right
|
|
|
|
(Left a) <*> _ = Left a
|
|
(Right f) <*> (Right r) = Right (f r)
|
|
(Right _) <*> (Left l) = Left l
|
|
|
|
public export
|
|
Monad (Either e) where
|
|
(Left n) >>= _ = Left n
|
|
(Right r) >>= f = f r
|
|
|
|
-----------
|
|
-- LISTS --
|
|
-----------
|
|
|
|
public export
|
|
data List a = Nil | (::) a (List a)
|
|
|
|
%name List xs, ys, zs
|
|
|
|
public export
|
|
Eq a => Eq (List a) where
|
|
[] == [] = True
|
|
x :: xs == y :: ys = x == y && xs == ys
|
|
_ == _ = False
|
|
|
|
public export
|
|
Ord a => Ord (List a) where
|
|
compare [] [] = EQ
|
|
compare [] (x :: xs) = LT
|
|
compare (x :: xs) [] = GT
|
|
compare (x :: xs) (y ::ys)
|
|
= case compare x y of
|
|
EQ => compare xs ys
|
|
c => c
|
|
|
|
namespace List
|
|
public export
|
|
(++) : List a -> List a -> List a
|
|
[] ++ ys = ys
|
|
(x :: xs) ++ ys = x :: xs ++ ys
|
|
|
|
public export
|
|
Functor List where
|
|
map f [] = []
|
|
map f (x :: xs) = f x :: map f xs
|
|
|
|
public export
|
|
Semigroup (List a) where
|
|
(<+>) = (++)
|
|
|
|
public export
|
|
Monoid (List a) where
|
|
neutral = []
|
|
|
|
public export
|
|
Foldable List where
|
|
foldr c n [] = n
|
|
foldr c n (x::xs) = c x (foldr c n xs)
|
|
|
|
foldl f q [] = q
|
|
foldl f q (x::xs) = foldl f (f q x) xs
|
|
|
|
public export
|
|
Applicative List where
|
|
pure x = [x]
|
|
fs <*> vs = concatMap (\f => map f vs) fs
|
|
|
|
public export
|
|
Alternative List where
|
|
empty = []
|
|
(<|>) = (++)
|
|
|
|
public export
|
|
Monad List where
|
|
m >>= f = concatMap f m
|
|
|
|
public export
|
|
elem : Eq a => a -> List a -> Bool
|
|
x `elem` [] = False
|
|
x `elem` (y :: ys) = if x == y then True else x `elem` ys
|
|
|
|
-------------
|
|
-- STREAMS --
|
|
-------------
|
|
|
|
namespace Stream
|
|
public export
|
|
data Stream : Type -> Type where
|
|
(::) : a -> Inf (Stream a) -> Stream a
|
|
|
|
public export
|
|
Functor Stream where
|
|
map f (x :: xs) = f x :: map f xs
|
|
|
|
public export
|
|
head : Stream a -> a
|
|
head (x :: xs) = x
|
|
|
|
public export
|
|
tail : Stream a -> Stream a
|
|
tail (x :: xs) = xs
|
|
|
|
public export
|
|
take : Nat -> Stream a -> List a
|
|
take Z xs = []
|
|
take (S k) (x :: xs) = x :: take k xs
|
|
|
|
-------------
|
|
-- STRINGS --
|
|
-------------
|
|
|
|
namespace Strings
|
|
public export
|
|
(++) : (1 x : String) -> (1 y : String) -> String
|
|
x ++ y = prim__strAppend x y
|
|
|
|
public export
|
|
length : String -> Nat
|
|
length str = fromInteger (prim__cast_IntInteger (prim__strLength str))
|
|
|
|
public export
|
|
reverse : String -> String
|
|
reverse = prim__strReverse
|
|
|
|
public export
|
|
substr : Nat -> Nat -> String -> String
|
|
substr s e = prim__strSubstr (prim__cast_IntegerInt (natToInteger s))
|
|
(prim__cast_IntegerInt (natToInteger e))
|
|
|
|
public export
|
|
strCons : Char -> String -> String
|
|
strCons = prim__strCons
|
|
|
|
public export
|
|
strUncons : String -> Maybe (Char, String)
|
|
strUncons "" = Nothing
|
|
strUncons str = Just (prim__strHead str, prim__strTail str)
|
|
|
|
export
|
|
pack : List Char -> String
|
|
pack [] = ""
|
|
pack (x :: xs) = strCons x (pack xs)
|
|
|
|
export
|
|
fastPack : List Char -> String
|
|
fastPack xs
|
|
= unsafePerformIO (schemeCall String "string" (toFArgs xs))
|
|
where
|
|
toFArgs : List Char -> FArgList
|
|
toFArgs [] = []
|
|
toFArgs (x :: xs) = x :: toFArgs xs
|
|
|
|
export
|
|
unpack : String -> List Char
|
|
unpack str = unpack' 0 (prim__cast_IntegerInt (natToInteger (length str))) str
|
|
where
|
|
unpack' : Int -> Int -> String -> List Char
|
|
unpack' pos len str
|
|
= if pos >= len
|
|
then []
|
|
else (prim__strIndex str pos) :: unpack' (pos + 1) len str
|
|
|
|
|
|
public export
|
|
Semigroup String where
|
|
(<+>) = (++)
|
|
|
|
public export
|
|
Monoid String where
|
|
neutral = ""
|
|
|
|
----------------
|
|
-- CHARACTERS --
|
|
----------------
|
|
public export
|
|
isUpper : Char -> Bool
|
|
isUpper x = x >= 'A' && x <= 'Z'
|
|
|
|
public export
|
|
isLower : Char -> Bool
|
|
isLower x = x >= 'a' && x <= 'z'
|
|
|
|
public export
|
|
isAlpha : Char -> Bool
|
|
isAlpha x = isUpper x || isLower x
|
|
|
|
public export
|
|
isDigit : Char -> Bool
|
|
isDigit x = (x >= '0' && x <= '9')
|
|
|
|
public export
|
|
isAlphaNum : Char -> Bool
|
|
isAlphaNum x = isDigit x || isAlpha x
|
|
|
|
public export
|
|
isSpace : Char -> Bool
|
|
isSpace x
|
|
= x == ' ' || x == '\t' || x == '\r' ||
|
|
x == '\n' || x == '\f' || x == '\v' ||
|
|
x == '\xa0'
|
|
|
|
public export
|
|
isNL : Char -> Bool
|
|
isNL x = x == '\r' || x == '\n'
|
|
|
|
public export
|
|
toUpper : Char -> Char
|
|
toUpper x
|
|
= if (isLower x)
|
|
then prim__cast_IntChar (prim__cast_CharInt x - 32)
|
|
else x
|
|
|
|
public export
|
|
toLower : Char -> Char
|
|
toLower x
|
|
= if (isUpper x)
|
|
then prim__cast_IntChar (prim__cast_CharInt x + 32)
|
|
else x
|
|
|
|
public export
|
|
isHexDigit : Char -> Bool
|
|
isHexDigit x = elem (toUpper x) hexChars where
|
|
hexChars : List Char
|
|
hexChars
|
|
= ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
|
|
'A', 'B', 'C', 'D', 'E', 'F']
|
|
|
|
public export
|
|
isOctDigit : Char -> Bool
|
|
isOctDigit x = (x >= '0' && x <= '7')
|
|
|
|
public export
|
|
isControl : Char -> Bool
|
|
isControl x
|
|
= (x >= '\x0000' && x <= '\x001f')
|
|
|| (x >= '\x007f' && x <= '\x009f')
|
|
|
|
----------
|
|
-- SHOW --
|
|
----------
|
|
|
|
public export
|
|
data Prec = Open | Equal | Dollar | Backtick | User Nat | PrefixMinus | App
|
|
|
|
public export
|
|
precCon : Prec -> Integer
|
|
precCon Open = 0
|
|
precCon Equal = 1
|
|
precCon Dollar = 2
|
|
precCon Backtick = 3
|
|
precCon (User n) = 4
|
|
precCon PrefixMinus = 5
|
|
precCon App = 6
|
|
|
|
Eq Prec where
|
|
(==) (User m) (User n) = m == n
|
|
(==) x y = precCon x == precCon y
|
|
|
|
Ord Prec where
|
|
compare (User m) (User n) = compare m n
|
|
compare x y = compare (precCon x) (precCon y)
|
|
|
|
public export
|
|
interface Show ty where
|
|
show : (x : ty) -> String
|
|
show x = showPrec Open x
|
|
|
|
showPrec : (d : Prec) -> (x : ty) -> String
|
|
showPrec _ x = show x
|
|
|
|
showParens : (b : Bool) -> String -> String
|
|
showParens False s = s
|
|
showParens True s = "(" ++ s ++ ")"
|
|
|
|
export
|
|
showCon : (d : Prec) -> (conName : String) -> (shownArgs : String) -> String
|
|
showCon d conName shownArgs = showParens (d >= App) (conName ++ shownArgs)
|
|
|
|
export
|
|
showArg : Show a => (x : a) -> String
|
|
showArg x = " " ++ showPrec App x
|
|
|
|
firstCharIs : (Char -> Bool) -> String -> Bool
|
|
firstCharIs p "" = False
|
|
firstCharIs p str = p (prim__strHead str)
|
|
|
|
primNumShow : (a -> String) -> Prec -> a -> String
|
|
primNumShow f d x = let str = f x in showParens (d >= PrefixMinus && firstCharIs (== '-') str) str
|
|
|
|
export
|
|
Show Int where
|
|
showPrec = primNumShow prim__cast_IntString
|
|
|
|
export
|
|
Show Integer where
|
|
showPrec = primNumShow prim__cast_IntegerString
|
|
|
|
export
|
|
Show Double where
|
|
showPrec = primNumShow prim__cast_DoubleString
|
|
|
|
protectEsc : (Char -> Bool) -> String -> String -> String
|
|
protectEsc p f s = f ++ (if firstCharIs p s then "\\&" else "") ++ s
|
|
|
|
showLitChar : Char -> String -> String
|
|
showLitChar '\a' = ("\\a" ++)
|
|
showLitChar '\b' = ("\\b" ++)
|
|
showLitChar '\f' = ("\\f" ++)
|
|
showLitChar '\n' = ("\\n" ++)
|
|
showLitChar '\r' = ("\\r" ++)
|
|
showLitChar '\t' = ("\\t" ++)
|
|
showLitChar '\v' = ("\\v" ++)
|
|
showLitChar '\SO' = protectEsc (== 'H') "\\SO"
|
|
showLitChar '\DEL' = ("\\DEL" ++)
|
|
showLitChar '\\' = ("\\\\" ++)
|
|
showLitChar c
|
|
= case getAt (fromInteger (prim__cast_CharInteger c)) asciiTab of
|
|
Just k => strCons '\\' . (k ++)
|
|
Nothing => if (c > '\DEL')
|
|
then strCons '\\' . protectEsc isDigit (show (prim__cast_CharInt c))
|
|
else strCons c
|
|
where
|
|
asciiTab : List String
|
|
asciiTab
|
|
= ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
|
|
"BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
|
|
"DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
|
|
"CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US"]
|
|
|
|
getAt : Nat -> List String -> Maybe String
|
|
getAt Z (x :: xs) = Just x
|
|
getAt (S k) (x :: xs) = getAt k xs
|
|
getAt _ [] = Nothing
|
|
|
|
showLitString : List Char -> String -> String
|
|
showLitString [] = id
|
|
showLitString ('"'::cs) = ("\\\"" ++) . showLitString cs
|
|
showLitString (c ::cs) = (showLitChar c) . showLitString cs
|
|
|
|
export
|
|
Show Char where
|
|
show '\'' = "'\\''"
|
|
show c = strCons '\'' (showLitChar c "'")
|
|
|
|
export
|
|
Show String where
|
|
show cs = strCons '"' (showLitString (unpack cs) "\"")
|
|
|
|
export
|
|
Show Nat where
|
|
show n = show (the Integer (natToInteger n))
|
|
|
|
export
|
|
Show Bool where
|
|
show True = "True"
|
|
show False = "False"
|
|
|
|
export
|
|
Show () where
|
|
show () = "()"
|
|
|
|
export
|
|
(Show a, Show b) => Show (a, b) where
|
|
show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")"
|
|
|
|
export
|
|
(Show a, {y : a} -> Show (p y)) => Show (DPair a p) where
|
|
show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"
|
|
|
|
export
|
|
Show a => Show (List a) where
|
|
show xs = "[" ++ show' "" xs ++ "]"
|
|
where
|
|
show' : String -> List a -> String
|
|
show' acc [] = acc
|
|
show' acc [x] = acc ++ show x
|
|
show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs
|
|
|
|
export
|
|
Show a => Show (Maybe a) where
|
|
showPrec d Nothing = "Nothing"
|
|
showPrec d (Just x) = showCon d "Just" (showArg x)
|
|
|
|
--------
|
|
-- IO --
|
|
--------
|
|
|
|
public export
|
|
Functor IO where
|
|
map f io = io_bind io (\b => io_pure (f b))
|
|
|
|
public export
|
|
Applicative IO where
|
|
pure x = io_pure x
|
|
f <*> a
|
|
= io_bind f (\f' =>
|
|
io_bind a (\a' =>
|
|
io_pure (f' a')))
|
|
|
|
public export
|
|
Monad IO where
|
|
b >>= k = io_bind b k
|
|
|
|
export
|
|
print : Show a => a -> IO ()
|
|
print x = putStr $ show x
|
|
|
|
export
|
|
printLn : Show a => a -> IO ()
|
|
printLn x = putStrLn $ show x
|
|
|
|
-----------
|
|
-- CASTS --
|
|
-----------
|
|
|
|
-- Casts between primitives only here. They might be lossy.
|
|
|
|
-- To String
|
|
|
|
public export
|
|
interface Cast from to where
|
|
cast : from -> to
|
|
|
|
export
|
|
Cast Int String where
|
|
cast = prim__cast_IntString
|
|
|
|
export
|
|
Cast Integer String where
|
|
cast = prim__cast_IntegerString
|
|
|
|
export
|
|
Cast Char String where
|
|
cast = prim__cast_CharString
|
|
|
|
export
|
|
Cast Double String where
|
|
cast = prim__cast_DoubleString
|
|
|
|
-- To Integer
|
|
|
|
export
|
|
Cast Int Integer where
|
|
cast = prim__cast_IntInteger
|
|
|
|
export
|
|
Cast Char Integer where
|
|
cast = prim__cast_CharInteger
|
|
|
|
export
|
|
Cast Double Integer where
|
|
cast = prim__cast_DoubleInteger
|
|
|
|
export
|
|
Cast String Integer where
|
|
cast = prim__cast_StringInteger
|
|
|
|
-- To Int
|
|
|
|
export
|
|
Cast Integer Int where
|
|
cast = prim__cast_IntegerInt
|
|
|
|
export
|
|
Cast Char Int where
|
|
cast = prim__cast_CharInt
|
|
|
|
export
|
|
Cast Double Int where
|
|
cast = prim__cast_DoubleInt
|
|
|
|
export
|
|
Cast String Int where
|
|
cast = prim__cast_StringInt
|
|
|
|
-- To Char
|
|
|
|
export
|
|
Cast Int Char where
|
|
cast = prim__cast_IntChar
|
|
|
|
-- To Double
|
|
|
|
export
|
|
Cast Int Double where
|
|
cast = prim__cast_IntDouble
|
|
|
|
export
|
|
Cast Integer Double where
|
|
cast = prim__cast_IntegerDouble
|
|
|
|
export
|
|
Cast String Double where
|
|
cast = prim__cast_StringDouble
|