{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Typed deep embedding of simple C expressions
--
-- This is a subset of C expressions that only have simple non-compound and
-- non-pointed types, and that don't contain any control structures.
--
-- (Of course, nothing stops one from translating 'CExp' to something other than
-- C, but its constructors and set of supported types is inspired by C.)

module Language.Embedded.CExp where



import Data.Array
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Typeable

import Language.Syntactic
import Language.Syntactic.Functional (Denotation)
import Language.Syntactic.TH

import Language.C.Quote.C
import Language.C.Syntax (Type, UnOp (..), BinOp (..), Exp (UnOp, BinOp))
import qualified Language.C.Syntax as C

import Language.C.Monad
import Language.Embedded.Expression
import Language.Embedded.Backend.C
import Language.Embedded.Imperative.CMD (IArr (..))



--------------------------------------------------------------------------------
-- * Expressions
--------------------------------------------------------------------------------

data Unary a
  where
    UnNeg :: Num a => Unary (a -> a)
    UnNot :: Unary (Bool -> Bool)

evalUnary :: Unary a -> a
evalUnary :: Unary a -> a
evalUnary Unary a
UnNeg = a
forall a. Num a => a -> a
negate
evalUnary Unary a
UnNot = a
Bool -> Bool
not

unaryOp :: Unary a -> UnOp
unaryOp :: Unary a -> UnOp
unaryOp Unary a
UnNeg = UnOp
Negate
unaryOp Unary a
UnNot = UnOp
Lnot

data Binary a
  where
    BiAdd  :: Num a            => Binary (a -> a -> a)
    BiSub  :: Num a            => Binary (a -> a -> a)
    BiMul  :: Num a            => Binary (a -> a -> a)
    BiDiv  :: Fractional a     => Binary (a -> a -> a)
    BiQuot :: Integral a       => Binary (a -> a -> a)
    BiRem  :: Integral a       => Binary (a -> a -> a)
    BiAnd  ::                     Binary (Bool -> Bool -> Bool)
    BiOr   ::                     Binary (Bool -> Bool -> Bool)
    BiEq   :: CType a          => Binary (a -> a -> Bool)
    BiNEq  :: CType a          => Binary (a -> a -> Bool)
    BiLt   :: (Ord a, CType a) => Binary (a -> a -> Bool)
    BiGt   :: (Ord a, CType a) => Binary (a -> a -> Bool)
    BiLe   :: (Ord a, CType a) => Binary (a -> a -> Bool)
    BiGe   :: (Ord a, CType a) => Binary (a -> a -> Bool)

evalBinary :: Binary a -> a
evalBinary :: Binary a -> a
evalBinary Binary a
BiAdd  = a
forall a. Num a => a -> a -> a
(+)
evalBinary Binary a
BiSub  = (-)
evalBinary Binary a
BiMul  = a
forall a. Num a => a -> a -> a
(*)
evalBinary Binary a
BiDiv  = a
forall a. Fractional a => a -> a -> a
(/)
evalBinary Binary a
BiQuot = a
forall a. Integral a => a -> a -> a
quot
evalBinary Binary a
BiRem  = a
forall a. Integral a => a -> a -> a
rem
evalBinary Binary a
BiAnd  = a
Bool -> Bool -> Bool
(&&)
evalBinary Binary a
BiOr   = a
Bool -> Bool -> Bool
(||)
evalBinary Binary a
BiEq   = a
forall a. Eq a => a -> a -> Bool
(==)
evalBinary Binary a
BiNEq  = a
forall a. Eq a => a -> a -> Bool
(/=)
evalBinary Binary a
BiLt   = a
forall a. Ord a => a -> a -> Bool
(<)
evalBinary Binary a
BiGt   = a
forall a. Ord a => a -> a -> Bool
(>)
evalBinary Binary a
BiLe   = a
forall a. Ord a => a -> a -> Bool
(<=)
evalBinary Binary a
BiGe   = a
forall a. Ord a => a -> a -> Bool
(>=)

binaryOp :: Binary a -> BinOp
binaryOp :: Binary a -> BinOp
binaryOp Binary a
BiAdd  = BinOp
Add
binaryOp Binary a
BiSub  = BinOp
Sub
binaryOp Binary a
BiMul  = BinOp
Mul
binaryOp Binary a
BiDiv  = BinOp
Div
binaryOp Binary a
BiQuot = BinOp
Div
binaryOp Binary a
BiRem  = BinOp
Mod
binaryOp Binary a
BiAnd  = BinOp
Land
binaryOp Binary a
BiOr   = BinOp
Lor
binaryOp Binary a
BiEq   = BinOp
Eq
binaryOp Binary a
BiNEq  = BinOp
Ne
binaryOp Binary a
BiLt   = BinOp
Lt
binaryOp Binary a
BiGt   = BinOp
Gt
binaryOp Binary a
BiLe   = BinOp
Le
binaryOp Binary a
BiGe   = BinOp
Ge

type SupportCode = forall m . MonadC m => m ()
  -- Only needed because GHC 7.8 can't represent tuple constraints (like
  -- `MonadC`) in Template Haskell.

-- | Syntactic symbols for C
data Sym sig
  where
    -- Literal
    Lit   :: String -> a -> Sym (Full a)
    -- Predefined constant
    Const :: String -> a -> Sym (Full a)
      -- The difference between `Lit` and `Const` is that the latter gets turned
      -- into a variable in the C code. It is like `Var`, except that it can
      -- also be evaluated.
    -- Function call
    Fun   :: Signature sig => String -> Denotation sig -> Sym sig
    -- Unary operator
    UOp   :: Unary (a -> b) -> Sym (a :-> Full b)
    -- Binary operator
    Op    :: Binary (a -> b -> c) -> Sym (a :-> b :-> Full c)
    -- Type casting (ignored when generating code)
    Cast  :: (a -> b) -> Sym (a :-> Full b)
    -- Conditional
    Cond  :: Sym (Bool :-> a :-> a :-> Full a)
    -- Variable (only for compilation)
    Var   :: VarId -> Sym (Full a)
    -- Unsafe array indexing
    ArrIx :: (Integral i, Ix i) => IArr i a -> Sym (i :-> Full a)
    -- Attach extra code to an expression
    WithCode :: SupportCode -> Sym (a :-> Full a)

deriveSymbol ''Sym

instance Render Sym
  where
    renderSym :: Sym sig -> String
renderSym (Lit String
a a
_)    = String
a
    renderSym (Const String
a a
_)  = String
a
    renderSym (Fun String
name Denotation sig
_) = String
name
    renderSym (UOp Unary (a -> b)
op)     = UnOp -> String
forall a. Show a => a -> String
show (UnOp -> String) -> UnOp -> String
forall a b. (a -> b) -> a -> b
$ Unary (a -> b) -> UnOp
forall a. Unary a -> UnOp
unaryOp Unary (a -> b)
op
    renderSym (Op Binary (a -> b -> c)
op)      = BinOp -> String
forall a. Show a => a -> String
show (BinOp -> String) -> BinOp -> String
forall a b. (a -> b) -> a -> b
$ Binary (a -> b -> c) -> BinOp
forall a. Binary a -> BinOp
binaryOp Binary (a -> b -> c)
op
    renderSym (Cast a -> b
_)     = String
"cast"
    renderSym (Var String
v)      = String
v
    renderSym (ArrIx (IArrComp String
arr)) = String
"ArrIx " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arr
    renderSym (ArrIx IArr i a
_)              = String
"ArrIx ..."
    renderSym (WithCode SupportCode
_) = String
"WithCode ..."

    renderArgs :: [String] -> Sym sig -> String
