{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
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
class ConstExp e where
lit :: DinoType a => a -> e a
default lit :: Applicative e => a -> e a
lit = pure
true, false :: ConstExp e => e Bool
true = lit True
false = lit False
text :: ConstExp e => Text -> e Text
text = lit
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
fromIntegral :: (Integral a, DinoType b, Num b) => e a -> e b
floor :: (RealFrac a, DinoType b, Integral b) => e a -> e b
truncate :: (RealFrac a, DinoType b, Integral b) => e a -> e b
roundN :: RealFrac a => Int -> e a -> e a
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 = liftA2 (+)
sub = liftA2 (-)
mul = liftA2 (*)
absE = liftA abs
signE = liftA signum
fromIntegral = liftA Prelude.fromIntegral
floor = liftA (Prelude.fromInteger . Prelude.floor)
truncate = liftA (Prelude.fromInteger . Prelude.truncate)
roundN n = liftA roundN'
where
roundN' a = (fromInteger $ Prelude.round $ a * (10^n)) / (10.0^^n)
fromInt :: (NumExp e, DinoType a, Num a) => e Integer -> e a
fromInt = fromIntegral
class FracExp e where
fdiv :: (Fractional a, Eq a) => e a -> e a -> e a
default fdiv :: (Applicative e, Fractional a) => e a -> e a -> e a
fdiv = liftA2 (/)
(./) ::
( ConstExp e
, FracExp e
, CompareExp e
, CondExpFO e
, DinoType a
, Fractional a
)
=> e a
-> e a
-> e a
a ./ b = ifThenElse (b == lit 0) (lit 0) (fdiv a b)
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 = liftA Prelude.not
conj = liftA2 (Prelude.&&)
disj = liftA2 (Prelude.||)
xor = liftA2 (Prelude./=)
(&&), (||) :: LogicExp e => e Bool -> e Bool -> e Bool
(&&) = conj
(||) = disj
infixr 3 &&
infixr 2 ||
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 = liftA2 (Prelude.==)
neq = liftA2 (Prelude./=)
lt = liftA2 (Prelude.<)
gt = liftA2 (Prelude.>)
lte = liftA2 (Prelude.<=)
gte = liftA2 (Prelude.>=)
min = liftA2 Prelude.min
max = liftA2 Prelude.max
(==), (/=) :: (Eq a, CompareExp e) => e a -> e a -> e Bool
(==) = eq
(/=) = neq
(<), (>), (<=), (>=) :: (Ord a, CompareExp e) => e a -> e a -> e Bool
(<) = lt
(>) = gt
(<=) = lte
(>=) = gte
infix 4 ==, /=, <, >, <=, >=
(==!) :: (ConstExp e, CompareExp e, DinoType a) => e a -> a -> e Bool
a ==! b = a == lit b
infix 4 ==!
data a :-> b = a :-> b
deriving (Eq, Show, Foldable, Functor, Traversable)
instance Bifunctor (:->) where
bimap f g (a :-> b) = f a :-> g b
(-->) :: a -> b -> (a :-> b)
(-->) = (:->)
infix 1 :->, -->
data Otherwise = Otherwise
class CondExpFO e where
just :: e a -> e (Maybe a)
cases ::
[e Bool :-> e a]
-> (Otherwise :-> e a)
-> e a
partial_cases ::
HasCallStack
=> [e Bool :-> e a]
-> e a
default just :: Applicative e => e a -> e (Maybe a)
just = liftA Just
default cases :: Monad e => [e Bool :-> e a] -> (Otherwise :-> e a) -> e a
cases cs (_ :-> d) = do
f <- firstM (\(c :-> _) -> c) cs
case f of
Nothing -> d
Just (_ :-> a) -> a
default partial_cases :: (Monad e, HasCallStack) => [e Bool :-> e a] -> e a
partial_cases = default_partial_cases
class CondExpFO e => CondExp e where
maybe ::
DinoType a
=> e b
-> (e a -> e b)
-> e (Maybe a)
-> e b
default maybe :: Monad e => e b -> (e a -> e b) -> e (Maybe a) -> e b
maybe n j m = Prelude.maybe n (j . return) =<< m
default_partial_cases :: (CondExpFO e, HasCallStack) => [e Bool :-> e a] -> e a
default_partial_cases cs =
cases cs $ (Otherwise --> error "partial_cases: no matching case")
nothing :: (ConstExp e, DinoType a) => e (Maybe a)
nothing = lit Nothing
isJust :: (ConstExp e, CondExp e, DinoType a) => e (Maybe a) -> e Bool
isJust = maybe false (const true)
match ::
CondExpFO e
=> a
-> [(a -> e Bool) :-> e b]
-> (Otherwise :-> e b)
-> e b
match a = cases . map (first ($ a))
matchConst ::
(ConstExp e, CompareExp e, CondExpFO e, DinoType a)
=> e a
-> [a :-> e b]
-> (Otherwise :-> e b)
-> e b
matchConst a = match a . map (first ((==) . lit))
matchConstFull ::
( ConstExp e
, CompareExp e
, CondExpFO e
, DinoType a
, Show a
, Enum a
, Bounded a
, HasCallStack
)
=> e a
-> [a :-> e b]
-> e b
matchConstFull a cs
| null missing = partial_cases $ map (first (a ==!)) cs
| otherwise = error $ "matchConstFull: missing cases " ++ show missing
where
domain = [minBound .. maxBound]
missing = domain \\ [b | b :-> _ <- cs]
ifThenElse ::
CondExpFO e
=> e Bool
-> e a
-> e a
-> e a
ifThenElse c t f = cases [c --> t] (Otherwise --> f)
fromMaybe :: (CondExp e, DinoType a) => e a -> e (Maybe a) -> e a
fromMaybe n = maybe n id
class ListExpFO e where
range ::
Enum a
=> e a
-> e a
-> 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 = liftA2 $ \l u -> [l .. u]
list = sequenceA
headE = liftA headMay
append = liftA2 (++)
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]
foldE ::
(DinoType a, DinoType b)
=> (e a -> e b -> e a)
-> e a
-> e [b]
-> 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 f as = mapM (f . return) =<< as
dropWhileE p as = dropWhileM (p . return) =<< as
foldE f a bs = do
a' <- a
bs' <- bs
foldM (\aa bb -> f (return aa) (return bb)) a' bs'
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 = liftA2 (,)
fstE = liftA fst
sndE = liftA snd
class LetExp e where
letE ::
DinoType a
=> Text
-> e a
-> (e a -> e b)
-> e b
default letE :: Monad e => Text -> e a -> (e a -> e b) -> e b
letE _ a body = a >>= body . return
share ::
(LetExp e, DinoType a)
=> e a
-> (e a -> e b)
-> e b
share = letE "share"
shared ::
(LetExp e, DinoType a)
=> (e a -> e b)
-> e a
-> e b
shared = flip share
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 _ = liftA (GHC.getField @f)
instance (f1 ~ f2) => IsLabel f1 (Field f2) where
fromLabel = Field
field ::
(FieldExp e, KnownSymbol f, HasField f r a, DinoType a)
=> Field f
-> e r
-> e a
field = getField
(<.) ::
(FieldExp e, KnownSymbol f, HasField f r a, DinoType a)
=> Field f
-> e r
-> e a
(<.) = getField
infixr 9 <.
class AnnExp ann e where
ann :: ann -> e a -> e a
ann _ = id
class AssertExp e where
assert ::
Text
-> e Bool
-> e a
-> e a
assert _ _ = id
assertEq ::
(Eq a, Show a)
=> Text
-> e a
-> e a
-> e a
assertEq _ _ act = act
newtype Exp e a = Exp
{ unExp :: e a
} deriving ( Eq
, Show
, Functor
, Applicative
, Monad
, ConstExp
, NumExp
, FracExp
, LogicExp
, CompareExp
, CondExpFO
, CondExp
, ListExpFO
, ListExp
, LetExp
, FieldExp
, AnnExp ann
, AssertExp
)
instance (ConstExp e, IsString a, DinoType a) => IsString (Exp e a) where
fromString = lit . fromString
instance (ConstExp e, NumExp e, DinoType a, Num a) => Num (Exp e a) where
fromInteger = Exp . lit . fromInteger
(+) = add
(-) = sub
(*) = mul
abs = absE
signum = signE
instance (ConstExp e, NumExp e, FracExp e, DinoType a, Fractional a) =>
Fractional (Exp e a) where
fromRational = Exp . lit . fromRational
(/) = fdiv
instance (FieldExp e1, e1 ~ e2, KnownSymbol f, HasField f r a, DinoType a) =>
IsLabel f (Exp e1 r -> Exp e2 a) where
fromLabel = getField (Field @f)
sumE :: (ConstExp e, NumExp e, ListExp e, DinoType a, Num a) => e [a] -> e a
sumE = foldE add (lit 0)
andE :: (ConstExp e, LogicExp e, ListExp e) => e [Bool] -> e Bool
andE = foldE (&&) true
orE :: (ConstExp e, LogicExp e, ListExp e) => e [Bool] -> e Bool
orE = foldE (||) false
allE ::
(ConstExp e, LogicExp e, ListExp e, DinoType a)
=> (e a -> e Bool)
-> e [a]
-> e Bool
allE p = andE . mapE p
anyE ::
(ConstExp e, LogicExp e, ListExp e, DinoType a)
=> (e a -> e Bool)
-> e [a]
-> e Bool
anyE p = orE . mapE p
find ::
(LogicExp e, ListExp e, DinoType a)
=> (e a -> e Bool)
-> e [a]
-> e (Maybe a)
find p = headE . dropWhileE (not . p)
(<++>) :: ListExpFO e => e [a] -> e [a] -> e [a]
(<++>) = append
and :: (ConstExp e, LogicExp e) => [e Bool] -> e Bool
and = foldr (&&) true
or :: (ConstExp e, LogicExp e) => [e Bool] -> e Bool
or = foldr (||) false
all :: (ConstExp e, LogicExp e) => (a -> e Bool) -> [a] -> e Bool
all p = and . map p
any :: (ConstExp e, LogicExp e) => (a -> e Bool) -> [a] -> e Bool
any p = or . map p
data Optional e a where
Return :: a -> Optional e a
Bind :: DinoType a => e (Maybe a) -> (e a -> Optional e b) -> Optional e b
instance Functor (Optional e) where
fmap f (Return a) = Return $ f a
fmap f (Bind m k) = Bind m (fmap f . k)
instance Applicative (Optional e) where
pure = Return
(<*>) = ap
instance Monad (Optional e) where
Return a >>= k = k a
Bind m k >>= l = Bind m (k >=> l)
suppose :: DinoType a => e (Maybe a) -> Optional e (e a)
suppose a = Bind a Return
optional ::
(ConstExp e, CondExp e, LetExp e, DinoType a, DinoType b)
=> e b
-> (e a -> e b)
-> Optional e (e a)
-> e b
optional n j o = share n $ \n' ->
let go (Return a) = j a
go (Bind m k) = maybe n' (go . k) m
in go o
runOptional ::
(ConstExp e, CondExp e, LetExp e, DinoType a)
=> Optional e (e a)
-> e (Maybe a)
runOptional = optional nothing just
fromOptional ::
(ConstExp e, CondExp e, LetExp e, DinoType a)
=> e a
-> Optional e (e a)
-> e a
fromOptional d = optional d id