{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}

-- | General tagless expressions

module Dino.Expression where

import Dino.Prelude
import qualified Prelude

import Control.Applicative (liftA, liftA2)
import Control.Error (headMay)
import Control.Monad ((>=>), ap, foldM)
import Control.Monad.Loops (dropWhileM, firstM)
import Data.Bifunctor (Bifunctor (..))
import Data.List ((\\))
import Data.String (IsString (..))
import qualified GHC.Records as GHC
import GHC.Stack

import Dino.Types



--------------------------------------------------------------------------------
-- * Expression classes and constructs
--------------------------------------------------------------------------------

----------------------------------------
-- ** Constants
----------------------------------------

-- | Constant expressions
--
-- The default implementation is for 'Applicative' interpretations.
class ConstExp e where
  -- | Make a Dino literal from a Haskell value
  lit :: DinoType a => a -> e a

  default lit :: Applicative e => a -> e a
  lit = a -> e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

true, false :: ConstExp e => e Bool
true :: e Bool
true = Bool -> e Bool
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit Bool
True
false :: e Bool
false = Bool -> e Bool
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit Bool
False

-- | Constant text expression
--
-- With @OverloadedStrings@ enabled, text literals can be written simply as
-- @"..."@.
text :: ConstExp e => Text -> e Text
text :: Text -> e Text
text = Text -> e Text
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit



----------------------------------------
-- ** Numeric expressions
----------------------------------------

-- | Numeric expressions
--
-- The default implementations are for 'Applicative' interpretations.
class NumExp e where
  add   :: Num a => e a -> e a -> e a
  sub   :: Num a => e a -> e a -> e a
  mul   :: Num a => e a -> e a -> e a
  absE  :: Num a => e a -> e a
  signE :: Num a => e a -> e a

  -- | Convert an integer to any numeric type
  fromIntegral :: (Integral a, DinoType b, Num b) => e a -> e b

  -- | @`floor` x@ returns the greatest integer not greater than @x@
  floor :: (RealFrac a, DinoType b, Integral b) => e a -> e b

  -- | @`truncate` x@ returns the integer nearest @x@ between zero and @x@
  truncate :: (RealFrac a, DinoType b, Integral b) => e a -> e b

  -- | Round to the specified number of decimals
  roundN :: RealFrac a => Int -> e a -> e a
    -- TODO This function doesn't make much sense for non-decimal
    -- representations. Use a decimal representation.

  default add          :: (Applicative e, Num a) => e a -> e a -> e a
  default sub          :: (Applicative e, Num a) => e a -> e a -> e a
  default mul          :: (Applicative e, Num a) => e a -> e a -> e a
  default absE         :: (Applicative e, Num a) => e a -> e a
  default signE        :: (Applicative e, Num a) => e a -> e a
  default fromIntegral :: (Applicative e, Integral a, Num b) => e a -> e b
  default floor        :: (Applicative e, RealFrac a, Integral b) => e a -> e b
  default truncate     :: (Applicative e, RealFrac a, Integral b) => e a -> e b
  default roundN       :: (Applicative e, RealFrac a) => Int -> e a -> e a

  add          = (a -> a -> a) -> e a -> e a -> e a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Num a => a -> a -> a
(+)
  sub          = (a -> a -> a) -> e a -> e a -> e a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (-)
  mul          = (a -> a -> a) -> e a -> e a -> e a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Num a => a -> a -> a
(*)
  absE         = (a -> a) -> e a -> e a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> a
forall a. Num a => a -> a
abs
  signE        = (a -> a) -> e a -> e a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> a
forall a. Num a => a -> a
signum
  fromIntegral = (a -> b) -> e a -> e b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> b
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral
  floor        = (a -> b) -> e a -> e b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (Integer -> b
forall a. Num a => Integer -> a
Prelude.fromInteger (Integer -> b) -> (a -> Integer) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.floor)
  truncate     = (a -> b) -> e a -> e b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (Integer -> b
forall a. Num a => Integer -> a
Prelude.fromInteger (Integer -> b) -> (a -> Integer) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.truncate)
  roundN Int
n     = (a -> a) -> e a -> e a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> a
roundN'
    where
      roundN' :: a -> a
roundN' a
a = (Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a) -> Integer -> a
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
Prelude.round (a -> Integer) -> a -> Integer
forall a b. (a -> b) -> a -> b
$ a
a a -> a -> a
forall a. Num a => a -> a -> a
* (a
10a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n)) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
10.0a -> Int -> a
forall a b. (Fractional a, Integral b) => a -> b -> a
^^Int
n)
        -- https://stackoverflow.com/questions/12450501/round-number-to-specified-number-of-digits#12450771

-- | Convert an 'Integer' to any numeric type
fromInt :: (NumExp e, DinoType a, Num a) => e Integer -> e a
fromInt :: e Integer -> e a
fromInt = e Integer -> e a
forall (e :: * -> *) a b.
(NumExp e, Integral a, DinoType b, Num b) =>
e a -> e b
fromIntegral
  -- We cannot override the name `fromInteger`, since that's used for desugaring
  -- numeric literals.

-- | Fractional expressions
--
-- The default implementation is for 'Applicative' interpretations.
class FracExp e where
  -- | Division
  fdiv :: (Fractional a, Eq a) => e a -> e a -> e a
    -- `Eq` is useful for catching division by zero.

  default fdiv :: (Applicative e, Fractional a) => e a -> e a -> e a
  fdiv = (a -> a -> a) -> e a -> e a -> e a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Fractional a => a -> a -> a
(/)

-- | Division that returns 0 when the denominator is 0
(./) ::
     ( ConstExp e
     , FracExp e
     , CompareExp e
     , CondExpFO e
     , DinoType a
     , Fractional a
     )
  => e a
  -> e a
  -> e a
e a
a ./ :: e a -> e a -> e a
./ e a
b = e Bool -> e a -> e a -> e a
forall (e :: * -> *) a. CondExpFO e => e Bool -> e a -> e a -> e a
ifThenElse (e a
b e a -> e a -> e Bool
forall a (e :: * -> *).
(Eq a, CompareExp e) =>
e a -> e a -> e Bool
== a -> e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit a
0) (a -> e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit a
0) (e a -> e a -> e a
forall (e :: * -> *) a.
(FracExp e, Fractional a, Eq a) =>
e a -> e a -> e a
fdiv e a
a e a
b)



----------------------------------------
-- ** Logic expressions
----------------------------------------

-- | Logic expressions
--
-- The default implementations are for 'Applicative' interpretations.
class LogicExp e where
  not  :: e Bool -> e Bool
  conj :: e Bool -> e Bool -> e Bool
  disj :: e Bool -> e Bool -> e Bool
  xor  :: e Bool -> e Bool -> e Bool

  default not  :: Applicative e => e Bool -> e Bool
  default conj :: Applicative e => e Bool -> e Bool -> e Bool
  default disj :: Applicative e => e Bool -> e Bool -> e Bool
  default xor  :: Applicative e => e Bool -> e Bool -> e Bool

  not  = (Bool -> Bool) -> e Bool -> e Bool
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA Bool -> Bool
Prelude.not
  conj = (Bool -> Bool -> Bool) -> e Bool -> e Bool -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(Prelude.&&)
  disj = (Bool -> Bool -> Bool) -> e Bool -> e Bool -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(Prelude.||)
  xor  = (Bool -> Bool -> Bool) -> e Bool -> e Bool -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(Prelude./=)

(&&), (||) :: LogicExp e => e Bool -> e Bool -> e Bool

&& :: e Bool -> e Bool -> e Bool
(&&) = e Bool -> e Bool -> e Bool
forall (e :: * -> *). LogicExp e => e Bool -> e Bool -> e Bool
conj
|| :: e Bool -> e Bool -> e Bool
(||) = e Bool -> e Bool -> e Bool
forall (e :: * -> *). LogicExp e => e Bool -> e Bool -> e Bool
disj

infixr 3 &&
infixr 2 ||



----------------------------------------
-- ** Comparisons
----------------------------------------

-- | Comparisons
--
-- The default implementations are for 'Applicative' interpretations.
class CompareExp e where
  eq  :: Eq a  => e a -> e a -> e Bool
  neq :: Eq a  => e a -> e a -> e Bool
  lt  :: Ord a => e a -> e a -> e Bool
  gt  :: Ord a => e a -> e a -> e Bool
  lte :: Ord a => e a -> e a -> e Bool
  gte :: Ord a => e a -> e a -> e Bool
  min :: Ord a => e a -> e a -> e a
  max :: Ord a => e a -> e a -> e a

  default eq  :: (Applicative e, Eq a)  => e a -> e a -> e Bool
  default neq :: (Applicative e, Eq a)  => e a -> e a -> e Bool
  default lt  :: (Applicative e, Ord a) => e a -> e a -> e Bool
  default gt  :: (Applicative e, Ord a) => e a -> e a -> e Bool
  default lte :: (Applicative e, Ord a) => e a -> e a -> e Bool
  default gte :: (Applicative e, Ord a) => e a -> e a -> e Bool
  default min :: (Applicative e, Ord a) => e a -> e a -> e a
  default max :: (Applicative e, Ord a) => e a -> e a -> e a

  eq  = (a -> a -> Bool) -> e a -> e a -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(Prelude.==)
  neq = (a -> a -> Bool) -> e a -> e a -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(Prelude./=)
  lt  = (a -> a -> Bool) -> e a -> e a -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.<)
  gt  = (a -> a -> Bool) -> e a -> e a -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.>)
  lte = (a -> a -> Bool) -> e a -> e a -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.<=)
  gte = (a -> a -> Bool) -> e a -> e a -> e Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Prelude.>=)
  min = (a -> a -> a) -> e a -> e a -> e a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Ord a => a -> a -> a
Prelude.min
  max = (a -> a -> a) -> e a -> e a -> e a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Ord a => a -> a -> a
Prelude.max

(==), (/=) :: (Eq a, CompareExp e) => e a -> e a -> e Bool
== :: e a -> e a -> e Bool
(==) = e a -> e a -> e Bool
forall (e :: * -> *) a.
(CompareExp e, Eq a) =>
e a -> e a -> e Bool
eq
/= :: e a -> e a -> e Bool
(/=) = e a -> e a -> e Bool
forall (e :: * -> *) a.
(CompareExp e, Eq a) =>
e a -> e a -> e Bool
neq

(<), (>), (<=), (>=) :: (Ord a, CompareExp e) => e a -> e a -> e Bool
< :: e a -> e a -> e Bool
(<)  = e a -> e a -> e Bool
forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
e a -> e a -> e Bool
lt
> :: e a -> e a -> e Bool
(>)  = e a -> e a -> e Bool
forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
e a -> e a -> e Bool
gt
<= :: e a -> e a -> e Bool
(<=) = e a -> e a -> e Bool
forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
e a -> e a -> e Bool
lte
>= :: e a -> e a -> e Bool
(>=) = e a -> e a -> e Bool
forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
e a -> e a -> e Bool
gte

infix 4 ==, /=, <, >, <=, >=