renderArgs = [String] -> Sym sig -> String
forall (sym :: * -> *) a. Render sym => [String] -> sym a -> String
renderArgsSmart

instance Equality Sym
  where
    equal :: Sym a -> Sym b -> Bool
equal = Sym a -> Sym b -> Bool
forall (sym :: * -> *) a b. Render sym => sym a -> sym b -> Bool
equalDefault
    hash :: Sym a -> Hash
hash  = Sym a -> Hash
forall (sym :: * -> *) a. Render sym => sym a -> Hash
hashDefault

instance StringTree Sym

instance Symbol T where symSig :: T sig -> SigRep sig
symSig (T Sym sig
s) = Sym sig -> SigRep sig
forall (sym :: * -> *) sig. Symbol sym => sym sig -> SigRep sig
symSig Sym sig
s

instance Render T
  where
    renderSym :: T sig -> String
renderSym (T Sym sig
s)     = Sym sig -> String
forall (sym :: * -> *) sig. Render sym => sym sig -> String
renderSym Sym sig
s
    renderArgs :: [String] -> T sig -> String
renderArgs [String]
as (T Sym sig
s) = [String] -> Sym sig -> String
forall (sym :: * -> *) sig.
Render sym =>
[String] -> sym sig -> String
renderArgs [String]
as Sym sig
s

instance Equality T
  where
    equal :: T a -> T b -> Bool
equal (T Sym a
s) (T Sym b
t) = Sym a -> Sym b -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal Sym a
s Sym b
t
    hash :: T a -> Hash
hash (T Sym a
s)        = Sym a -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash Sym a
s

instance StringTree T
  where
    stringTreeSym :: [Tree String] -> T a -> Tree String
stringTreeSym [Tree String]
as (T Sym a
s) = [Tree String] -> Sym a -> Tree String
forall (sym :: * -> *) a.
StringTree sym =>
[Tree String] -> sym a -> Tree String
stringTreeSym [Tree String]
as Sym a
s

data T sig
  where
    T :: CType (DenResult sig) => { T sig -> Sym sig
unT :: Sym sig } -> T sig

-- | C expression
newtype CExp a = CExp {CExp a -> ASTF T a
unCExp :: ASTF T a}
  deriving (CExp a -> CExp a -> Bool
(CExp a -> CExp a -> Bool)
-> (CExp a -> CExp a -> Bool) -> Eq (CExp a)
forall a. CExp a -> CExp a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CExp a -> CExp a -> Bool
$c/= :: forall a. CExp a -> CExp a -> Bool
== :: CExp a -> CExp a -> Bool
$c== :: forall a. CExp a -> CExp a -> Bool
Eq)

instance Syntactic (CExp a)
  where
    type Domain (CExp a)   = T
    type Internal (CExp a) = a
    desugar :: CExp a -> ASTF (Domain (CExp a)) (Internal (CExp a))
desugar = CExp a -> ASTF (Domain (CExp a)) (Internal (CExp a))
forall a. CExp a -> ASTF T a
unCExp
    sugar :: ASTF (Domain (CExp a)) (Internal (CExp a)) -> CExp a
sugar   = ASTF (Domain (CExp a)) (Internal (CExp a)) -> CExp a
forall a. ASTF T a -> CExp a
CExp

evalSym :: Sym sig -> Denotation sig
evalSym :: Sym sig -> Denotation sig
evalSym (Lit String
_ a
a)   = a
Denotation sig
a
evalSym (Const String
_ a
a) = a
Denotation sig
a
evalSym (Fun String
_ Denotation sig
f)   = Denotation sig
f
evalSym (UOp Unary (a -> b)
uop)   = Unary (a -> b) -> a -> b
forall a. Unary a -> a
evalUnary Unary (a -> b)
uop
evalSym (Op Binary (a -> b -> c)
bop)    = Binary (a -> b -> c) -> a -> b -> c
forall a. Binary a -> a
evalBinary Binary (a -> b -> c)
bop
evalSym (Cast a -> b
f)    = Denotation sig
a -> b
f
evalSym Sym sig
Cond        = \Bool
c a
t a
f -> if Bool
c then a
t else a
f
evalSym (ArrIx (IArrRun Array i a
arr)) = \i
i ->
    if i
ii -> i -> Bool
forall a. Ord a => a -> a -> Bool
<i
l Bool -> Bool -> Bool
|| i
ii -> i -> Bool
forall a. Ord a => a -> a -> Bool
>i
h
      then String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"index "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (i -> Integer
forall a. Integral a => a -> Integer
toInteger i
i)
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" out of bounds "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Integer, Integer) -> String
forall a. Show a => a -> String
show (i -> Integer
forall a. Integral a => a -> Integer
toInteger i
l, i -> Integer
forall a. Integral a => a -> Integer
toInteger i
h)
      else Array i a
arrArray i a -> i -> a
forall i e. Ix i => Array i e -> i -> e
!i
i
  where
    (i
l,i
h) = Array i a -> (i, i)
forall i e. Array i e -> (i, i)
bounds Array i a
arr
evalSym (WithCode SupportCode
_) = Denotation sig
forall a. a -> a
id
evalSym (Var String
v) = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"evalCExp: cannot evaluate variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v

-- | Evaluate an expression
evalCExp :: CExp a -> a
evalCExp :: CExp a -> a
evalCExp (CExp ASTF T a
e) = ASTF T a -> Denotation (Full a)
forall sig. AST T sig -> Denotation sig
go ASTF T a
e
  where
    go :: AST T sig -> Denotation sig
    go :: AST T sig -> Denotation sig
go (Sym (T Sym sig
s)) = Sym sig -> Denotation sig
forall sig. Sym sig -> Denotation sig
evalSym Sym sig
s
    go (AST T (a :-> sig)
f :$ AST T (Full a)
a)    = AST T (a :-> sig) -> Denotation (a :-> sig)
forall sig. AST T sig -> Denotation sig
go AST T (a :-> sig)
f (a -> Denotation sig) -> a -> Denotation sig
forall a b. (a -> b) -> a -> b
$ AST T (Full a) -> Denotation (Full a)
forall sig. AST T sig -> Denotation sig
go AST T (Full a)
a

instance FreeExp CExp
  where
    type FreePred CExp = CType
    constExp :: a -> CExp a
