module Feldspar.Core.Constructs.Ord
( ORD (..)
) where
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Feldspar.Range
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
data ORD a
where
LTH :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)
GTH :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)
LTE :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)
GTE :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)
Min :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full a)
Max :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full a)
instance Semantic ORD
where
semantics LTH = Sem "(<)" (<)
semantics GTH = Sem "(>)" (>)
semantics LTE = Sem "(<=)" (<=)
semantics GTE = Sem "(>=)" (>=)
semantics Min = Sem "min" min
semantics Max = Sem "max" max
instance Equality ORD where equal = equalDefault; exprHash = exprHashDefault
instance Render ORD where renderArgs = renderArgsDefault
instance ToTree ORD
instance Eval ORD where evaluate = evaluateDefault
instance EvalBind ORD where evalBindSym = evalBindSymDefault
instance Sharable ORD
instance AlphaEq dom dom dom env => AlphaEq ORD ORD dom env
where
alphaEqSym = alphaEqSymDefault
instance SizeProp (ORD :|| Type)
where
sizeProp (C' Min) (WrapFull a :* WrapFull b :* Nil) = min (infoSize a) (infoSize b)
sizeProp (C' Max) (WrapFull a :* WrapFull b :* Nil) = max (infoSize a) (infoSize b)
sizeProp a@(C' _) args = sizePropDefault a args
instance ( (ORD :|| Type) :<: dom
, OptimizeSuper dom
)
=> Optimize (ORD :|| Type) dom
where
constructFeatOpt (C' LTH) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, ra `rangeLess` rb
= return (literalDecor True)
constructFeatOpt (C' LTH) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, rb `rangeLessEq` ra
= return (literalDecor False)
constructFeatOpt (C' GTH) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, rb `rangeLess` ra
= return (literalDecor True)
constructFeatOpt (C' GTH) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, ra `rangeLessEq` rb
= return (literalDecor False)
constructFeatOpt (C' LTE) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, ra `rangeLessEq` rb
= return (literalDecor True)
constructFeatOpt (C' LTE) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, rb `rangeLess` ra
= return (literalDecor False)
constructFeatOpt (C' LTE) (a :* b :* Nil)
| alphaEq a b
= return $ literalDecor True
constructFeatOpt (C' GTE) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, rb `rangeLessEq` ra
= return (literalDecor True)
constructFeatOpt (C' GTE) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, ra `rangeLess` rb
= return (literalDecor False)
constructFeatOpt (C' GTE) (a :* b :* Nil)
| alphaEq a b
= return $ literalDecor True
constructFeatOpt (C' Min) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, ra `rangeLessEq` rb
= return a
constructFeatOpt (C' Min) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, rb `rangeLessEq` ra
= return b
constructFeatOpt (C' Min) (a :* b :* Nil)
| alphaEq a b
= return a
constructFeatOpt (C' Max) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, ra `rangeLessEq` rb
= return b
constructFeatOpt (C' Max) (a :* b :* Nil)
| RangeSet ra <- infoRange (getInfo a)
, RangeSet rb <- infoRange (getInfo b)
, rb `rangeLessEq` ra
= return a
constructFeatOpt (C' Max) (a :* b :* Nil)
| alphaEq a b
= return a
constructFeatOpt a args = constructFeatUnOpt a args
constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x