-- | Check equality against a constant value
(==!) :: (ConstExp e, CompareExp e, DinoType a) => e a -> a -> e Bool
e a
a ==! :: e a -> a -> e Bool
==! a
b = e a
a e a -> e a -> e Bool
forall a (e :: * -> *).
(Eq a, CompareExp e) =>
e a -> e a -> e Bool
== a -> e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit a
b

infix 4 ==!



----------------------------------------
-- ** Conditionals
----------------------------------------

-- | Representation of a case in 'cases'
data a :-> b = a :-> b
  deriving ((a :-> b) -> (a :-> b) -> Bool
((a :-> b) -> (a :-> b) -> Bool)
-> ((a :-> b) -> (a :-> b) -> Bool) -> Eq (a :-> b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => (a :-> b) -> (a :-> b) -> Bool
/= :: (a :-> b) -> (a :-> b) -> Bool
$c/= :: forall a b. (Eq a, Eq b) => (a :-> b) -> (a :-> b) -> Bool
== :: (a :-> b) -> (a :-> b) -> Bool
$c== :: forall a b. (Eq a, Eq b) => (a :-> b) -> (a :-> b) -> Bool
Eq, Int -> (a :-> b) -> ShowS
[a :-> b] -> ShowS
(a :-> b) -> String
(Int -> (a :-> b) -> ShowS)
-> ((a :-> b) -> String) -> ([a :-> b] -> ShowS) -> Show (a :-> b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> (a :-> b) -> ShowS
forall a b. (Show a, Show b) => [a :-> b] -> ShowS
forall a b. (Show a, Show b) => (a :-> b) -> String
showList :: [a :-> b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [a :-> b] -> ShowS
show :: (a :-> b) -> String
$cshow :: forall a b. (Show a, Show b) => (a :-> b) -> String
showsPrec :: Int -> (a :-> b) -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> (a :-> b) -> ShowS
Show, (a :-> a) -> Bool
(a -> m) -> (a :-> a) -> m
(a -> b -> b) -> b -> (a :-> a) -> b
(forall m. Monoid m => (a :-> m) -> m)
-> (forall m a. Monoid m => (a -> m) -> (a :-> a) -> m)
-> (forall m a. Monoid m => (a -> m) -> (a :-> a) -> m)
-> (forall a b. (a -> b -> b) -> b -> (a :-> a) -> b)
-> (forall a b. (a -> b -> b) -> b -> (a :-> a) -> b)
-> (forall b a. (b -> a -> b) -> b -> (a :-> a) -> b)
-> (forall b a. (b -> a -> b) -> b -> (a :-> a) -> b)
-> (forall a. (a -> a -> a) -> (a :-> a) -> a)
-> (forall a. (a -> a -> a) -> (a :-> a) -> a)
-> (forall a. (a :-> a) -> [a])
-> (forall a. (a :-> a) -> Bool)
-> (forall a. (a :-> a) -> Int)
-> (forall a. Eq a => a -> (a :-> a) -> Bool)
-> (forall a. Ord a => (a :-> a) -> a)
-> (forall a. Ord a => (a :-> a) -> a)
-> (forall a. Num a => (a :-> a) -> a)
-> (forall a. Num a => (a :-> a) -> a)
-> Foldable ((:->) a)
forall a. Eq a => a -> (a :-> a) -> Bool
forall a. Num a => (a :-> a) -> a
forall a. Ord a => (a :-> a) -> a
forall m. Monoid m => (a :-> m) -> m
forall a. (a :-> a) -> Bool
forall a. (a :-> a) -> Int
forall a. (a :-> a) -> [a]
forall a. (a -> a -> a) -> (a :-> a) -> a
forall a a. Eq a => a -> (a :-> a) -> Bool
forall a a. Num a => (a :-> a) -> a
forall a a. Ord a => (a :-> a) -> a
forall m a. Monoid m => (a -> m) -> (a :-> a) -> m
forall a m. Monoid m => (a :-> m) -> m
forall a a. (a :-> a) -> Bool
forall a a. (a :-> a) -> Int
forall a a. (a :-> a) -> [a]
forall b a. (b -> a -> b) -> b -> (a :-> a) -> b
forall a b. (a -> b -> b) -> b -> (a :-> a) -> b
forall a a. (a -> a -> a) -> (a :-> a) -> a
forall a m a. Monoid m => (a -> m) -> (a :-> a) -> m
forall a b a. (b -> a -> b) -> b -> (a :-> a) -> b
forall a a b. (a -> b -> b) -> b -> (a :-> a) -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: (a :-> a) -> a
$cproduct :: forall a a. Num a => (a :-> a) -> a
sum :: (a :-> a) -> a
$csum :: forall a a. Num a => (a :-> a) -> a
minimum :: (a :-> a) -> a
$cminimum :: forall a a. Ord a => (a :-> a) -> a
maximum :: (a :-> a) -> a
$cmaximum :: forall a a. Ord a => (a :-> a) -> a
elem :: a -> (a :-> a) -> Bool
$celem :: forall a a. Eq a => a -> (a :-> a) -> Bool
length :: (a :-> a) -> Int
$clength :: forall a a. (a :-> a) -> Int
null :: (a :-> a) -> Bool
$cnull :: forall a a. (a :-> a) -> Bool
toList :: (a :-> a) -> [a]
$ctoList :: forall a a. (a :-> a) -> [a]
foldl1 :: (a -> a -> a) -> (a :-> a) -> a
$cfoldl1 :: forall a a. (a -> a -> a) -> (a :-> a) -> a
foldr1 :: (a -> a -> a) -> (a :-> a) -> a
$cfoldr1 :: forall a a. (a -> a -> a) -> (a :-> a) -> a
foldl' :: (b -> a -> b) -> b -> (a :-> a) -> b
$cfoldl' :: forall a b a. (b -> a -> b) -> b -> (a :-> a) -> b
foldl :: (b -> a -> b) -> b -> (a :-> a) -> b
$cfoldl :: forall a b a. (b -> a -> b) -> b -> (a :-> a) -> b
foldr' :: (a -> b -> b) -> b -> (a :-> a) -> b
$cfoldr' :: forall a a b. (a -> b -> b) -> b -> (a :-> a) -> b
foldr :: (a -> b -> b) -> b -> (a :-> a) -> b
$cfoldr :: forall a a b. (a -> b -> b) -> b -> (a :-> a) -> b
foldMap' :: (a -> m) -> (a :-> a) -> m
$cfoldMap' :: forall a m a. Monoid m => (a -> m) -> (a :-> a) -> m
foldMap :: (a -> m) -> (a :-> a) -> m
$cfoldMap :: forall a m a. Monoid m => (a -> m) -> (a :-> a) -> m
fold :: (a :-> m) -> m
$cfold :: forall a m. Monoid m => (a :-> m) -> m
Foldable, a -> (a :-> b) -> a :-> a
(a -> b) -> (a :-> a) -> a :-> b
(forall a b. (a -> b) -> (a :-> a) -> a :-> b)
-> (forall a b. a -> (a :-> b) -> a :-> a) -> Functor ((:->) a)
forall a b. a -> (a :-> b) -> a :-> a
forall a b. (a -> b) -> (a :-> a) -> a :-> b
forall a a b. a -> (a :-> b) -> a :-> a
forall a a b. (a -> b) -> (a :-> a) -> a :-> b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> (a :-> b) -> a :-> a
$c<$ :: forall a a b. a -> (a :-> b) -> a :-> a
fmap :: (a -> b) -> (a :-> a) -> a :-> b
$cfmap :: forall a a b. (a -> b) -> (a :-> a) -> a :-> b
Functor, Functor ((:->) a)
Foldable ((:->) a)
Functor ((:->) a)
-> Foldable ((:->) a)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> (a :-> a) -> f (a :-> b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    (a :-> f a) -> f (a :-> a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> (a :-> a) -> m (a :-> b))
-> (forall (m :: * -> *) a. Monad m => (a :-> m a) -> m (a :-> a))
-> Traversable ((:->) a)
(a -> f b) -> (a :-> a) -> f (a :-> b)
forall a. Functor ((:->) a)
forall a. Foldable ((:->) a)
forall a (m :: * -> *) a. Monad m => (a :-> m a) -> m (a :-> a)
forall a (f :: * -> *) a.
Applicative f =>
(a :-> f a) -> f (a :-> a)
forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> (a :-> a) -> m (a :-> b)
forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (a :-> a) -> f (a :-> b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => (a :-> m a) -> m (a :-> a)
forall (f :: * -> *) a. Applicative f => (a :-> f a) -> f (a :-> a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> (a :-> a) -> m (a :-> b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (a :-> a) -> f (a :-> b)
sequence :: (a :-> m a) -> m (a :-> a)
$csequence :: forall a (m :: * -> *) a. Monad m => (a :-> m a) -> m (a :-> a)
mapM :: (a -> m b) -> (a :-> a) -> m (a :-> b)
$cmapM :: forall a (m :: * -> *) a b.
Monad m =>
(a -> m b) -> (a :-> a) -> m (a :-> b)
sequenceA :: (a :-> f a) -> f (a :-> a)
$csequenceA :: forall a (f :: * -> *) a.
Applicative f =>
(a :-> f a) -> f (a :-> a)
traverse :: (a -> f b) -> (a :-> a) -> f (a :-> b)
$ctraverse :: forall a (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (a :-> a) -> f (a :-> b)
$cp2Traversable :: forall a. Foldable ((:->) a)
$cp1Traversable :: forall a. Functor ((:->) a)
Traversable)

instance Bifunctor (:->) where
  bimap :: (a -> b) -> (c -> d) -> (a :-> c) -> b :-> d
bimap a -> b
f c -> d
g (a
a :-> c
b) = a -> b
f a
a b -> d -> b :-> d
forall a b. a -> b -> a :-> b
:-> c -> d
g c
b

-- | Construct a case in 'cases', 'match', etc.
--
-- Example:
--
-- @
-- beaufortScale :: _ => `Exp` e a -> `Exp` e `Text`
-- beaufortScale v = `match` v
--   [ (`<` 0.5)   `-->` "calm"
--   , (`<` 13.8)  `-->` "breeze"
--   , (`<` 24.5)  `-->` "gale" ]
--   ( `Otherwise` `-->` "storm" )
-- @
(-->) :: a -> b -> (a :-> b)
--> :: a -> b -> a :-> b
(-->) = a -> b -> a :-> b
forall a b. a -> b -> a :-> b
(:->)

infix 1 :->, -->

-- | Marker for the default case in 'cases'
data Otherwise = Otherwise

-- | Helper class to 'CondExp' containing only first-order constructs
--
-- The reason for having this class is that there are types for which
-- 'CondExpFO' can be derived but 'CondExp' cannot.
class CondExpFO e where
  -- | Construct an optional value that is present
  just :: e a -> e (Maybe a)

  -- | Case expression
  cases ::
       [e Bool :-> e a] -- ^ Guarded expressions
    -> (Otherwise :-> e a) -- ^ Fall-through case
    -> e a

  -- | Case expression without fall-through
  --
  -- Evaluation may fail if the cases are not complete.
  partial_cases ::
       HasCallStack
    => [e Bool :-> e a] -- ^ Guarded expressions
    -> e a

  default just :: Applicative e => e a -> e (Maybe a)
  just = (a -> Maybe a) -> e a -> e (Maybe a)
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA a -> Maybe a
forall a. a -> Maybe a
Just

  default cases :: Monad e => [e Bool :-> e a] -> (Otherwise :-> e a) -> e a
  cases [e Bool :-> e a]
cs (Otherwise
_ :-> e a
d) = do
    Maybe (e Bool :-> e a)
f <- ((e Bool :-> e a) -> e Bool)
-> [e Bool :-> e a] -> e (Maybe (e Bool :-> e a))
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
firstM (\(e Bool
c :-> e a
_) -> e Bool
c) [e Bool :-> e a]
cs
    case Maybe (e Bool :-> e a)
f of
      Maybe (e Bool :-> e a)
Nothing -> e a
d
      Just (e Bool
_ :-> e a
a) -> e a
a

  default partial_cases :: (Monad e, HasCallStack) => [e Bool :-> e a] -> e a
  partial_cases = [e Bool :-> e a] -> e a
forall (e :: * -> *) a.
(CondExpFO e, HasCallStack) =>
[e Bool :-> e a] -> e a
default_partial_cases

-- | Expressions supporting conditionals
--
-- The default implementations are for monadic interpretations.
class CondExpFO e => CondExp e where
  -- | Deconstruct an optional value
  maybe ::
       DinoType a
    => e b -- ^ Result when 'nothing'
    -> (e a -> e b) -- ^ Result when 'just'
    -> e (Maybe a) -- ^ Value to deconstruct
    -> e b

  default maybe :: Monad e => e b -> (e a -> e b) -> e (Maybe a) -> e b
  maybe e b
n e a -> e b
j e (Maybe a)
m = e b -> (a -> e b) -> Maybe a -> e b
forall b a. b -> (a -> b) -> Maybe a -> b
Prelude.maybe e b
n (e a -> e b
j (e a -> e b) -> (a -> e a) -> a -> e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e a
forall (m :: * -> *) a. Monad m => a -> m a
return) (Maybe a -> e b) -> e (Maybe a) -> e b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< e (Maybe a)
m

default_partial_cases :: (CondExpFO e, HasCallStack) => [e Bool :-> e a] -> e a
default_partial_cases :: [e Bool :-> e a] -> e a
default_partial_cases [e Bool :-> e a]
cs =
  [e Bool :-> e a] -> (Otherwise :-> e a) -> e a
forall (e :: * -> *) a.
CondExpFO e =>
[e Bool :-> e a] -> (Otherwise :-> e a) -> e a
cases [e Bool :-> e a]
cs ((Otherwise :-> e a) -> e a) -> (Otherwise :-> e a) -> e a
forall a b. (a -> b) -> a -> b
$ (Otherwise
Otherwise Otherwise -> e a -> Otherwise :-> e a
forall a b. a -> b -> a :-> b
--> String -> e a
forall a. HasCallStack => String -> a
error String
"partial_cases: no matching case")

-- | Construct an optional value that is missing
nothing :: (ConstExp e, DinoType a) => e (Maybe a)
nothing :: e (Maybe a)
nothing = Maybe a -> e (Maybe a)
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit Maybe a
forall a. Maybe a
Nothing

isJust :: (ConstExp e, CondExp e, DinoType a) => e (Maybe a) -> e Bool
isJust :: e (Maybe a) -> e Bool
isJust = e Bool -> (e a -> e Bool) -> e (Maybe a) -> e Bool
forall (e :: * -> *) a b.
(CondExp e, DinoType a) =>
e b -> (e a -> e b) -> e (Maybe a) -> e b
maybe e Bool
forall (e :: * -> *). ConstExp e => e Bool
false (e Bool -> e a -> e Bool
forall a b. a -> b -> a
const e Bool
forall (e :: * -> *). ConstExp e => e Bool
true)

-- | Case expression using Boolean functions for matching
match ::
     CondExpFO e
  => a -- ^ Scrutinee
  -> [(a -> e Bool) :-> e b] -- ^ Cases
  -> (Otherwise :-> e b) -- ^ Fall-through case
  -> e b
match :: a -> [(a -> e Bool) :-> e b] -> (Otherwise :-> e b) -> e b
match a
a = [e Bool :-> e b] -> (Otherwise :-> e b) -> e b
forall (e :: * -> *) a.
CondExpFO e =>
[e Bool :-> e a] -> (Otherwise :-> e a) -> e a
cases ([e Bool :-> e b] -> (Otherwise :-> e b) -> e b)
-> ([(a -> e Bool) :-> e b] -> [e Bool :-> e b])
-> [(a -> e Bool) :-> e b]
-> (Otherwise :-> e b)
-> e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((a -> e Bool) :-> e b) -> e Bool :-> e b)
-> [(a -> e Bool) :-> e b] -> [e Bool :-> e b]
forall a b. (a -> b) -> [a] -> [b]
map (((a -> e Bool) -> e Bool)
-> ((a -> e Bool) :-> e b) -> e Bool :-> e b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((a -> e Bool) -> a -> e Bool
forall a b. (a -> b) -> a -> b
$ a
a))

-- | Case expression matching a value against constants
--
-- Example:
--
-- @
-- operate c a = `matchConst` c
--   ['+' `-->` a + 1
--   ,'-' `-->` a - 1
--   ]
--   (`Otherwise` `-->` a)
-- @
matchConst ::
     (ConstExp e, CompareExp e, CondExpFO e, DinoType a)
  => e a -- ^ Scrutinee
  -> [a :-> e b] -- ^ Cases
  -> (Otherwise :-> e b) -- ^ Fall-through case
  -> e b
matchConst :: e a -> [a :-> e b] -> (Otherwise :-> e b) -> e b
matchConst e a
a = e a -> [(e a -> e Bool) :-> e b] -> (Otherwise :-> e b) -> e b
forall (e :: * -> *) a b.
CondExpFO e =>
a -> [(a -> e Bool) :-> e b] -> (Otherwise :-> e b) -> e b
match e a
a ([(e a -> e Bool) :-> e b] -> (Otherwise :-> e b) -> e b)
-> ([a :-> e b] -> [(e a -> e Bool) :-> e b])
-> [a :-> e b]
-> (Otherwise :-> e b)
-> e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a :-> e b) -> (e a -> e Bool) :-> e b)
-> [a :-> e b] -> [(e a -> e Bool) :-> e b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> e a -> e Bool) -> (a :-> e b) -> (e a -> e Bool) :-> e b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (e a -> e a -> e Bool
forall a (e :: * -> *).
(Eq a, CompareExp e) =>
e a -> e a -> e Bool
(==) (e a -> e a -> e Bool) -> (a -> e a) -> a -> e a -> e Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit))

-- | A Version of 'matchConst' for enumerations where the cases cover the whole
-- domain
--
-- An error is thrown if the cases do not cover the whole domain.
matchConstFull ::
     ( ConstExp e
     , CompareExp e
     , CondExpFO e
     , DinoType a
     , Show a
     , Enum a
     , Bounded a
     , HasCallStack
     )
  => e a -- ^ Scrutinee
  -> [a :-> e b] -- ^ Cases
  -> e b
matchConstFull :: e a -> [a :-> e b] -> e b
matchConstFull e a
a [a :-> e b]
cs
  | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
missing = [e Bool :-> e b] -> e b
forall (e :: * -> *) a.
(CondExpFO e, HasCallStack) =>
[e Bool :-> e a] -> e a
partial_cases ([e Bool :-> e b] -> e b) -> [e Bool :-> e b] -> e b
forall a b. (a -> b) -> a -> b
$ ((a :-> e b) -> e Bool :-> e b) -> [a :-> e b] -> [e Bool :-> e b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> e Bool) -> (a :-> e b) -> e Bool :-> e b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (e a
a e a -> a -> e Bool
forall (e :: * -> *) a.
(ConstExp e, CompareExp e, DinoType a) =>
e a -> a -> e Bool
==!)) [a :-> e b]
cs
  | Bool
otherwise = String -> e b
forall a. HasCallStack => String -> a
error (String -> e b) -> String -> e b
forall a b. (a -> b) -> a -> b
$ String
"matchConstFull: missing cases " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [a] -> String
forall a. Show a => a -> String
show [a]
missing
  where
    domain :: [a]
domain = [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]
    missing :: [a]
missing = [a]
domain [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a
b | a
b :-> e b
_ <- [a :-> e b]
cs]

-- | Conditional expression
--
-- Enable @RebindableSyntax@ to use the standard syntax @if a then b else c@
-- for calling this function.
ifThenElse ::
     CondExpFO e
  => e Bool -- ^ Condition
  -> e a -- ^ True branch
  -> e a -- ^ False branch
  -> e a
ifThenElse :: e Bool -> e a -> e a -> e a
ifThenElse e Bool
c e a
t e a
f = [e Bool :-> e a] -> (Otherwise :-> e a) -> e a
forall (e :: * -> *) a.
CondExpFO e =>
[e Bool :-> e a] -> (Otherwise :-> e a) -> e a
cases [e Bool
c e Bool -> e a -> e Bool :-> e a
forall a b. a -> b -> a :-> b
--> e a
t] (Otherwise
Otherwise Otherwise -> e a -> Otherwise :-> e a
forall a b. a -> b -> a :-> b
--> e a
f)

fromMaybe :: (CondExp e, DinoType a) => e a -> e (Maybe a) -> e a
fromMaybe :: e a -> e (Maybe a) -> e a
fromMaybe e a
n = e a -> (e a -> e a) -> e (Maybe a) -> e a
forall (e :: * -> *) a b.
(CondExp e, DinoType a) =>
e b -> (e a -> e b) -> e (Maybe a) -> e b
maybe e a
n e a -> e a
forall a. a -> a
id



----------------------------------------
-- ** Lists
----------------------------------------

-- | Helper class to 'ListExp' containing only first-order constructs
--
-- The reason for having this class is that there are types for which
-- 'ListExpFO' can be derived but 'ListExp' cannot.
class ListExpFO e where
  range ::
       Enum a
    => e a -- ^ Lower bound (inclusive)
    -> e a -- ^ Upper bound (inclusive)
    -> e [a]

  list   :: DinoType a => [e a] -> e [a]
  headE  :: e [a] -> e (Maybe a)
  append :: e [a] -> e [a] -> e [a]

  default range  :: (Applicative e, Enum a) => e a -> e a -> e [a]
  default list   :: Applicative e => [e a] -> e [a]
  default headE  :: Applicative e => e [a] -> e (Maybe a)
  default append :: Applicative e => e [a] -> e [a] -> e [a]

  range  = (a -> a -> [a]) -> e a -> e a -> e [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((a -> a -> [a]) -> e a -> e a -> e [a])
-> (a -> a -> [a]) -> e a -> e a -> e [a]
forall a b. (a -> b) -> a -> b
$ \a
l a
u -> [a
l .. a
u]
  list   = [e a] -> e [a]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
  headE  = ([a] -> Maybe a) -> e [a] -> e (Maybe a)
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA [a] -> Maybe a
forall a. [a] -> Maybe a
headMay
  append = ([a] -> [a] -> [a]) -> e [a] -> e [a] -> e [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

class ListExpFO e => ListExp e where
  mapE       :: DinoType a => (e a -> e b) -> e [a] -> e [b]
  dropWhileE :: DinoType a => (e a -> e Bool) -> e [a] -> e [a]

  -- | Left fold
  foldE ::
       (DinoType a, DinoType b)
    => (e a -> e b -> e a) -- ^ Reducer function
    -> e a -- ^ Initial value
    -> e [b] -- ^ List to reduce (traversed left-to-right)
    -> e a

  default mapE       :: Monad e => (e a -> e b) -> e [a] -> e [b]
  default dropWhileE :: Monad e => (e a -> e Bool) -> e [a] -> e [a]
  default foldE      :: Monad e => (e a -> e b -> e a) -> e a -> e [b] -> e a

  mapE e a -> e b
f e [a]
as       = (a -> e b) -> [a] -> e [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (e a -> e b
f (e a -> e b) -> (a -> e a) -> a -> e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e a
forall (m :: * -> *) a. Monad m => a -> m a
return) ([a] -> e [b]) -> e [a] -> e [b]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< e [a]
as
  dropWhileE e a -> e Bool
p e [a]
as = (a -> e Bool) -> [a] -> e [a]
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM (e a -> e Bool
p (e a -> e Bool) -> (a -> e a) -> a -> e Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e a
forall (m :: * -> *) a. Monad m => a -> m a
return) ([a] -> e [a]) -> e [a] -> e [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< e [a]
as

  foldE e a -> e b -> e a
f e a
a e [b]
bs = do
    a
a' <- e a
a
    [b]
bs' <- e [b]
bs
    (a -> b -> e a) -> a -> [b] -> e a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\a
aa b
bb -> e a -> e b -> e a
f (a -> e a
forall (m :: * -> *) a. Monad m => a -> m a
return a
aa) (b -> e b
forall (m :: * -> *) a. Monad m => a -> m a
return b
bb)) a
a' [b]
bs'



----------------------------------------
-- ** Tuples
----------------------------------------

class TupleExp e where
  pair :: e a -> e b -> e (a, b)
  fstE :: e (a, b) -> e a
  sndE :: e (a, b) -> e b

  default pair :: Applicative e => e a -> e b -> e (a, b)
  default fstE :: Applicative e => e (a, b) -> e a
  default sndE :: Applicative e => e (a, b) -> e b

  pair = (a -> b -> (a, b)) -> e a -> e b -> e (a, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
  fstE = ((a, b) -> a) -> e (a, b) -> e a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (a, b) -> a
forall a b. (a, b) -> a
fst
  sndE = ((a, b) -> b) -> e (a, b) -> e b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (a, b) -> b
forall a b. (a, b) -> b
snd



----------------------------------------
-- ** Let bindings
----------------------------------------

class LetExp e where
  -- | Share a value in a calculation
  --
  -- The default implementation of 'letE' implements call-by-value.
  letE ::
       DinoType a
    => Text         -- ^ Variable base name
    -> e a          -- ^ Value to share
    -> (e a -> e b) -- ^ Body
    -> e b

  default letE :: Monad e => Text -> e a -> (e a -> e b) -> e b
  letE Text
_ e a
a e a -> e b
body = e a
a e a -> (a -> e b) -> e b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= e a -> e b
body (e a -> e b) -> (a -> e a) -> a -> e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Share a value in a calculation
--
-- Like 'letE' but with the variable base name fixed to \"share\".
share ::
     (LetExp e, DinoType a)
  => e a          -- ^ Value to share
  -> (e a -> e b) -- ^ Body
  -> e b
share :: e a -> (e a -> e b) -> e b
share = Text -> e a -> (e a -> e b) -> e b
forall (e :: * -> *) a b.
(LetExp e, DinoType a) =>
Text -> e a -> (e a -> e b) -> e b
letE Text
"share"

-- | Make a function with a shared argument
--
-- @
-- `shared` = `flip` `share`
-- @
--
-- Like 'letE' but with the variable base name fixed to \"share\".
shared ::
     (LetExp e, DinoType a)
  => (e a -> e b) -- ^ Body
  -> e a          -- ^ Value to share
  -> e b
shared :: (e a -> e b) -> e a -> e b
shared = (e a -> (e a -> e b) -> e b) -> (e a -> e b) -> e a -> e b
forall a b c. (a -> b -> c) -> b -> a -> c
flip e a -> (e a -> e b) -> e b
forall (e :: * -> *) a b.
(LetExp e, DinoType a) =>
e a -> (e a -> e b) -> e b
share



----------------------------------------
-- ** Records
----------------------------------------

data Field (f :: Symbol) = Field

class FieldExp e where
  getField ::
       (KnownSymbol f, HasField f r a, DinoType a) => proxy f -> e r -> e a

  default getField ::
       forall proxy f r a. (Applicative e, KnownSymbol f, HasField f r a)
    => proxy f
    -> e r
    -> e a
  getField proxy f
_ = (r -> a) -> e r -> e a
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField f r a => r -> a
GHC.getField @f)

instance (f1 ~ f2) => IsLabel f1 (Field f2) where
  fromLabel :: Field f2
fromLabel = Field f2
forall (f :: Symbol). Field f
Field

-- | Extract a field from a record
--
-- Use as follows (with @OverloadedLabels@):
--
-- > field #name $ field #driver car
field ::
     (FieldExp e, KnownSymbol f, HasField f r a, DinoType a)
  => Field f
  -> e r
  -> e a
field :: Field f -> e r -> e a
field = Field f -> e r -> e a
forall (e :: * -> *) (f :: Symbol) r a (proxy :: Symbol -> *).
(FieldExp e, KnownSymbol f, HasField f r a, DinoType a) =>
proxy f -> e r -> e a
getField

-- | Extract a field from a record
--
-- Use as follows (with @OverloadedLabels@):
--
-- > #name <. #driver <. car
(<.) ::
     (FieldExp e, KnownSymbol f, HasField f r a, DinoType a)
  => Field f
  -> e r
  -> e a
<. :: Field f -> e r -> e a
(<.) = Field f -> e r -> e a
forall (e :: * -> *) (f :: Symbol) r a (proxy :: Symbol -> *).
(FieldExp e, KnownSymbol f, HasField f r a, DinoType a) =>
proxy f -> e r -> e a
getField

infixr 9 <.



----------------------------------------
-- ** Annotations
----------------------------------------

class AnnExp ann e where
  -- | Annotate an expression
  ann :: ann -> e a -> e a
  ann ann
_ = e a -> e a
forall a. a -> a
id



----------------------------------------
-- ** Assertions
----------------------------------------

class AssertExp e where
  -- | Assert that a condition is true
  --
  -- Interpretations can choose whether to ignore the assertion or to check its
  -- validity. The default implementation ignores the assertion.
  --
  -- The following must hold for any monadic interpretation:
  --
  -- @
  -- `assert` lab c a
  --   `==`
  -- (`assert` lab c (`return` ()) `>>` `return` a)
  -- @
  assert ::
       Text -- ^ Assertion label
    -> e Bool -- ^ Condition that should be true
    -> e a -- ^ Expression to attach the assertion to
    -> e a
  assert Text
_ e Bool
_ = e a -> e a
forall a. a -> a
id

  -- | Assert that an expression is semantically equivalent to a reference
  -- expression
  --
  -- Interpretations can choose whether to ignore the assertion or to check its
  -- validity. The default implementation ignores the assertion.
  --
  -- The following must hold for any monadic interpretation:
  --
  -- @
  -- `assertEq` lab ref act
  --   `==`
  -- ( do a <- act
  --      `assertEq` lab ref (`return` a)
  --      return a
  -- )
  -- @
  assertEq ::
       (Eq a, Show a) -- TODO Use `Pretty`?
    => Text -- ^ Assertion label
    -> e a -- ^ Reference expression
    -> e a -- ^ Actual expression
    -> e a
  assertEq Text
_ e a
_ e a
act = e a
act
    -- Having a separate function for equality avoids the problem of "Boolean
    -- blindness". For example, a diff of the two expressions can be shown when
    -- they are not equal.



----------------------------------------
-- ** Concrete expression wrapper
----------------------------------------

-- | Useful wrapper to get a concrete type for tagless DSL expressions
--
-- The problem solved by this type can be explained as follows:
--
-- Suppose you write a numeric expression with the most general type:
--
-- > myExp1 :: Num e => e
-- > myExp1 = 1+2
--
-- And suppose you define an evaluation function as follows:
--
--
-- > eval1 :: (forall e . (ConstExp e, NumExp e) => e a) -> a
-- > eval1 = runIdentity
--
-- The problem is that we cannot pass @myExp1@ to @eval1@:
--
-- > test1 :: Int
-- > test1 = eval1 myExp1
--
-- This leads to:
--
-- > • Could not deduce (Num (e Int)) ...
--
-- And we don't want to change @eval1@ to
--
-- > eval1 :: (forall e . (ConstExp e, NumExp e, Num (e a)) => e a) -> a
--
-- since this requires the expression to return a number (and not e.g. a
-- Boolean), and it also doesn't help to satisfy any internal numeric
-- expressions that may use a different type than @a@.
--
-- Instead, the solution is to use 'Exp' as follows:
--
-- > myExp2 :: (ConstExp e, NumExp e, Num a) => Exp e a
-- > myExp2 = 1+2
-- >
-- > eval2 :: (forall e . (ConstExp e, NumExp e) => Exp e a) -> a
-- > eval2 = runIdentity . unExp
-- >
-- > test2 :: Int
-- > test2 = eval2 myExp2
--
-- The trick is that there exists an instance
--
-- > instance (Num a, ConstExp e, NumExp e) => Num (Exp e a)
--
-- So it is enough for @eval2@ to supply constraints on @e@, and it will
-- automatically imply the availability of the `Num` instance.
newtype Exp e a = Exp
  { Exp e a -> e a
unExp :: e a
  } deriving ( Exp e a -> Exp e a -> Bool
(Exp e a -> Exp e a -> Bool)
-> (Exp e a -> Exp e a -> Bool) -> Eq (Exp e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (e :: k -> *) (a :: k).
Eq (e a) =>
Exp e a -> Exp e a -> Bool
/= :: Exp e a -> Exp e a -> Bool
$c/= :: forall k (e :: k -> *) (a :: k).
Eq (e a) =>
Exp e a -> Exp e a -> Bool
== :: Exp e a -> Exp e a -> Bool
$c== :: forall k (e :: k -> *) (a :: k).
Eq (e a) =>
Exp e a -> Exp e a -> Bool
Eq
             , Int -> Exp e a -> ShowS
[Exp e a] -> ShowS
Exp e a -> String
(Int -> Exp e a -> ShowS)
-> (Exp e a -> String) -> ([Exp e a] -> ShowS) -> Show (Exp e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (e :: k -> *) (a :: k).
Show (e a) =>
Int -> Exp e a -> ShowS
forall k (e :: k -> *) (a :: k). Show (e a) => [Exp e a] -> ShowS
forall k (e :: k -> *) (a :: k). Show (e a) => Exp e a -> String
showList :: [Exp e a] -> ShowS
$cshowList :: forall k (e :: k -> *) (a :: k). Show (e a) => [Exp e a] -> ShowS
show :: Exp e a -> String
$cshow :: forall k (e :: k -> *) (a :: k). Show (e a) => Exp e a -> String
showsPrec :: Int -> Exp e a -> ShowS
$cshowsPrec :: forall k (e :: k -> *) (a :: k).
Show (e a) =>
Int -> Exp e a -> ShowS
Show
             , a -> Exp e b -> Exp e a
(a -> b) -> Exp e a -> Exp e b
(forall a b. (a -> b) -> Exp e a -> Exp e b)
-> (forall a b. a -> Exp e b -> Exp e a) -> Functor (Exp e)
forall a b. a -> Exp e b -> Exp e a
forall a b. (a -> b) -> Exp e a -> Exp e b
forall (e :: * -> *) a b. Functor e => a -> Exp e b -> Exp e a
forall (e :: * -> *) a b.
Functor e =>
(a -> b) -> Exp e a -> Exp e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Exp e b -> Exp e a
$c<$ :: forall (e :: * -> *) a b. Functor e => a -> Exp e b -> Exp e a
fmap :: (a -> b) -> Exp e a -> Exp e b
$cfmap :: forall (e :: * -> *) a b.
Functor e =>
(a -> b) -> Exp e a -> Exp e b
Functor
             , Functor (Exp e)
a -> Exp e a
Functor (Exp e)
-> (forall a. a -> Exp e a)
-> (forall a b. Exp e (a -> b) -> Exp e a -> Exp e b)
-> (forall a b c. (a -> b -> c) -> Exp e a -> Exp e b -> Exp e c)
-> (forall a b. Exp e a -> Exp e b -> Exp e b)
-> (forall a b. Exp e a -> Exp e b -> Exp e a)
-> Applicative (Exp e)
Exp e a -> Exp e b -> Exp e b
Exp e a -> Exp e b -> Exp e a
Exp e (a -> b) -> Exp e a -> Exp e b
(a -> b -> c) -> Exp e a -> Exp e b -> Exp e c
forall a. a -> Exp e a
forall a b. Exp e a -> Exp e b -> Exp e a
forall a b. Exp e a -> Exp e b -> Exp e b
forall a b. Exp e (a -> b) -> Exp e a -> Exp e b
forall a b c. (a -> b -> c) -> Exp e a -> Exp e b -> Exp e c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (e :: * -> *). Applicative e => Functor (Exp e)
forall (e :: * -> *) a. Applicative e => a -> Exp e a
forall (e :: * -> *) a b.
Applicative e =>
Exp e a -> Exp e b -> Exp e a
forall (e :: * -> *) a b.
Applicative e =>
Exp e a -> Exp e b -> Exp e b
forall (e :: * -> *) a b.
Applicative e =>
Exp e (a -> b) -> Exp e a -> Exp e b
forall (e :: * -> *) a b c.
Applicative e =>
(a -> b -> c) -> Exp e a -> Exp e b -> Exp e c
<* :: Exp e a -> Exp e b -> Exp e a
$c<* :: forall (e :: * -> *) a b.
Applicative e =>
Exp e a -> Exp e b -> Exp e a
*> :: Exp e a -> Exp e b -> Exp e b
$c*> :: forall (e :: * -> *) a b.
Applicative e =>
Exp e a -> Exp e b -> Exp e b
liftA2 :: (a -> b -> c) -> Exp e a -> Exp e b -> Exp e c
$cliftA2 :: forall (e :: * -> *) a b c.
Applicative e =>
(a -> b -> c) -> Exp e a -> Exp e b -> Exp e c
<*> :: Exp e (a -> b) -> Exp e a -> Exp e b
$c<*> :: forall (e :: * -> *) a b.
Applicative e =>
Exp e (a -> b) -> Exp e a -> Exp e b
pure :: a -> Exp e a
$cpure :: forall (e :: * -> *) a. Applicative e => a -> Exp e a
$cp1Applicative :: forall (e :: * -> *). Applicative e => Functor (Exp e)
Applicative
             , Applicative (Exp e)
a -> Exp e a
Applicative (Exp e)
-> (forall a b. Exp e a -> (a -> Exp e b) -> Exp e b)
-> (forall a b. Exp e a -> Exp e b -> Exp e b)
-> (forall a. a -> Exp e a)
-> Monad (Exp e)
Exp e a -> (a -> Exp e b) -> Exp e b
Exp e a -> Exp e b -> Exp e b
forall a. a -> Exp e a
forall a b. Exp e a -> Exp e b -> Exp e b
forall a b. Exp e a -> (a -> Exp e b) -> Exp e b
forall (e :: * -> *). Monad e => Applicative (Exp e)
forall (e :: * -> *) a. Monad e => a -> Exp e a
forall (e :: * -> *) a b. Monad e => Exp e a -> Exp e b -> Exp e b
forall (e :: * -> *) a b.
Monad e =>
Exp e a -> (a -> Exp e b) -> Exp e b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Exp e a
$creturn :: forall (e :: * -> *) a. Monad e => a -> Exp e a
>> :: Exp e a -> Exp e b -> Exp e b
$c>> :: forall (e :: * -> *) a b. Monad e => Exp e a -> Exp e b -> Exp e b
>>= :: Exp e a -> (a -> Exp e b) -> Exp e b
$c>>= :: forall (e :: * -> *) a b.
Monad e =>
Exp e a -> (a -> Exp e b) -> Exp e b
$cp1Monad :: forall (e :: * -> *). Monad e => Applicative (Exp e)
Monad
             , a -> Exp e a
(forall a. DinoType a => a -> Exp e a) -> ConstExp (Exp e)
forall a. DinoType a => a -> Exp e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> Exp e a
forall (e :: * -> *).
(forall a. DinoType a => a -> e a) -> ConstExp e
lit :: a -> Exp e a
$clit :: forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> Exp e a
ConstExp
             , Int -> Exp e a -> Exp e a
Exp e a -> Exp e a -> Exp e a
Exp e a -> Exp e a -> Exp e a
Exp e a -> Exp e a -> Exp e a
Exp e a -> Exp e a
Exp e a -> Exp e a
Exp e a -> Exp e b
Exp e a -> Exp e b
Exp e a -> Exp e b
(forall a. Num a => Exp e a -> Exp e a -> Exp e a)
-> (forall a. Num a => Exp e a -> Exp e a -> Exp e a)
-> (forall a. Num a => Exp e a -> Exp e a -> Exp e a)
-> (forall a. Num a => Exp e a -> Exp e a)
-> (forall a. Num a => Exp e a -> Exp e a)
-> (forall a b.
    (Integral a, DinoType b, Num b) =>
    Exp e a -> Exp e b)
-> (forall a b.
    (RealFrac a, DinoType b, Integral b) =>
    Exp e a -> Exp e b)
-> (forall a b.
    (RealFrac a, DinoType b, Integral b) =>
    Exp e a -> Exp e b)
-> (forall a. RealFrac a => Int -> Exp e a -> Exp e a)
-> NumExp (Exp e)
forall a. Num a => Exp e a -> Exp e a
forall a. Num a => Exp e a -> Exp e a -> Exp e a
forall a. RealFrac a => Int -> Exp e a -> Exp e a
forall a b. (Integral a, DinoType b, Num b) => Exp e a -> Exp e b
forall a b.
(RealFrac a, DinoType b, Integral b) =>
Exp e a -> Exp e b
forall (e :: * -> *) a. (NumExp e, Num a) => Exp e a -> Exp e a
forall (e :: * -> *) a.
(NumExp e, Num a) =>
Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a.
(NumExp e, RealFrac a) =>
Int -> Exp e a -> Exp e a
forall (e :: * -> *) a b.
(NumExp e, Integral a, DinoType b, Num b) =>
Exp e a -> Exp e b
forall (e :: * -> *) a b.
(NumExp e, RealFrac a, DinoType b, Integral b) =>
Exp e a -> Exp e b
forall (e :: * -> *).
(forall a. Num a => e a -> e a -> e a)
-> (forall a. Num a => e a -> e a -> e a)
-> (forall a. Num a => e a -> e a -> e a)
-> (forall a. Num a => e a -> e a)
-> (forall a. Num a => e a -> e a)
-> (forall a b. (Integral a, DinoType b, Num b) => e a -> e b)
-> (forall a b. (RealFrac a, DinoType b, Integral b) => e a -> e b)
-> (forall a b. (RealFrac a, DinoType b, Integral b) => e a -> e b)
-> (forall a. RealFrac a => Int -> e a -> e a)
-> NumExp e
roundN :: Int -> Exp e a -> Exp e a
$croundN :: forall (e :: * -> *) a.
(NumExp e, RealFrac a) =>
Int -> Exp e a -> Exp e a
truncate :: Exp e a -> Exp e b
$ctruncate :: forall (e :: * -> *) a b.
(NumExp e, RealFrac a, DinoType b, Integral b) =>
Exp e a -> Exp e b
floor :: Exp e a -> Exp e b
$cfloor :: forall (e :: * -> *) a b.
(NumExp e, RealFrac a, DinoType b, Integral b) =>
Exp e a -> Exp e b
fromIntegral :: Exp e a -> Exp e b
$cfromIntegral :: forall (e :: * -> *) a b.
(NumExp e, Integral a, DinoType b, Num b) =>
Exp e a -> Exp e b
signE :: Exp e a -> Exp e a
$csignE :: forall (e :: * -> *) a. (NumExp e, Num a) => Exp e a -> Exp e a
absE :: Exp e a -> Exp e a
$cabsE :: forall (e :: * -> *) a. (NumExp e, Num a) => Exp e a -> Exp e a
mul :: Exp e a -> Exp e a -> Exp e a
$cmul :: forall (e :: * -> *) a.
(NumExp e, Num a) =>
Exp e a -> Exp e a -> Exp e a
sub :: Exp e a -> Exp e a -> Exp e a
$csub :: forall (e :: * -> *) a.
(NumExp e, Num a) =>
Exp e a -> Exp e a -> Exp e a
add :: Exp e a -> Exp e a -> Exp e a
$cadd :: forall (e :: * -> *) a.
(NumExp e, Num a) =>
Exp e a -> Exp e a -> Exp e a
NumExp
             , Exp e a -> Exp e a -> Exp e a
(forall a. (Fractional a, Eq a) => Exp e a -> Exp e a -> Exp e a)
-> FracExp (Exp e)
forall a. (Fractional a, Eq a) => Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a.
(FracExp e, Fractional a, Eq a) =>
Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *).
(forall a. (Fractional a, Eq a) => e a -> e a -> e a) -> FracExp e
fdiv :: Exp e a -> Exp e a -> Exp e a
$cfdiv :: forall (e :: * -> *) a.
(FracExp e, Fractional a, Eq a) =>
Exp e a -> Exp e a -> Exp e a
FracExp
             , Exp e Bool -> Exp e Bool
Exp e Bool -> Exp e Bool -> Exp e Bool
(Exp e Bool -> Exp e Bool)
-> (Exp e Bool -> Exp e Bool -> Exp e Bool)
-> (Exp e Bool -> Exp e Bool -> Exp e Bool)
-> (Exp e Bool -> Exp e Bool -> Exp e Bool)
-> LogicExp (Exp e)
forall (e :: * -> *). LogicExp e => Exp e Bool -> Exp e Bool
forall (e :: * -> *).
LogicExp e =>
Exp e Bool -> Exp e Bool -> Exp e Bool
forall (e :: * -> *).
(e Bool -> e Bool)
-> (e Bool -> e Bool -> e Bool)
-> (e Bool -> e Bool -> e Bool)
-> (e Bool -> e Bool -> e Bool)
-> LogicExp e
xor :: Exp e Bool -> Exp e Bool -> Exp e Bool
$cxor :: forall (e :: * -> *).
LogicExp e =>
Exp e Bool -> Exp e Bool -> Exp e Bool
disj :: Exp e Bool -> Exp e Bool -> Exp e Bool
$cdisj :: forall (e :: * -> *).
LogicExp e =>
Exp e Bool -> Exp e Bool -> Exp e Bool
conj :: Exp e Bool -> Exp e Bool -> Exp e Bool
$cconj :: forall (e :: * -> *).
LogicExp e =>
Exp e Bool -> Exp e Bool -> Exp e Bool
not :: Exp e Bool -> Exp e Bool
$cnot :: forall (e :: * -> *). LogicExp e => Exp e Bool -> Exp e Bool
LogicExp
             , Exp e a -> Exp e a -> Exp e Bool
Exp e a -> Exp e a -> Exp e Bool
Exp e a -> Exp e a -> Exp e Bool
Exp e a -> Exp e a -> Exp e Bool
Exp e a -> Exp e a -> Exp e Bool
Exp e a -> Exp e a -> Exp e Bool
Exp e a -> Exp e a -> Exp e a
Exp e a -> Exp e a -> Exp e a
(forall a. Eq a => Exp e a -> Exp e a -> Exp e Bool)
-> (forall a. Eq a => Exp e a -> Exp e a -> Exp e Bool)
-> (forall a. Ord a => Exp e a -> Exp e a -> Exp e Bool)
-> (forall a. Ord a => Exp e a -> Exp e a -> Exp e Bool)
-> (forall a. Ord a => Exp e a -> Exp e a -> Exp e Bool)
-> (forall a. Ord a => Exp e a -> Exp e a -> Exp e Bool)
-> (forall a. Ord a => Exp e a -> Exp e a -> Exp e a)
-> (forall a. Ord a => Exp e a -> Exp e a -> Exp e a)
-> CompareExp (Exp e)
forall a. Eq a => Exp e a -> Exp e a -> Exp e Bool
forall a. Ord a => Exp e a -> Exp e a -> Exp e a
forall a. Ord a => Exp e a -> Exp e a -> Exp e Bool
forall (e :: * -> *) a.
(CompareExp e, Eq a) =>
Exp e a -> Exp e a -> Exp e Bool
forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e Bool
forall (e :: * -> *).
(forall a. Eq a => e a -> e a -> e Bool)
-> (forall a. Eq a => e a -> e a -> e Bool)
-> (forall a. Ord a => e a -> e a -> e Bool)
-> (forall a. Ord a => e a -> e a -> e Bool)
-> (forall a. Ord a => e a -> e a -> e Bool)
-> (forall a. Ord a => e a -> e a -> e Bool)
-> (forall a. Ord a => e a -> e a -> e a)
-> (forall a. Ord a => e a -> e a -> e a)
-> CompareExp e
max :: Exp e a -> Exp e a -> Exp e a
$cmax :: forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e a
min :: Exp e a -> Exp e a -> Exp e a
$cmin :: forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e a
gte :: Exp e a -> Exp e a -> Exp e Bool
$cgte :: forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e Bool
lte :: Exp e a -> Exp e a -> Exp e Bool
$clte :: forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e Bool
gt :: Exp e a -> Exp e a -> Exp e Bool
$cgt :: forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e Bool
lt :: Exp e a -> Exp e a -> Exp e Bool
$clt :: forall (e :: * -> *) a.
(CompareExp e, Ord a) =>
Exp e a -> Exp e a -> Exp e Bool
neq :: Exp e a -> Exp e a -> Exp e Bool
$cneq :: forall (e :: * -> *) a.
(CompareExp e, Eq a) =>
Exp e a -> Exp e a -> Exp e Bool
eq :: Exp e a -> Exp e a -> Exp e Bool
$ceq :: forall (e :: * -> *) a.
(CompareExp e, Eq a) =>
Exp e a -> Exp e a -> Exp e Bool
CompareExp
             , [Exp e Bool :-> Exp e a] -> (Otherwise :-> Exp e a) -> Exp e a
[Exp e Bool :-> Exp e a] -> Exp e a
Exp e a -> Exp e (Maybe a)
(forall a. Exp e a -> Exp e (Maybe a))
-> (forall a.
    [Exp e Bool :-> Exp e a] -> (Otherwise :-> Exp e a) -> Exp e a)
-> (forall a. HasCallStack => [Exp e Bool :-> Exp e a] -> Exp e a)
-> CondExpFO (Exp e)
forall a. HasCallStack => [Exp e Bool :-> Exp e a] -> Exp e a
forall a.
[Exp e Bool :-> Exp e a] -> (Otherwise :-> Exp e a) -> Exp e a
forall a. Exp e a -> Exp e (Maybe a)
forall (e :: * -> *) a.
(CondExpFO e, HasCallStack) =>
[Exp e Bool :-> Exp e a] -> Exp e a
forall (e :: * -> *) a.
CondExpFO e =>
[Exp e Bool :-> Exp e a] -> (Otherwise :-> Exp e a) -> Exp e a
forall (e :: * -> *) a. CondExpFO e => Exp e a -> Exp e (Maybe a)
forall (e :: * -> *).
(forall a. e a -> e (Maybe a))
-> (forall a. [e Bool :-> e a] -> (Otherwise :-> e a) -> e a)
-> (forall a. HasCallStack => [e Bool :-> e a] -> e a)
-> CondExpFO e
partial_cases :: [Exp e Bool :-> Exp e a] -> Exp e a
$cpartial_cases :: forall (e :: * -> *) a.
(CondExpFO e, HasCallStack) =>
[Exp e Bool :-> Exp e a] -> Exp e a
cases :: [Exp e Bool :-> Exp e a] -> (Otherwise :-> Exp e a) -> Exp e a
$ccases :: forall (e :: * -> *) a.
CondExpFO e =>
[Exp e Bool :-> Exp e a] -> (Otherwise :-> Exp e a) -> Exp e a
just :: Exp e a -> Exp e (Maybe a)
$cjust :: forall (e :: * -> *) a. CondExpFO e => Exp e a -> Exp e (Maybe a)
CondExpFO
             , CondExpFO (Exp e)
Exp e b -> (Exp e a -> Exp e b) -> Exp e (Maybe a) -> Exp e b
CondExpFO (Exp e)
-> (forall a b.
    DinoType a =>
    Exp e b -> (Exp e a -> Exp e b) -> Exp e (Maybe a) -> Exp e b)
-> CondExp (Exp e)
forall a b.
DinoType a =>
Exp e b -> (Exp e a -> Exp e b) -> Exp e (Maybe a) -> Exp e b
forall (e :: * -> *). CondExp e => CondExpFO (Exp e)
forall (e :: * -> *) a b.
(CondExp e, DinoType a) =>
Exp e b -> (Exp e a -> Exp e b) -> Exp e (Maybe a) -> Exp e b
forall (e :: * -> *).
CondExpFO e
-> (forall a b.
    DinoType a =>
    e b -> (e a -> e b) -> e (Maybe a) -> e b)
-> CondExp e
maybe :: Exp e b -> (Exp e a -> Exp e b) -> Exp e (Maybe a) -> Exp e b
$cmaybe :: forall (e :: * -> *) a b.
(CondExp e, DinoType a) =>
Exp e b -> (Exp e a -> Exp e b) -> Exp e (Maybe a) -> Exp e b
$cp1CondExp :: forall (e :: * -> *). CondExp e => CondExpFO (Exp e)
CondExp
             , [Exp e a] -> Exp e [a]
Exp e a -> Exp e a -> Exp e [a]
Exp e [a] -> Exp e (Maybe a)
Exp e [a] -> Exp e [a] -> Exp e [a]
(forall a. Enum a => Exp e a -> Exp e a -> Exp e [a])
-> (forall a. DinoType a => [Exp e a] -> Exp e [a])
-> (forall a. Exp e [a] -> Exp e (Maybe a))
-> (forall a. Exp e [a] -> Exp e [a] -> Exp e [a])
-> ListExpFO (Exp e)
forall a. Enum a => Exp e a -> Exp e a -> Exp e [a]
forall a. DinoType a => [Exp e a] -> Exp e [a]
forall a. Exp e [a] -> Exp e (Maybe a)
forall a. Exp e [a] -> Exp e [a] -> Exp e [a]
forall (e :: * -> *) a.
(ListExpFO e, Enum a) =>
Exp e a -> Exp e a -> Exp e [a]
forall (e :: * -> *) a.
(ListExpFO e, DinoType a) =>
[Exp e a] -> Exp e [a]
forall (e :: * -> *) a. ListExpFO e => Exp e [a] -> Exp e (Maybe a)
forall (e :: * -> *) a.
ListExpFO e =>
Exp e [a] -> Exp e [a] -> Exp e [a]
forall (e :: * -> *).
(forall a. Enum a => e a -> e a -> e [a])
-> (forall a. DinoType a => [e a] -> e [a])
-> (forall a. e [a] -> e (Maybe a))
-> (forall a. e [a] -> e [a] -> e [a])
-> ListExpFO e
append :: Exp e [a] -> Exp e [a] -> Exp e [a]
$cappend :: forall (e :: * -> *) a.
ListExpFO e =>
Exp e [a] -> Exp e [a] -> Exp e [a]
headE :: Exp e [a] -> Exp e (Maybe a)
$cheadE :: forall (e :: * -> *) a. ListExpFO e => Exp e [a] -> Exp e (Maybe a)
list :: [Exp e a] -> Exp e [a]
$clist :: forall (e :: * -> *) a.
(ListExpFO e, DinoType a) =>
[Exp e a] -> Exp e [a]
range :: Exp e a -> Exp e a -> Exp e [a]
$crange :: forall (e :: * -> *) a.
(ListExpFO e, Enum a) =>
Exp e a -> Exp e a -> Exp e [a]
ListExpFO
             , ListExpFO (Exp e)
ListExpFO (Exp e)
-> (forall a b.
    DinoType a =>
    (Exp e a -> Exp e b) -> Exp e [a] -> Exp e [b])
-> (forall a.
    DinoType a =>
    (Exp e a -> Exp e Bool) -> Exp e [a] -> Exp e [a])
-> (forall a b.
    (DinoType a, DinoType b) =>
    (Exp e a -> Exp e b -> Exp e a) -> Exp e a -> Exp e [b] -> Exp e a)
-> ListExp (Exp e)
(Exp e a -> Exp e b) -> Exp e [a] -> Exp e [b]
(Exp e a -> Exp e Bool) -> Exp e [a] -> Exp e [a]
(Exp e a -> Exp e b -> Exp e a) -> Exp e a -> Exp e [b] -> Exp e a
forall a.
DinoType a =>
(Exp e a -> Exp e Bool) -> Exp e [a] -> Exp e [a]
forall a b.
(DinoType a, DinoType b) =>
(Exp e a -> Exp e b -> Exp e a) -> Exp e a -> Exp e [b] -> Exp e a
forall a b.
DinoType a =>
(Exp e a -> Exp e b) -> Exp e [a] -> Exp e [b]
forall (e :: * -> *). ListExp e => ListExpFO (Exp e)
forall (e :: * -> *) a.
(ListExp e, DinoType a) =>
(Exp e a -> Exp e Bool) -> Exp e [a] -> Exp e [a]
forall (e :: * -> *) a b.
(ListExp e, DinoType a, DinoType b) =>
(Exp e a -> Exp e b -> Exp e a) -> Exp e a -> Exp e [b] -> Exp e a
forall (e :: * -> *) a b.
(ListExp e, DinoType a) =>
(Exp e a -> Exp e b) -> Exp e [a] -> Exp e [b]
forall (e :: * -> *).
ListExpFO e
-> (forall a b. DinoType a => (e a -> e b) -> e [a] -> e [b])
-> (forall a. DinoType a => (e a -> e Bool) -> e [a] -> e [a])
-> (forall a b.
    (DinoType a, DinoType b) =>
    (e a -> e b -> e a) -> e a -> e [b] -> e a)
-> ListExp e
foldE :: (Exp e a -> Exp e b -> Exp e a) -> Exp e a -> Exp e [b] -> Exp e a
$cfoldE :: forall (e :: * -> *) a b.
(ListExp e, DinoType a, DinoType b) =>
(Exp e a -> Exp e b -> Exp e a) -> Exp e a -> Exp e [b] -> Exp e a
dropWhileE :: (Exp e a -> Exp e Bool) -> Exp e [a] -> Exp e [a]
$cdropWhileE :: forall (e :: * -> *) a.
(ListExp e, DinoType a) =>
(Exp e a -> Exp e Bool) -> Exp e [a] -> Exp e [a]
mapE :: (Exp e a -> Exp e b) -> Exp e [a] -> Exp e [b]
$cmapE :: forall (e :: * -> *) a b.
(ListExp e, DinoType a) =>
(Exp e a -> Exp e b) -> Exp e [a] -> Exp e [b]
$cp1ListExp :: forall (e :: * -> *). ListExp e => ListExpFO (Exp e)
ListExp
             , Text -> Exp e a -> (Exp e a -> Exp e b) -> Exp e b
(forall a b.
 DinoType a =>
 Text -> Exp e a -> (Exp e a -> Exp e b) -> Exp e b)
-> LetExp (Exp e)
forall a b.
DinoType a =>
Text -> Exp e a -> (Exp e a -> Exp e b) -> Exp e b
forall (e :: * -> *) a b.
(LetExp e, DinoType a) =>
Text -> Exp e a -> (Exp e a -> Exp e b) -> Exp e b
forall (e :: * -> *).
(forall a b. DinoType a => Text -> e a -> (e a -> e b) -> e b)
-> LetExp e
letE :: Text -> Exp e a -> (Exp e a -> Exp e b) -> Exp e b
$cletE :: forall (e :: * -> *) a b.
(LetExp e, DinoType a) =>
Text -> Exp e a -> (Exp e a -> Exp e b) -> Exp e b
LetExp
             , proxy f -> Exp e r -> Exp e a
(forall (f :: Symbol) r a (proxy :: Symbol -> *).
 (KnownSymbol f, HasField f r a, DinoType a) =>
 proxy f -> Exp e r -> Exp e a)
-> FieldExp (Exp e)
forall (f :: Symbol) r a (proxy :: Symbol -> *).
(KnownSymbol f, HasField f r a, DinoType a) =>
proxy f -> Exp e r -> Exp e a
forall (e :: * -> *) (f :: Symbol) r a (proxy :: Symbol -> *).
(FieldExp e, KnownSymbol f, HasField f r a, DinoType a) =>
proxy f -> Exp e r -> Exp e a
forall (e :: * -> *).
(forall (f :: Symbol) r a (proxy :: Symbol -> *).
 (KnownSymbol f, HasField f r a, DinoType a) =>
 proxy f -> e r -> e a)
-> FieldExp e
getField :: proxy f -> Exp e r -> Exp e a
$cgetField :: forall (e :: * -> *) (f :: Symbol) r a (proxy :: Symbol -> *).
(FieldExp e, KnownSymbol f, HasField f r a, DinoType a) =>
proxy f -> Exp e r -> Exp e a
FieldExp
             , AnnExp ann
             , Text -> Exp e a -> Exp e a -> Exp e a
Text -> Exp e Bool -> Exp e a -> Exp e a
(forall a. Text -> Exp e Bool -> Exp e a -> Exp e a)
-> (forall a.
    (Eq a, Show a) =>
    Text -> Exp e a -> Exp e a -> Exp e a)
-> AssertExp (Exp e)
forall a. (Eq a, Show a) => Text -> Exp e a -> Exp e a -> Exp e a
forall a. Text -> Exp e Bool -> Exp e a -> Exp e a
forall (e :: * -> *) a.
(AssertExp e, Eq a, Show a) =>
Text -> Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a.
AssertExp e =>
Text -> Exp e Bool -> Exp e a -> Exp e a
forall (e :: * -> *).
(forall a. Text -> e Bool -> e a -> e a)
-> (forall a. (Eq a, Show a) => Text -> e a -> e a -> e a)
-> AssertExp e
assertEq :: Text -> Exp e a -> Exp e a -> Exp e a
$cassertEq :: forall (e :: * -> *) a.
(AssertExp e, Eq a, Show a) =>
Text -> Exp e a -> Exp e a -> Exp e a
assert :: Text -> Exp e Bool -> Exp e a -> Exp e a
$cassert :: forall (e :: * -> *) a.
AssertExp e =>
Text -> Exp e Bool -> Exp e a -> Exp e a
AssertExp
             )

instance (ConstExp e, IsString a, DinoType a) => IsString (Exp e a) where
  fromString :: String -> Exp e a
fromString = a -> Exp e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit (a -> Exp e a) -> (String -> a) -> String -> Exp e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. IsString a => String -> a
fromString

instance (ConstExp e, NumExp e, DinoType a, Num a) => Num (Exp e a) where
  fromInteger :: Integer -> Exp e a
fromInteger = e a -> Exp e a
forall k (e :: k -> *) (a :: k). e a -> Exp e a
Exp (e a -> Exp e a) -> (Integer -> e a) -> Integer -> Exp e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit (a -> e a) -> (Integer -> a) -> Integer -> e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger
  + :: Exp e a -> Exp e a -> Exp e a
(+) = Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a. (NumExp e, Num a) => e a -> e a -> e a
add
  (-) = Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a. (NumExp e, Num a) => e a -> e a -> e a
sub
  * :: Exp e a -> Exp e a -> Exp e a
(*) = Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a. (NumExp e, Num a) => e a -> e a -> e a
mul
  abs :: Exp e a -> Exp e a
abs = Exp e a -> Exp e a
forall (e :: * -> *) a. (NumExp e, Num a) => e a -> e a
absE
  signum :: Exp e a -> Exp e a
signum = Exp e a -> Exp e a
forall (e :: * -> *) a. (NumExp e, Num a) => e a -> e a
signE

instance (ConstExp e, NumExp e, FracExp e, DinoType a, Fractional a) =>
         Fractional (Exp e a) where
  fromRational :: Rational -> Exp e a
fromRational = e a -> Exp e a
forall k (e :: k -> *) (a :: k). e a -> Exp e a
Exp (e a -> Exp e a) -> (Rational -> e a) -> Rational -> Exp e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit (a -> e a) -> (Rational -> a) -> Rational -> e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> a
forall a. Fractional a => Rational -> a
fromRational
  / :: Exp e a -> Exp e a -> Exp e a
(/) = Exp e a -> Exp e a -> Exp e a
forall (e :: * -> *) a.
(FracExp e, Fractional a, Eq a) =>
e a -> e a -> e a
fdiv

instance (FieldExp e1, e1 ~ e2, KnownSymbol f, HasField f r a, DinoType a) =>
         IsLabel f (Exp e1 r -> Exp e2 a) where
  fromLabel :: Exp e1 r -> Exp e2 a
fromLabel = Field f -> Exp e2 r -> Exp e2 a
forall (e :: * -> *) (f :: Symbol) r a (proxy :: Symbol -> *).
(FieldExp e, KnownSymbol f, HasField f r a, DinoType a) =>
proxy f -> e r -> e a
getField (Field f
forall (f :: Symbol). Field f
Field @f)



--------------------------------------------------------------------------------
-- * Derived operations
--------------------------------------------------------------------------------

----------------------------------------
-- ** Operations on Dino lists
----------------------------------------

sumE :: (ConstExp e, NumExp e, ListExp e, DinoType a, Num a) => e [a] -> e a
sumE :: e [a] -> e a
sumE = (e a -> e a -> e a) -> e a -> e [a] -> e a
forall (e :: * -> *) a b.
(ListExp e, DinoType a, DinoType b) =>
(e a -> e b -> e a) -> e a -> e [b] -> e a
foldE e a -> e a -> e a
forall (e :: * -> *) a. (NumExp e, Num a) => e a -> e a -> e a
add (a -> e a
forall (e :: * -> *) a. (ConstExp e, DinoType a) => a -> e a
lit a
0)

andE :: (ConstExp e, LogicExp e, ListExp e) => e [Bool] -> e Bool
andE :: e [Bool] -> e Bool
andE = (e Bool -> e Bool -> e Bool) -> e Bool -> e [Bool] -> e Bool
forall (e :: * -> *) a b.
(ListExp e, DinoType a, DinoType b) =>
(e a -> e b -> e a) -> e a -> e [b] -> e a
foldE e Bool -> e Bool -> e Bool
forall (e :: * -> *). LogicExp e => e Bool -> e Bool -> e Bool
(&&) e Bool
forall (e :: * -> *). ConstExp e => e Bool
true

orE :: (ConstExp e, LogicExp e, ListExp e) => e [Bool] -> e Bool
orE :: e [Bool] -> e Bool
orE = (e Bool -> e Bool -> e Bool) -> e Bool -> e [Bool] -> e Bool
forall (e :: * -> *) a b.
(ListExp e, DinoType a, DinoType b) =>
(e a -> e b -> e a) -> e a -> e [b] -> e a
foldE e Bool -> e Bool -> e Bool
forall (e :: * -> *). LogicExp e => e Bool -> e Bool -> e Bool
(||) e Bool
forall (e :: * -> *). ConstExp e => e Bool
false

allE ::
     (ConstExp e, LogicExp e, ListExp e, DinoType a)
  => (e a -> e Bool)
  -> e [a]
  -> e Bool
allE :: (e a -> e Bool) -> e [a] -> e Bool
allE e a -> e Bool
p = e [Bool] -> e Bool
forall (e :: * -> *).
(ConstExp e, LogicExp e, ListExp e) =>
e [Bool] -> e Bool
andE (e [Bool] -> e Bool) -> (e [a] -> e [Bool]) -> e [a] -> e Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e a -> e Bool) -> e [a] -> e [Bool]
forall (e :: * -> *) a b.
(ListExp e, DinoType a) =>
(e a -> e b) -> e [a] -> e [b]
mapE e a -> e Bool
p

anyE ::
     (ConstExp e, LogicExp e, ListExp e, DinoType a)
  => (e a -> e Bool)
  -> e [a]
  -> e Bool
anyE :: (e a -> e Bool) -> e [a] -> e Bool
anyE e a -> e Bool
p = e [Bool] -> e Bool
forall (e :: * -> *).
(ConstExp e, LogicExp e, ListExp e) =>
e [Bool] -> e Bool
orE (e [Bool] -> e Bool) -> (e [a] -> e [Bool]) -> e [a] -> e Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e a -> e Bool) -> e [a] -> e [Bool]
forall (e :: * -> *) a b.
(ListExp e, DinoType a) =>
(e a -> e b) -> e [a] -> e [b]
mapE e a -> e Bool
p

find ::
     (LogicExp e, ListExp e, DinoType a)
  => (e a -> e Bool)
  -> e [a]
  -> e (Maybe a)
find :: (e a -> e Bool) -> e [a] -> e (Maybe a)
find e a -> e Bool
p = e [a] -> e (Maybe a)
forall (e :: * -> *) a. ListExpFO e => e [a] -> e (Maybe a)
headE (e [a] -> e (Maybe a)) -> (e [a] -> e [a]) -> e [a] -> e (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e a -> e Bool) -> e [a] -> e [a]
forall (e :: * -> *) a.
(ListExp e, DinoType a) =>
(e a -> e Bool) -> e [a] -> e [a]
dropWhileE (e Bool -> e Bool
forall (e :: * -> *). LogicExp e => e Bool -> e Bool
not (e Bool -> e Bool) -> (e a -> e Bool) -> e a -> e Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e a -> e Bool
p)

(<++>) :: ListExpFO e => e [a] -> e [a] -> e [a]
<++> :: e [a] -> e [a] -> e [a]
(<++>) = e [a] -> e [a] -> e [a]
forall (e :: * -> *) a. ListExpFO e => e [a] -> e [a] -> e [a]
append



----------------------------------------
-- ** Operations on Haskell lists
----------------------------------------

and :: (ConstExp e, LogicExp e) => [e Bool] -> e Bool
and :: [e Bool] -> e Bool
and = (e Bool -> e Bool -> e Bool) -> e Bool -> [e Bool] -> e Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr e Bool -> e Bool -> e Bool
forall (e :: * -> *). LogicExp e => e Bool -> e Bool -> e Bool
(&&) e Bool
forall (e :: * -> *). ConstExp e => e Bool
true

or :: (ConstExp e, LogicExp e) => [e Bool] -> e Bool
or :: [e Bool] -> e Bool
or = (e Bool -> e Bool -> e Bool) -> e Bool -> [e Bool] -> e Bool
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr e Bool -> e Bool -> e Bool
forall (e :: * -> *). LogicExp e => e Bool -> e Bool -> e Bool
(||) e Bool
forall (e :: * -> *). ConstExp e => e Bool
false

all :: (ConstExp e, LogicExp e) => (a -> e Bool) -> [a] -> e Bool
all :: (a -> e Bool) -> [a] -> e Bool
all a -> e Bool
p = [e Bool] -> e Bool
forall (e :: * -> *).
(ConstExp e, LogicExp e) =>
[e Bool] -> e Bool
and ([e Bool] -> e Bool) -> ([a] -> [e Bool]) -> [a] -> e Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> e Bool) -> [a] -> [e Bool]
forall a b. (a -> b) -> [a] -> [b]
map a -> e Bool
p

any :: (ConstExp e, LogicExp e) => (a -> e Bool) -> [a] -> e Bool
any :: (a -> e Bool) -> [a] -> e Bool
any a -> e Bool
p = [e Bool] -> e Bool
forall (e :: * -> *).
(ConstExp e, LogicExp e) =>
[e Bool] -> e Bool
or ([e Bool] -> e Bool) -> ([a] -> [e Bool]) -> [a] -> e Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> e Bool) -> [a] -> [e Bool]
forall a b. (a -> b) -> [a] -> [b]
map a -> e Bool
p



----------------------------------------
-- ** Optional monad
----------------------------------------

-- | 'Optional' expressions with a 'Monad' instance
--
-- 'Optional' is handy to avoid nested uses of 'maybe'. As an example, here is a
-- safe division function:
--
-- > safeDiv :: _ => e a -> e a -> Optional e (e a)
-- > safeDiv a b = suppose $
-- >   if (b /= lit 0)
-- >     then just (fdiv a b)
-- >     else nothing
--
-- And here is a calculation that defaults to 0 if any of the divisions fails:
--
-- > foo :: _ => Exp e Double -> Exp e Double -> Exp e Double
-- > foo a b = fromOptional 0 $ do
-- >   x <- safeDiv a b
-- >   y <- safeDiv b x
-- >   safeDiv x y
data Optional e a where
  Return :: a -> Optional e a
  Bind :: DinoType a => e (Maybe a) -> (e a -> Optional e b) -> Optional e b
  -- Inspired by the Operational monad

instance Functor (Optional e) where
  fmap :: (a -> b) -> Optional e a -> Optional e b
fmap a -> b
f (Return a
a) = b -> Optional e b
forall a (e :: * -> *). a -> Optional e a
Return (b -> Optional e b) -> b -> Optional e b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  fmap a -> b
f (Bind e (Maybe a)
m e a -> Optional e a
k) = e (Maybe a) -> (e a -> Optional e b) -> Optional e b
forall a (e :: * -> *) b.
DinoType a =>
e (Maybe a) -> (e a -> Optional e b) -> Optional e b
Bind e (Maybe a)
m ((a -> b) -> Optional e a -> Optional e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Optional e a -> Optional e b)
-> (e a -> Optional e a) -> e a -> Optional e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e a -> Optional e a
k)

instance Applicative (Optional e) where
  pure :: a -> Optional e a
pure = a -> Optional e a
forall a (e :: * -> *). a -> Optional e a
Return
  <*> :: Optional e (a -> b) -> Optional e a -> Optional e b
(<*>) = Optional e (a -> b) -> Optional e a -> Optional e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (Optional e) where
  Return a
a >>= :: Optional e a -> (a -> Optional e b) -> Optional e b
>>= a -> Optional e b
k = a -> Optional e b
k a
a
  Bind e (Maybe a)
m e a -> Optional e a
k >>= a -> Optional e b
l = e (Maybe a) -> (e a -> Optional e b) -> Optional e b
forall a (e :: * -> *) b.
DinoType a =>
e (Maybe a) -> (e a -> Optional e b) -> Optional e b
Bind e (Maybe a)
m (e a -> Optional e a
k (e a -> Optional e a) -> (a -> Optional e b) -> e a -> Optional e b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> Optional e b
l)

-- | Lift an optional expression to 'Optional'
suppose :: DinoType a => e (Maybe a) -> Optional e (e a)
suppose :: e (Maybe a) -> Optional e (e a)
suppose e (Maybe a)
a = e (Maybe a) -> (e a -> Optional e (e a)) -> Optional e (e a)
forall a (e :: * -> *) b.
DinoType a =>
e (Maybe a) -> (e a -> Optional e b) -> Optional e b
Bind e (Maybe a)
a e a -> Optional e (e a)
forall a (e :: * -> *). a -> Optional e a
Return

-- | Convert from 'Optional' value to an optional expression
optional ::
     (ConstExp e, CondExp e, LetExp e, DinoType a, DinoType b)
  => e b -- ^ Result if missing
  -> (e a -> e b) -- ^ Result if present
  -> Optional e (e a) -- ^ Value to examine
  -> e b
optional :: e b -> (e a -> e b) -> Optional e (e a) -> e b
optional e b
n e a -> e b
j Optional e (e a)
o = e b -> (e b -> e b) -> e b
forall (e :: * -> *) a b.
(LetExp e, DinoType a) =>
e a -> (e a -> e b) -> e b
share e b
n ((e b -> e b) -> e b) -> (e b -> e b) -> e b
forall a b. (a -> b) -> a -> b
$ \e b
n' ->
  let go :: Optional e (e a) -> e b
go (Return e a
a) = e a -> e b
j e a
a
      go (Bind e (Maybe a)
m e a -> Optional e (e a)
k) = e b -> (e a -> e b) -> e (Maybe a) -> e b
forall (e :: * -> *) a b.
(CondExp e, DinoType a) =>
e b -> (e a -> e b) -> e (Maybe a) -> e b
maybe e b
n' (Optional e (e a) -> e b
go (Optional e (e a) -> e b)
-> (e a -> Optional e (e a)) -> e a -> e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e a -> Optional e (e a)
k) e (Maybe a)
m
   in Optional e (e a) -> e b
go Optional e (e a)
o

runOptional ::
     (ConstExp e, CondExp e, LetExp e, DinoType a)
  => Optional e (e a)
  -> e (Maybe a)
runOptional :: Optional e (e a) -> e (Maybe a)
runOptional = e (Maybe a)
-> (e a -> e (Maybe a)) -> Optional e (e a) -> e (Maybe a)
forall (e :: * -> *) a b.
(ConstExp e, CondExp e, LetExp e, DinoType a, DinoType b) =>
e b -> (e a -> e b) -> Optional e (e a) -> e b
optional e (Maybe a)
forall (e :: * -> *) a. (ConstExp e, DinoType a) => e (Maybe a)
nothing e a -> e (Maybe a)
forall (e :: * -> *) a. CondExpFO e => e a -> e (Maybe a)
just

-- | Extract an 'Optional' value
fromOptional ::
     (ConstExp e, CondExp e, LetExp e, DinoType a)
  => e a -- ^ Default value (in case the 'Optional' value is missing)
  -> Optional e (e a)
  -> e a
fromOptional :: e a -> Optional e (e a) -> e a
fromOptional e a
d = e a -> (e a -> e a) -> Optional e (e a) -> e a
forall (e :: * -> *) a b.
(ConstExp e, CondExp e, LetExp e, DinoType a, DinoType b) =>
e b -> (e a -> e b) -> Optional e (e a) -> e b
optional e a
d e a -> e a
forall a. a -> a
id