constExp a
a = ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp (ASTF T a -> CExp a) -> ASTF T a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (Full a) -> ASTF T a
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (T (Full a) -> ASTF T a) -> T (Full a) -> ASTF T a
forall a b. (a -> b) -> a -> b
$ Sym (Full a) -> T (Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Full a) -> T (Full a)) -> Sym (Full a) -> T (Full a)
forall a b. (a -> b) -> a -> b
$ String -> a -> Sym (Full a)
forall a. String -> a -> Sym (Full a)
Lit (a -> String
forall a. Show a => a -> String
show a
a) a
a
    varExp :: String -> CExp a
varExp = ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp (ASTF T a -> CExp a) -> (String -> ASTF T a) -> String -> CExp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T (Full a) -> ASTF T a
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (T (Full a) -> ASTF T a)
-> (String -> T (Full a)) -> String -> ASTF T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sym (Full a) -> T (Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Full a) -> T (Full a))
-> (String -> Sym (Full a)) -> String -> T (Full a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Sym (Full a)
forall a. String -> Sym (Full a)
Var

instance EvalExp CExp where evalExp :: CExp a -> a
evalExp = CExp a -> a
forall a. CExp a -> a
evalCExp

-- | Compile an expression
compCExp :: forall m a . MonadC m => CExp a -> m Exp
compCExp :: CExp a -> m Exp
compCExp = (forall sig.
 (a ~ DenResult sig) =>
 T sig -> Args (AST T) sig -> m Exp)
-> ASTF T a -> m Exp
forall (sym :: * -> *) a b.
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> b)
-> ASTF sym a -> b
simpleMatch (\(T s) -> Sym sig -> Args (AST T) sig -> m Exp
forall sig.
CType (DenResult sig) =>
Sym sig -> Args (AST T) sig -> m Exp
go Sym sig
s) (ASTF T a -> m Exp) -> (CExp a -> ASTF T a) -> CExp a -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExp a -> ASTF T a
forall a. CExp a -> ASTF T a
unCExp
  where
    compCExp' :: ASTF T b -> m Exp
    compCExp' :: ASTF T b -> m Exp
compCExp' = CExp b -> m Exp
forall (m :: * -> *) a. MonadC m => CExp a -> m Exp
compCExp (CExp b -> m Exp) -> (ASTF T b -> CExp b) -> ASTF T b -> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF T b -> CExp b
forall a. ASTF T a -> CExp a
CExp

    typeOfSym :: forall sig m . MonadC m =>
        CType (DenResult sig) => Sym sig -> m Type
    typeOfSym :: Sym sig -> m Type
typeOfSym Sym sig
_ = Proxy (DenResult sig) -> m Type
forall a (m :: * -> *) (proxy :: * -> *).
(CType a, MonadC m) =>
proxy a -> m Type
cType (Proxy (DenResult sig)
forall k (t :: k). Proxy t
Proxy :: Proxy (DenResult sig))

    go :: CType (DenResult sig) => Sym sig -> Args (AST T) sig -> m Exp
    go :: Sym sig -> Args (AST T) sig -> m Exp
go (Var String
v) Args (AST T) sig
Nil   = String -> m ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar String
v m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $id:v |]
    go (Lit String
_ a
a) Args (AST T) sig
Nil = a -> m Exp
forall a (m :: * -> *). (CType a, MonadC m) => a -> m Exp
cLit a
a
    go (Const String
const a
_) Args (AST T) sig
Nil = do
      String -> m ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar String
const
      Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $id:const |]
    go (Fun String
fun Denotation sig
_) Args (AST T) sig
args = do
      [Exp]
as <- [m Exp] -> m [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([m Exp] -> m [Exp]) -> [m Exp] -> m [Exp]
forall a b. (a -> b) -> a -> b
$ (forall a. AST T (Full a) -> m Exp) -> Args (AST T) sig -> [m Exp]
forall (c :: * -> *) b sig.
(forall a. c (Full a) -> b) -> Args c sig -> [b]
listArgs forall a. AST T (Full a) -> m Exp
compCExp' Args (AST T) sig
args
      Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $id:fun($args:as) |]
    go (UOp Unary (a -> b)
uop) (AST T (Full a)
a :* Args (AST T) sig1
Nil) = do
      Exp
a' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
a
      Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ UnOp -> Exp -> SrcLoc -> Exp
UnOp (Unary (a -> b) -> UnOp
forall a. Unary a -> UnOp
unaryOp Unary (a -> b)
uop) Exp
a' SrcLoc
forall a. Monoid a => a
mempty
    go (Op Binary (a -> b -> c)
bop) (AST T (Full a)
a :* AST T (Full a)
b :* Args (AST T) sig1
Nil) = do
      Exp
a' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
a
      Exp
b' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
b
      Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ BinOp -> Exp -> Exp -> SrcLoc -> Exp
BinOp (Binary (a -> b -> c) -> BinOp
forall a. Binary a -> BinOp
binaryOp Binary (a -> b -> c)
bop) Exp
a' Exp
b' SrcLoc
forall a. Monoid a => a
mempty
    go s :: Sym sig
s@(Cast a -> b
f) (AST T (Full a)
a :* Args (AST T) sig1
Nil) = do
      Exp
a' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
a
      Type
t <- Sym sig -> m Type
forall sig (m :: * -> *).
(MonadC m, CType (DenResult sig)) =>
Sym sig -> m Type
typeOfSym Sym sig
s
      Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp|($ty:t) $a'|]
          -- Explicit casting is usually not needed. But sometimes it is. For
          -- example
          --
          --     printf("%f",i);
          --
          -- gives an error if `i` is an integer. The most robust option is
          -- probably to always have explicit casts. In many cases it probably
          -- also makes the generated code more readable.
    go Sym sig
Cond (AST T (Full a)
c :* AST T (Full a)
t :* AST T (Full a)
f :* Args (AST T) sig1
Nil) = do
      Exp
c' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
c
      Exp
t' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
t
      Exp
f' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
f
      Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> SrcLoc -> Exp
C.Cond Exp
c' Exp
t' Exp
f' SrcLoc
forall a. Monoid a => a
mempty
    go (ArrIx IArr i a
arr) (AST T (Full a)
i :* Args (AST T) sig1
Nil) = do
      Exp
i' <- AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
i
      IArr i a -> m ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar IArr i a
arr
      Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $id:arr[$i'] |]
    go (WithCode SupportCode
code) (AST T (Full a)
a :* Args (AST T) sig1
Nil) = m ()
SupportCode
code m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> AST T (Full a) -> m Exp
forall a. AST T (Full a) -> m Exp
compCExp' AST T (Full a)
a

instance CompExp CExp where compExp :: CExp a -> m Exp
compExp = CExp a -> m Exp
forall (m :: * -> *) a. MonadC m => CExp a -> m Exp
compCExp

-- | One-level constant folding: if all immediate sub-expressions are literals,
-- the expression is reduced to a single literal
constFold :: CExp a -> CExp a
constFold :: CExp a -> CExp a
constFold = ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp (ASTF T a -> CExp a) -> (CExp a -> ASTF T a) -> CExp a -> CExp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall sig.
 (a ~ DenResult sig) =>
 T sig -> Args (AST T) sig -> ASTF T a)
-> ASTF T a -> ASTF T a
forall (sym :: * -> *) a (c :: * -> *).
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (Full a))
-> ASTF sym a -> c (Full a)
match forall sig.
(a ~ DenResult sig) =>
T sig -> Args (AST T) sig -> ASTF T a
forall sig.
T sig -> Args (AST T) sig -> AST T (Full (DenResult sig))
go (ASTF T a -> ASTF T a)
-> (CExp a -> ASTF T a) -> CExp a -> ASTF T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExp a -> ASTF T a
forall a. CExp a -> ASTF T a
unCExp
  where
    go :: T sig -> Args (AST T) sig -> AST T (Full (DenResult sig))
    go :: T sig -> Args (AST T) sig -> AST T (Full (DenResult sig))
go (T Sym sig
s) Args (AST T) sig
as = AST T (Full (DenResult sig))
res
      where
        e :: AST T (Full (DenResult sig))
e   = AST T sig -> Args (AST T) sig -> AST T (Full (DenResult sig))
forall (sym :: * -> *) sig.
AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)
appArgs (T sig -> AST T sig
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (T sig -> AST T sig) -> T sig -> AST T sig
forall a b. (a -> b) -> a -> b
$ Sym sig -> T sig
forall sig. CType (DenResult sig) => Sym sig -> T sig
T Sym sig
s) Args (AST T) sig
as
        res :: AST T (Full (DenResult sig))
res = if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (forall a. AST T (Full a) -> Bool) -> Args (AST T) sig -> [Bool]
forall (c :: * -> *) b sig.
(forall a. c (Full a) -> b) -> Args c sig -> [b]
listArgs (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> (ASTF T a -> Maybe a) -> ASTF T a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExp a -> Maybe a
forall a. CExp a -> Maybe a
viewLit (CExp a -> Maybe a) -> (ASTF T a -> CExp a) -> ASTF T a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp) Args (AST T) sig
as
                then CExp (DenResult sig) -> AST T (Full (DenResult sig))
forall a. CExp a -> ASTF T a
unCExp (CExp (DenResult sig) -> AST T (Full (DenResult sig)))
-> CExp (DenResult sig) -> AST T (Full (DenResult sig))
forall a b. (a -> b) -> a -> b
$ DenResult sig -> CExp (DenResult sig)
forall a. CType a => a -> CExp a
value (DenResult sig -> CExp (DenResult sig))
-> DenResult sig -> CExp (DenResult sig)
forall a b. (a -> b) -> a -> b
$ CExp (DenResult sig) -> DenResult sig
forall a. CExp a -> a
evalCExp (CExp (DenResult sig) -> DenResult sig)
-> CExp (DenResult sig) -> DenResult sig
forall a b. (a -> b) -> a -> b
$ AST T (Full (DenResult sig)) -> CExp (DenResult sig)
forall a. ASTF T a -> CExp a
CExp AST T (Full (DenResult sig))
e
                else AST T (Full (DenResult sig))
e
  -- Deeper constant folding would require a way to witness `Show` for arbitrary
  -- sub-expressions. This is certainly doable, but seems to complicate things
  -- for not much gain (currently).

castAST :: forall a b . Typeable b => ASTF T a -> Maybe (ASTF T b)
castAST :: ASTF T a -> Maybe (ASTF T b)
castAST ASTF T a
a = (forall sig.
 (a ~ DenResult sig) =>
 T sig -> Args (AST T) sig -> Maybe (ASTF T b))
-> ASTF T a -> Maybe (ASTF T b)
forall (sym :: * -> *) a b.
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> b)
-> ASTF sym a -> b
simpleMatch forall sig.
(a ~ DenResult sig) =>
T sig -> Args (AST T) sig -> Maybe (ASTF T b)
forall sig.
(DenResult sig ~ a) =>
T sig -> Args (AST T) sig -> Maybe (ASTF T b)
go ASTF T a
a
  where
    go :: (DenResult sig ~ a) => T sig -> Args (AST T) sig -> Maybe (ASTF T b)
    go :: T sig -> Args (AST T) sig -> Maybe (ASTF T b)
go (T Sym sig
_) Args (AST T) sig
_ = ASTF T a -> Maybe (ASTF T b)
forall k (a :: k) (b :: k) (c :: k -> *).
(Typeable a, Typeable b) =>
c a -> Maybe (c b)
gcast ASTF T a
a

-- | Get the value of a literal expression
viewLit :: CExp a -> Maybe a
viewLit :: CExp a -> Maybe a
viewLit (CExp (Sym (T (Lit String
_ a
a)))) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
viewLit CExp a
_ = Maybe a
forall a. Maybe a
Nothing

pattern $mLitP :: forall r a.
CExp a
-> (forall a1.
    (CType (DenResult (Full a)), Full a ~ Full a1) =>
    a1 -> r)
-> (Void# -> r)
-> r
LitP a      <- CExp (Sym (T (Lit _ a)))
pattern $mLitP' :: forall r sig.
AST T sig
-> (forall a. (CType (DenResult sig), sig ~ Full a) => a -> r)
-> (Void# -> r)
-> r
LitP' a     <- Sym (T (Lit _ a))
pattern $mNonLitP :: forall r a. CExp a -> (Void# -> r) -> (Void# -> r) -> r
NonLitP     <- (viewLit -> Nothing)
pattern $mNonLitP' :: forall r a. ASTF T a -> (Void# -> r) -> (Void# -> r) -> r
NonLitP'    <- (CExp -> (viewLit -> Nothing))
pattern $mOpP :: forall r a.
CExp a
-> (forall a1 a2 a3 b c.
    (CType (DenResult (a2 :-> (a1 :-> Full a))),
     (a2 :-> (a1 :-> Full a)) ~ (a3 :-> (b :-> Full c))) =>
    Binary (a3 -> b -> c) -> AST T (Full a2) -> AST T (Full a1) -> r)
-> (Void# -> r)
-> r
OpP op a b  <- CExp (Sym (T (Op op)) :$ a :$ b)
pattern $mOpP' :: forall r sig.
AST T sig
-> (forall a1 a2 a3 b c.
    (CType (DenResult (a2 :-> (a1 :-> sig))),
     (a2 :-> (a1 :-> sig)) ~ (a3 :-> (b :-> Full c))) =>
    Binary (a3 -> b -> c) -> AST T (Full a2) -> AST T (Full a1) -> r)
-> (Void# -> r)
-> r
OpP' op a b <- Sym (T (Op op)) :$ a :$ b
pattern $mUOpP :: forall r a.
CExp a
-> (forall a1 a2 b.
    (CType (DenResult (a1 :-> Full a)),
     (a1 :-> Full a) ~ (a2 :-> Full b)) =>
    Unary (a2 -> b) -> AST T (Full a1) -> r)
-> (Void# -> r)
-> r
UOpP op a   <- CExp (Sym (T (UOp op)) :$ a)
pattern $mUOpP' :: forall r sig.
AST T sig
-> (forall a1 a2 b.
    (CType (DenResult (a1 :-> sig)), (a1 :-> sig) ~ (a2 :-> Full b)) =>
    Unary (a2 -> b) -> AST T (Full a1) -> r)
-> (Void# -> r)
-> r
UOpP' op a  <- Sym (T (UOp op)) :$ a

-- | Return whether the type of the expression is a floating-point numeric type
isFloat :: forall a . CType a => CExp a -> Bool
isFloat :: CExp a -> Bool
isFloat CExp a
a = TypeRep
t TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Float -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Float
forall a. HasCallStack => a
undefined :: Float) Bool -> Bool -> Bool
|| TypeRep
t TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Double -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (Double
forall a. HasCallStack => a
undefined :: Double)
  where
    t :: TypeRep
t = a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a
forall a. HasCallStack => a
undefined :: a)

-- | Return whether the type of the expression is a non-floating-point type
isExact :: CType a => CExp a -> Bool
isExact :: CExp a -> Bool
isExact = Bool -> Bool
not (Bool -> Bool) -> (CExp a -> Bool) -> CExp a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExp a -> Bool
forall a. CType a => CExp a -> Bool
isFloat

-- | Return whether the type of the expression is a non-floating-point type
isExact' :: CType a => ASTF T a -> Bool
isExact' :: ASTF T a -> Bool
isExact' = CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact (CExp a -> Bool) -> (ASTF T a -> CExp a) -> ASTF T a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp



--------------------------------------------------------------------------------
-- * User interface
--------------------------------------------------------------------------------

-- | Construct a literal expression
value :: CType a => a -> CExp a
value :: a -> CExp a
value a
a = ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp (ASTF T a -> CExp a) -> ASTF T a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (Full a) -> ASTF T a
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (T (Full a) -> ASTF T a) -> T (Full a) -> ASTF T a
forall a b. (a -> b) -> a -> b
$ Sym (Full a) -> T (Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Full a) -> T (Full a)) -> Sym (Full a) -> T (Full a)
forall a b. (a -> b) -> a -> b
$ String -> a -> Sym (Full a)
forall a. String -> a -> Sym (Full a)
Lit (a -> String
forall a. Show a => a -> String
show a
a) a
a

-- | Predefined constant
constant :: CType a
    => String  -- ^ Name of constant
    -> a       -- ^ Value of constant
    -> CExp a
constant :: String -> a -> CExp a
constant String
const a
val = ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp (ASTF T a -> CExp a) -> ASTF T a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (Full a) -> ASTF T a
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (T (Full a) -> ASTF T a) -> T (Full a) -> ASTF T a
forall a b. (a -> b) -> a -> b
$ Sym (Full a) -> T (Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Full a) -> T (Full a)) -> Sym (Full a) -> T (Full a)
forall a b. (a -> b) -> a -> b
$ String -> a -> Sym (Full a)
forall a. String -> a -> Sym (Full a)
Const String
const a
val

-- | Create a named variable
variable :: CType a => VarId -> CExp a
variable :: String -> CExp a
variable = ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp (ASTF T a -> CExp a) -> (String -> ASTF T a) -> String -> CExp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T (Full a) -> ASTF T a
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (T (Full a) -> ASTF T a)
-> (String -> T (Full a)) -> String -> ASTF T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sym (Full a) -> T (Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Full a) -> T (Full a))
-> (String -> Sym (Full a)) -> String -> T (Full a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Sym (Full a)
forall a. String -> Sym (Full a)
Var

withCode :: CType a => (forall m . MonadC m => m ()) -> CExp a -> CExp a
withCode :: SupportCode -> CExp a -> CExp a
withCode SupportCode
code = ASTF T a -> CExp a
forall a. ASTF T a -> CExp a
CExp (ASTF T a -> CExp a) -> (CExp a -> ASTF T a) -> CExp a -> CExp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T (a :-> Full a) -> ASTF T a -> ASTF T a
forall sig f (sym :: * -> *).
(Signature sig, f ~ SmartFun sym sig, sig ~ SmartSig f,
 sym ~ SmartSym f) =>
sym sig -> f
smartSym' (Sym (a :-> Full a) -> T (a :-> Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> Full a) -> T (a :-> Full a))
-> Sym (a :-> Full a) -> T (a :-> Full a)
forall a b. (a -> b) -> a -> b
$ SupportCode -> Sym (a :-> Full a)
forall a. SupportCode -> Sym (a :-> Full a)
WithCode SupportCode
code) (ASTF T a -> ASTF T a)
-> (CExp a -> ASTF T a) -> CExp a -> ASTF T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExp a -> ASTF T a
forall a. CExp a -> ASTF T a
unCExp

true, false :: CExp Bool
true :: CExp Bool
true  = SupportCode -> CExp Bool -> CExp Bool
forall a. CType a => SupportCode -> CExp a -> CExp a
withCode (String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdbool.h>") (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool -> CExp Bool
forall a. CType a => String -> a -> CExp a
constant String
"true" Bool
True
false :: CExp Bool
false = SupportCode -> CExp Bool -> CExp Bool
forall a. CType a => SupportCode -> CExp a -> CExp a
withCode (String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdbool.h>") (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool -> CExp Bool
forall a. CType a => String -> a -> CExp a
constant String
"false" Bool
False

instance (Num a, Ord a, CType a) => Num (CExp a)
  where
    fromInteger :: Integer -> CExp a
fromInteger = a -> CExp a
forall a. CType a => a -> CExp a
value (a -> CExp a) -> (Integer -> a) -> Integer -> CExp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger

    LitP a1
0 + :: CExp a -> CExp a -> CExp a
+ CExp a
b | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
b = CExp a
b
    CExp a
a + LitP a1
0 | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a
a
    a :: CExp a
a@(LitP a1
_) + b :: CExp a
b@CExp a
NonLitP | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a
bCExp a -> CExp a -> CExp a
forall a. Num a => a -> a -> a
+CExp a
a  -- Move literals to the right
    OpP Binary (a3 -> b -> c)
BiAdd AST T (Full a2)
a (LitP' a
b) + LitP a1
c | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp a2
forall a. Num a => a -> a -> a
+ a -> CExp a
forall a. CType a => a -> CExp a
value (a
ba -> a -> a
forall a. Num a => a -> a -> a
+a
a1
c)
    OpP Binary (a3 -> b -> c)
BiSub AST T (Full a2)
a (LitP' a
b) + LitP a1
c | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp a2
forall a. Num a => a -> a -> a
+ a1 -> CExp a1
forall a. CType a => a -> CExp a
value (a1
ca1 -> a1 -> a1
forall a. Num a => a -> a -> a
-a
a1
b)
    CExp a
a + LitP a1
b | a1
b a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
< a1
0, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a
a CExp a -> CExp a -> CExp a
forall a. Num a => a -> a -> a
- a1 -> CExp a1
forall a. CType a => a -> CExp a
value (a1 -> a1
forall a. Num a => a -> a
negate a1
b)
    CExp a
a + CExp a
b = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full a)) -> CExp a -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a)))
-> Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> a) -> Sym (a :-> (a :-> Full a))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> a)
forall a. Num a => Binary (a -> a -> a)
BiAdd) CExp a
a CExp a
b

    LitP a1
0 - :: CExp a -> CExp a -> CExp a
- CExp a
b | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
b = CExp a -> CExp a
forall a. Num a => a -> a
negate CExp a
b
    CExp a
a - LitP a1
0 | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a
a
    a :: CExp a
a@(LitP a1
_) - b :: CExp a
b@CExp a
NonLitP | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a -> CExp a
forall a. Num a => a -> a
negate CExp a
b CExp a -> CExp a -> CExp a
forall a. Num a => a -> a -> a
- CExp a -> CExp a
forall a. Num a => a -> a
negate CExp a
a  -- Move literals to the right
    OpP Binary (a3 -> b -> c)
BiAdd AST T (Full a2)
a (LitP' a
b) - LitP a1
c | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp a2
forall a. Num a => a -> a -> a
+ a -> CExp a
forall a. CType a => a -> CExp a
value (a
ba -> a -> a
forall a. Num a => a -> a -> a
-a
a1
c)
    OpP Binary (a3 -> b -> c)
BiSub AST T (Full a2)
a (LitP' a
b) - LitP a1
c | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp a2
forall a. Num a => a -> a -> a
- a -> CExp a
forall a. CType a => a -> CExp a
value (a
ba -> a -> a
forall a. Num a => a -> a -> a
+a
a1
c)
    CExp a
a - LitP a1
b | a1
b a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
< a1
0, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a
a CExp a -> CExp a -> CExp a
forall a. Num a => a -> a -> a
+ a1 -> CExp a1
forall a. CType a => a -> CExp a
value (a1 -> a1
forall a. Num a => a -> a
negate a1
b)
    CExp a
a - CExp a
b = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full a)) -> CExp a -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a)))
-> Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> a) -> Sym (a :-> (a :-> Full a))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> a)
forall a. Num a => Binary (a -> a -> a)
BiSub) CExp a
a CExp a
b

    LitP a1
0 * :: CExp a -> CExp a -> CExp a
* CExp a
b | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
b = a -> CExp a
forall a. CType a => a -> CExp a
value a
0
    CExp a
a * LitP a1
0 | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = a -> CExp a
forall a. CType a => a -> CExp a
value a
0
    LitP a1
1 * CExp a
b | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
b = CExp a
b
    CExp a
a * LitP a1
1 | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a
a
    a :: CExp a
a@(LitP a1
_) * b :: CExp a
b@CExp a
NonLitP | CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp a
bCExp a -> CExp a -> CExp a
forall a. Num a => a -> a -> a
*CExp a
a  -- Move literals to the right
    OpP Binary (a3 -> b -> c)
BiMul AST T (Full a2)
a (LitP' a
b) * LitP a1
c | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp a2
forall a. Num a => a -> a -> a
* a -> CExp a
forall a. CType a => a -> CExp a
value (a
ba -> a -> a
forall a. Num a => a -> a -> a
*a
a1
c)
    CExp a
a * CExp a
b = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full a)) -> CExp a -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a)))
-> Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> a) -> Sym (a :-> (a :-> Full a))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> a)
forall a. Num a => Binary (a -> a -> a)
BiMul) CExp a
a CExp a
b

    negate :: CExp a -> CExp a
negate (UOpP Unary (a2 -> b)
UnNeg AST T (Full a1)
a)  | AST T (Full a1) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a1)
a = AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
a
    negate (OpP Binary (a3 -> b -> c)
BiAdd AST T (Full a2)
a AST T (Full a1)
b) | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = CExp a2 -> CExp a2
forall a. Num a => a -> a
negate (AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a) CExp a2 -> CExp a2 -> CExp a2
forall a. Num a => a -> a -> a
- AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b
    negate (OpP Binary (a3 -> b -> c)
BiSub AST T (Full a2)
a AST T (Full a1)
b) | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b CExp a1 -> CExp a1 -> CExp a1
forall a. Num a => a -> a -> a
- AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a
    negate (OpP Binary (a3 -> b -> c)
BiMul AST T (Full a2)
a AST T (Full a1)
b) | AST T (Full a2) -> Bool
forall a. CType a => ASTF T a -> Bool
isExact' AST T (Full a2)
a = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp a2
forall a. Num a => a -> a -> a
* CExp a1 -> CExp a1
forall a. Num a => a -> a
negate (AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b)
      -- Negate the right operand, because literals are moved to the right
      -- in multiplications
    negate CExp a
a = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (a :-> Full a) -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> Full a) -> T (a :-> Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> Full a) -> T (a :-> Full a))
-> Sym (a :-> Full a) -> T (a :-> Full a)
forall a b. (a -> b) -> a -> b
$ Unary (a -> a) -> Sym (a :-> Full a)
forall a b. Unary (a -> b) -> Sym (a :-> Full b)
UOp Unary (a -> a)
forall a. Num a => Unary (a -> a)
UnNeg) CExp a
a

    abs :: CExp a -> CExp a
abs    = String -> CExp a -> CExp a
forall a. HasCallStack => String -> a
error String
"abs not implemented for CExp"
    signum :: CExp a -> CExp a
signum = String -> CExp a -> CExp a
forall a. HasCallStack => String -> a
error String
"signum not implemented for CExp"

instance (Fractional a, Ord a, CType a) => Fractional (CExp a)
  where
    fromRational :: Rational -> CExp a
fromRational = a -> CExp a
forall a. CType a => a -> CExp a
value (a -> CExp a) -> (Rational -> a) -> Rational -> CExp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> a
forall a. Fractional a => Rational -> a
fromRational
    CExp a
a / :: CExp a -> CExp a -> CExp a
/ CExp a
b = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full a)) -> CExp a -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a)))
-> Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> a) -> Sym (a :-> (a :-> Full a))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> a)
forall a. Fractional a => Binary (a -> a -> a)
BiDiv) CExp a
a CExp a
b

    recip :: CExp a -> CExp a
recip = String -> CExp a -> CExp a
forall a. HasCallStack => String -> a
error String
"recip not implemented for CExp"

-- | Integer division truncated toward zero
quot_ :: (Eq a, Integral a, CType a) => CExp a -> CExp a -> CExp a
quot_ :: CExp a -> CExp a -> CExp a
quot_ (LitP a1
0) CExp a
b = CExp a
0
quot_ CExp a
a (LitP a1
1) = CExp a
a
quot_ CExp a
a CExp a
b
    | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b     = CExp a
1
quot_ CExp a
a CExp a
b        = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full a)) -> CExp a -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a)))
-> Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> a) -> Sym (a :-> (a :-> Full a))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> a)
forall a. Integral a => Binary (a -> a -> a)
BiQuot) CExp a
a CExp a
b

-- | Integer remainder satisfying
--
-- > (x `quot_` y)*y + (x #% y) == x
(#%) :: (Integral a, CType a) => CExp a -> CExp a -> CExp a
LitP a1
0 #% :: CExp a -> CExp a -> CExp a
#% CExp a
_          = CExp a
0
CExp a
_      #% LitP a1
1     = CExp a
0
CExp a
a      #% CExp a
b | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b = CExp a
0
CExp a
a      #% CExp a
b          = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full a)) -> CExp a -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a)))
-> Sym (a :-> (a :-> Full a)) -> T (a :-> (a :-> Full a))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> a) -> Sym (a :-> (a :-> Full a))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> a)
forall a. Integral a => Binary (a -> a -> a)
BiRem) CExp a
a CExp a
b

-- | Integral type casting
i2n :: (Integral a, Num b, CType b) => CExp a -> CExp b
i2n :: CExp a -> CExp b
i2n CExp a
a = CExp b -> CExp b
forall a. CExp a -> CExp a
constFold (CExp b -> CExp b) -> CExp b -> CExp b
forall a b. (a -> b) -> a -> b
$ T (a :-> Full b) -> CExp a -> CExp b
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> Full b) -> T (a :-> Full b)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> Full b) -> T (a :-> Full b))
-> Sym (a :-> Full b) -> T (a :-> Full b)
forall a b. (a -> b) -> a -> b
$ (a -> b) -> Sym (a :-> Full b)
forall a a. (a -> a) -> Sym (a :-> Full a)
Cast (Integer -> b
forall a. Num a => Integer -> a
fromInteger (Integer -> b) -> (a -> Integer) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a. Integral a => a -> Integer
toInteger)) CExp a
a

-- | Cast integer to 'Bool'
i2b :: Integral a => CExp a -> CExp Bool
i2b :: CExp a -> CExp Bool
i2b CExp a
a = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (a :-> Full Bool) -> CExp a -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> Full Bool) -> T (a :-> Full Bool)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> Full Bool) -> T (a :-> Full Bool))
-> Sym (a :-> Full Bool) -> T (a :-> Full Bool)
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Sym (a :-> Full Bool)
forall a a. (a -> a) -> Sym (a :-> Full a)
Cast (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/=a
0)) CExp a
a

-- | Cast 'Bool' to integer
b2i :: (Integral a, CType a) => CExp Bool -> CExp a
b2i :: CExp Bool -> CExp a
b2i CExp Bool
a = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (Bool :-> Full a) -> CExp Bool -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (Bool :-> Full a) -> T (Bool :-> Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Bool :-> Full a) -> T (Bool :-> Full a))
-> Sym (Bool :-> Full a) -> T (Bool :-> Full a)
forall a b. (a -> b) -> a -> b
$ (Bool -> a) -> Sym (Bool :-> Full a)
forall a a. (a -> a) -> Sym (a :-> Full a)
Cast (\Bool
c -> if Bool
c then a
1 else a
0)) CExp Bool
a

-- | Boolean negation
not_ :: CExp Bool -> CExp Bool
not_ :: CExp Bool -> CExp Bool
not_ (UOpP Unary (a2 -> b)
UnNot AST T (Full a1)
a)  = AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
a
not_ (OpP Binary (a3 -> b -> c)
BiEq AST T (Full a2)
a AST T (Full a1)
b)  = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp Bool
forall a. (Eq a, CType a) => CExp a -> CExp a -> CExp Bool
#!= AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b
not_ (OpP Binary (a3 -> b -> c)
BiNEq AST T (Full a2)
a AST T (Full a1)
b) = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp Bool
forall a. (Eq a, CType a) => CExp a -> CExp a -> CExp Bool
#== AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b
not_ (OpP Binary (a3 -> b -> c)
BiLt AST T (Full a2)
a AST T (Full a1)
b)  = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp Bool
forall a. (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
#>= AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b
not_ (OpP Binary (a3 -> b -> c)
BiGt AST T (Full a2)
a AST T (Full a1)
b)  = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp Bool
forall a. (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
#<= AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b
not_ (OpP Binary (a3 -> b -> c)
BiLe AST T (Full a2)
a AST T (Full a1)
b)  = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp Bool
forall a. (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
#> AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b
not_ (OpP Binary (a3 -> b -> c)
BiGe AST T (Full a2)
a AST T (Full a1)
b)  = AST T (Full a2) -> CExp a2
forall a. ASTF T a -> CExp a
CExp AST T (Full a2)
a CExp a2 -> CExp a2 -> CExp Bool
forall a. (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
#< AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
b
not_ CExp Bool
a = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (Bool :-> Full Bool) -> CExp Bool -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (Bool :-> Full Bool) -> T (Bool :-> Full Bool)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Bool :-> Full Bool) -> T (Bool :-> Full Bool))
-> Sym (Bool :-> Full Bool) -> T (Bool :-> Full Bool)
forall a b. (a -> b) -> a -> b
$ Unary (Bool -> Bool) -> Sym (Bool :-> Full Bool)
forall a b. Unary (a -> b) -> Sym (a :-> Full b)
UOp Unary (Bool -> Bool)
UnNot) CExp Bool
a

-- | Logical and
(#&&) :: CExp Bool -> CExp Bool -> CExp Bool
LitP a1
True  #&& :: CExp Bool -> CExp Bool -> CExp Bool
#&& CExp Bool
b          = CExp Bool
b
LitP a1
False #&& CExp Bool
b          = CExp Bool
false
CExp Bool
a          #&& LitP a1
True  = CExp Bool
a
CExp Bool
a          #&& LitP a1
False = CExp Bool
false
CExp Bool
a          #&& CExp Bool
b          = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (Bool :-> (Bool :-> Full Bool))
-> CExp Bool -> CExp Bool -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (Bool :-> (Bool :-> Full Bool))
-> T (Bool :-> (Bool :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Bool :-> (Bool :-> Full Bool))
 -> T (Bool :-> (Bool :-> Full Bool)))
-> Sym (Bool :-> (Bool :-> Full Bool))
-> T (Bool :-> (Bool :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (Bool -> Bool -> Bool)
-> Sym (Bool :-> (Bool :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (Bool -> Bool -> Bool)
BiAnd) CExp Bool
a CExp Bool
b

-- | Logical or
(#||) :: CExp Bool -> CExp Bool -> CExp Bool
LitP a1
True  #|| :: CExp Bool -> CExp Bool -> CExp Bool
#|| CExp Bool
b          = CExp Bool
true
LitP a1
False #|| CExp Bool
b          = CExp Bool
b
CExp Bool
a          #|| LitP a1
True  = CExp Bool
true
CExp Bool
a          #|| LitP a1
False = CExp Bool
a
CExp Bool
a          #|| CExp Bool
b          = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (Bool :-> (Bool :-> Full Bool))
-> CExp Bool -> CExp Bool -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (Bool :-> (Bool :-> Full Bool))
-> T (Bool :-> (Bool :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (Bool :-> (Bool :-> Full Bool))
 -> T (Bool :-> (Bool :-> Full Bool)))
-> Sym (Bool :-> (Bool :-> Full Bool))
-> T (Bool :-> (Bool :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (Bool -> Bool -> Bool)
-> Sym (Bool :-> (Bool :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (Bool -> Bool -> Bool)
BiOr) CExp Bool
a CExp Bool
b

-- | Equality
(#==) :: (Eq a, CType a) => CExp a -> CExp a -> CExp Bool
CExp a
a #== :: CExp a -> CExp a -> CExp Bool
#== CExp a
b
    | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp Bool
true
    | Bool
otherwise         = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full Bool)) -> CExp a -> CExp a -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool)))
-> Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> Bool) -> Sym (a :-> (a :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> Bool)
forall a. CType a => Binary (a -> a -> Bool)
BiEq) CExp a
a CExp a
b

-- | In-equality
(#!=) :: (Eq a, CType a) => CExp a -> CExp a -> CExp Bool
CExp a
a #!= :: CExp a -> CExp a -> CExp Bool
#!= CExp a
b
    | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp Bool
false
    | Bool
otherwise         = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full Bool)) -> CExp a -> CExp a -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool)))
-> Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> Bool) -> Sym (a :-> (a :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> Bool)
forall a. CType a => Binary (a -> a -> Bool)
BiNEq) CExp a
a CExp a
b

(#<) :: (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
CExp a
a #< :: CExp a -> CExp a -> CExp Bool
#< CExp a
b
    | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp Bool
false
    | Bool
otherwise         = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full Bool)) -> CExp a -> CExp a -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool)))
-> Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> Bool) -> Sym (a :-> (a :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> Bool)
forall a. (Ord a, CType a) => Binary (a -> a -> Bool)
BiLt) CExp a
a CExp a
b

(#>) :: (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
CExp a
a #> :: CExp a -> CExp a -> CExp Bool
#> CExp a
b
    | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp Bool
false
    | Bool
otherwise         = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full Bool)) -> CExp a -> CExp a -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool)))
-> Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> Bool) -> Sym (a :-> (a :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> Bool)
forall a. (Ord a, CType a) => Binary (a -> a -> Bool)
BiGt) CExp a
a CExp a
b

(#<=) :: (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
CExp a
a #<= :: CExp a -> CExp a -> CExp Bool
#<= CExp a
b
    | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp Bool
true
    | Bool
otherwise         = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full Bool)) -> CExp a -> CExp a -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool)))
-> Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> Bool) -> Sym (a :-> (a :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> Bool)
forall a. (Ord a, CType a) => Binary (a -> a -> Bool)
BiLe) CExp a
a CExp a
b

(#>=) :: (Ord a, CType a) => CExp a -> CExp a -> CExp Bool
CExp a
a #>= :: CExp a -> CExp a -> CExp Bool
#>= CExp a
b
    | CExp a
a CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
b, CExp a -> Bool
forall a. CType a => CExp a -> Bool
isExact CExp a
a = CExp Bool
true
    | Bool
otherwise         = CExp Bool -> CExp Bool
forall a. CExp a -> CExp a
constFold (CExp Bool -> CExp Bool) -> CExp Bool -> CExp Bool
forall a b. (a -> b) -> a -> b
$ T (a :-> (a :-> Full Bool)) -> CExp a -> CExp a -> CExp Bool
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool)))
-> Sym (a :-> (a :-> Full Bool)) -> T (a :-> (a :-> Full Bool))
forall a b. (a -> b) -> a -> b
$ Binary (a -> a -> Bool) -> Sym (a :-> (a :-> Full Bool))
forall b b c. Binary (b -> b -> c) -> Sym (b :-> (b :-> Full c))
Op Binary (a -> a -> Bool)
forall a. (Ord a, CType a) => Binary (a -> a -> Bool)
BiGe) CExp a
a CExp a
b

infix 4 #==, #!=, #<, #>, #<=, #>=

-- | Conditional expression
cond :: CType a
    => CExp Bool  -- ^ Condition
    -> CExp a     -- ^ True branch
    -> CExp a     -- ^ False branch
    -> CExp a
cond :: CExp Bool -> CExp a -> CExp a -> CExp a
cond (LitP a1
c) CExp a
t CExp a
f = if a1
Bool
c then CExp a
t else CExp a
f
cond CExp Bool
c CExp a
t CExp a
f
    | CExp a
t CExp a -> CExp a -> Bool
forall a. Eq a => a -> a -> Bool
== CExp a
f = CExp a
t
cond (UOpP Unary (a2 -> b)
UnNot AST T (Full a1)
a) CExp a
t CExp a
f = CExp Bool -> CExp a -> CExp a -> CExp a
forall a. CType a => CExp Bool -> CExp a -> CExp a -> CExp a
cond (AST T (Full a1) -> CExp a1
forall a. ASTF T a -> CExp a
CExp AST T (Full a1)
a) CExp a
f CExp a
t
cond CExp Bool
c CExp a
t CExp a
f = CExp a -> CExp a
forall a. CExp a -> CExp a
constFold (CExp a -> CExp a) -> CExp a -> CExp a
forall a b. (a -> b) -> a -> b
$ T (Bool :-> (a :-> (a :-> Full a)))
-> CExp Bool -> CExp a -> CExp a -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (Bool :-> (a :-> (a :-> Full a)))
-> T (Bool :-> (a :-> (a :-> Full a)))
forall sig. CType (DenResult sig) => Sym sig -> T sig
T Sym (Bool :-> (a :-> (a :-> Full a)))
forall a. Sym (Bool :-> (a :-> (a :-> Full a)))
Cond) CExp Bool
c CExp a
t CExp a
f

-- | Condition operator; use as follows:
--
-- > cond1 ? a $
-- > cond2 ? b $
-- > cond3 ? c $
-- >         default
(?) :: CType a
    => CExp Bool  -- ^ Condition
    -> CExp a     -- ^ True branch
    -> CExp a     -- ^ False branch
    -> CExp a
? :: CExp Bool -> CExp a -> CExp a -> CExp a
(?) = CExp Bool -> CExp a -> CExp a -> CExp a
forall a. CType a => CExp Bool -> CExp a -> CExp a -> CExp a
cond

infixl 1 ?

-- | Array indexing
(#!) :: (CType a, Integral i, Ix i) => IArr i a -> CExp i -> CExp a
IArr i a
arr #! :: IArr i a -> CExp i -> CExp a
#! CExp i
i = T (i :-> Full a) -> CExp i -> CExp a
forall sig fi (sup :: * -> *) f (sub :: * -> *).
(Signature sig, fi ~ SmartFun sup sig, sig ~ SmartSig fi,
 sup ~ SmartSym fi, SyntacticN f fi, sub :<: sup) =>
sub sig -> f
sugarSym (Sym (i :-> Full a) -> T (i :-> Full a)
forall sig. CType (DenResult sig) => Sym sig -> T sig
T (Sym (i :-> Full a) -> T (i :-> Full a))
-> Sym (i :-> Full a) -> T (i :-> Full a)
forall a b. (a -> b) -> a -> b
$ IArr i a -> Sym (i :-> Full a)
forall i a. (Integral i, Ix i) => IArr i a -> Sym (i :-> Full a)
ArrIx IArr i a
arr) CExp i
i