{-# LANGUAGE GADTs #-}
module Language.Drasil.Code.Expr.Convert (
    expr, realInterval, constraint,
    CanGenCode(..)
) where

import qualified Language.Drasil as L
import qualified Language.Drasil.Expr.Development as LD
import qualified Language.Drasil.Literal.Development as LL

import Language.Drasil.Code.Expr

import Data.Bifunctor (Bifunctor(bimap, second))

class CanGenCode e where
    toCodeExpr :: e -> CodeExpr

instance CanGenCode LL.Literal where
    toCodeExpr :: Literal -> CodeExpr
toCodeExpr = Literal -> CodeExpr
Lit

instance CanGenCode LD.Expr where
    toCodeExpr :: Expr -> CodeExpr
toCodeExpr = Expr -> CodeExpr
expr

-- | Render an algebraic expression into our code expression language.
expr :: LD.Expr -> CodeExpr
expr :: Expr -> CodeExpr
expr (LD.Lit l :: Literal
l) = Literal -> CodeExpr
Lit Literal
l
expr (LD.AssocA ao :: AssocArithOper
ao es :: [Expr]
es) = AssocArithOper -> [CodeExpr] -> CodeExpr
AssocA (AssocArithOper -> AssocArithOper
assocArithOp AssocArithOper
ao) ([CodeExpr] -> CodeExpr) -> [CodeExpr] -> CodeExpr
forall a b. (a -> b) -> a -> b
$ (Expr -> CodeExpr) -> [Expr] -> [CodeExpr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> CodeExpr
expr [Expr]
es
expr (LD.AssocB bo :: AssocBoolOper
bo es :: [Expr]
es) = AssocBoolOper -> [CodeExpr] -> CodeExpr
AssocB (AssocBoolOper -> AssocBoolOper
assocBoolOp AssocBoolOper
bo) ([CodeExpr] -> CodeExpr) -> [CodeExpr] -> CodeExpr
forall a b. (a -> b) -> a -> b
$ (Expr -> CodeExpr) -> [Expr] -> [CodeExpr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> CodeExpr
expr [Expr]
es
expr (LD.C u :: UID
u) = UID -> CodeExpr
C UID
u
expr (LD.FCall u :: UID
u es :: [Expr]
es ns :: [(UID, Expr)]
ns) = UID -> [CodeExpr] -> [(UID, CodeExpr)] -> CodeExpr
FCall UID
u ((Expr -> CodeExpr) -> [Expr] -> [CodeExpr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> CodeExpr
expr [Expr]
es) (((UID, Expr) -> (UID, CodeExpr))
-> [(UID, Expr)] -> [(UID, CodeExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr -> CodeExpr) -> (UID, Expr) -> (UID, CodeExpr)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Expr -> CodeExpr
expr) [(UID, Expr)]
ns)
expr (LD.Case c :: Completeness
c es :: [(Expr, Expr)]
es) = Completeness -> [(CodeExpr, CodeExpr)] -> CodeExpr
Case Completeness
c ([(CodeExpr, CodeExpr)] -> CodeExpr)
-> [(CodeExpr, CodeExpr)] -> CodeExpr
forall a b. (a -> b) -> a -> b
$ ((Expr, Expr) -> (CodeExpr, CodeExpr))
-> [(Expr, Expr)] -> [(CodeExpr, CodeExpr)]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr -> CodeExpr)
-> (Expr -> CodeExpr) -> (Expr, Expr) -> (CodeExpr, CodeExpr)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Expr -> CodeExpr
expr Expr -> CodeExpr
expr) [(Expr, Expr)]
es
expr (LD.Matrix es :: [[Expr]]
es) = [[CodeExpr]] -> CodeExpr
Matrix ([[CodeExpr]] -> CodeExpr) -> [[CodeExpr]] -> CodeExpr
forall a b. (a -> b) -> a -> b
$ ([Expr] -> [CodeExpr]) -> [[Expr]] -> [[CodeExpr]]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr -> CodeExpr) -> [Expr] -> [CodeExpr]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> CodeExpr
expr) [[Expr]]
es
expr (LD.UnaryOp uo :: UFunc
uo e :: Expr
e) = UFunc -> CodeExpr -> CodeExpr
UnaryOp (UFunc -> UFunc
uFunc UFunc
uo) (Expr -> CodeExpr
expr Expr
e)
expr (LD.UnaryOpB uo :: UFuncB
uo e :: Expr
e) = UFuncB -> CodeExpr -> CodeExpr
UnaryOpB (UFuncB -> UFuncB
uFuncB UFuncB
uo) (Expr -> CodeExpr
expr Expr
e)
expr (LD.UnaryOpVV uo :: UFuncVV
uo e :: Expr
e) = UFuncVV -> CodeExpr -> CodeExpr
UnaryOpVV (UFuncVV -> UFuncVV
uFuncVV UFuncVV
uo) (Expr -> CodeExpr
expr Expr
e)
expr (LD.UnaryOpVN uo :: UFuncVN
uo e :: Expr
e) = UFuncVN -> CodeExpr -> CodeExpr
UnaryOpVN (UFuncVN -> UFuncVN
uFuncVN UFuncVN
uo) (Expr -> CodeExpr
expr Expr
e)
expr (LD.ArithBinaryOp bo :: ArithBinOp
bo l :: Expr
l r :: Expr
r) = ArithBinOp -> CodeExpr -> CodeExpr -> CodeExpr
ArithBinaryOp (ArithBinOp -> ArithBinOp
arithBinOp ArithBinOp
bo) (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)
expr (LD.BoolBinaryOp bo :: BoolBinOp
bo l :: Expr
l r :: Expr
r) = BoolBinOp -> CodeExpr -> CodeExpr -> CodeExpr
BoolBinaryOp (BoolBinOp -> BoolBinOp
boolBinOp BoolBinOp
bo) (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)
expr (LD.EqBinaryOp bo :: EqBinOp
bo l :: Expr
l r :: Expr
r) = EqBinOp -> CodeExpr -> CodeExpr -> CodeExpr
EqBinaryOp (EqBinOp -> EqBinOp
eqBinOp EqBinOp
bo) (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)
expr (LD.LABinaryOp bo :: LABinOp
bo l :: Expr
l r :: Expr
r) = LABinOp -> CodeExpr -> CodeExpr -> CodeExpr
LABinaryOp (LABinOp -> LABinOp
laBinOp LABinOp
bo) (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)
expr (LD.OrdBinaryOp bo :: OrdBinOp
bo l :: Expr
l r :: Expr
r) = OrdBinOp -> CodeExpr -> CodeExpr -> CodeExpr
OrdBinaryOp (OrdBinOp -> OrdBinOp
ordBinOp OrdBinOp
bo) (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)
expr (LD.VVVBinaryOp bo :: VVVBinOp
bo l :: Expr
l r :: Expr
r) = VVVBinOp -> CodeExpr -> CodeExpr -> CodeExpr
VVVBinaryOp (VVVBinOp -> VVVBinOp
vvvBinOp VVVBinOp
bo) (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)
expr (LD.VVNBinaryOp bo :: VVNBinOp
bo l :: Expr
l r :: Expr
r) = VVNBinOp -> CodeExpr -> CodeExpr -> CodeExpr
VVNBinaryOp (VVNBinOp -> VVNBinOp
vvnBinOp VVNBinOp
bo) (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)
expr (LD.Operator aao :: AssocArithOper
aao dd :: DiscreteDomainDesc Expr Expr
dd e :: Expr
e) = AssocArithOper
-> DiscreteDomainDesc CodeExpr CodeExpr -> CodeExpr -> CodeExpr
Operator (AssocArithOper -> AssocArithOper
assocArithOp AssocArithOper
aao) (DiscreteDomainDesc Expr Expr
-> DiscreteDomainDesc CodeExpr CodeExpr
renderDomainDesc DiscreteDomainDesc Expr Expr
dd) (Expr -> CodeExpr
expr Expr
e)
expr (LD.RealI u :: UID
u ri :: RealInterval Expr Expr
ri) = UID -> RealInterval CodeExpr CodeExpr -> CodeExpr
RealI UID
u (RealInterval Expr Expr -> RealInterval CodeExpr CodeExpr
realInterval RealInterval Expr Expr
ri)

-- | Convert 'RealInterval' 'Expr' 'Expr's into 'RealInterval' 'CodeExpr' 'CodeExpr's.
realInterval :: L.RealInterval L.Expr L.Expr -> L.RealInterval CodeExpr CodeExpr
realInterval :: RealInterval Expr Expr -> RealInterval CodeExpr CodeExpr
realInterval (L.Bounded (il :: Inclusive
il, el :: Expr
el) (ir :: Inclusive
ir, er :: Expr
er)) = (Inclusive, CodeExpr)
-> (Inclusive, CodeExpr) -> RealInterval CodeExpr CodeExpr
forall a b. (Inclusive, a) -> (Inclusive, b) -> RealInterval a b
L.Bounded (Inclusive
il, Expr -> CodeExpr
expr Expr
el) (Inclusive
ir, Expr -> CodeExpr
expr Expr
er)
realInterval (L.UpTo (i :: Inclusive
i, e :: Expr
e)) = (Inclusive, CodeExpr) -> RealInterval CodeExpr CodeExpr
forall a b. (Inclusive, a) -> RealInterval a b
L.UpTo (Inclusive
i, Expr -> CodeExpr
expr Expr
e)
realInterval (L.UpFrom (i :: Inclusive
i, e :: Expr
e)) = (Inclusive, CodeExpr) -> RealInterval CodeExpr CodeExpr
forall b a. (Inclusive, b) -> RealInterval a b
L.UpFrom (Inclusive
i, Expr -> CodeExpr
expr Expr
e)

-- | Convert constrained expressions ('ConstraintE') into 'Constraint''CodeExpr's.
constraint :: L.ConstraintE -> L.Constraint CodeExpr
constraint :: ConstraintE -> Constraint CodeExpr
constraint (L.Range r :: ConstraintReason
r ri :: RealInterval Expr Expr
ri) = ConstraintReason
-> RealInterval CodeExpr CodeExpr -> Constraint CodeExpr
forall a. ConstraintReason -> RealInterval a a -> Constraint a
L.Range ConstraintReason
r (RealInterval Expr Expr -> RealInterval CodeExpr CodeExpr
realInterval RealInterval Expr Expr
ri)

-- | Convert 'DomainDesc Expr Expr' into 'DomainDesc CodeExpr CodeExpr's.
renderDomainDesc :: L.DiscreteDomainDesc L.Expr L.Expr -> L.DiscreteDomainDesc CodeExpr CodeExpr
renderDomainDesc :: DiscreteDomainDesc Expr Expr
-> DiscreteDomainDesc CodeExpr CodeExpr
renderDomainDesc (L.BoundedDD s :: Symbol
s t :: RTopology
t l :: Expr
l r :: Expr
r) = Symbol
-> RTopology
-> CodeExpr
-> CodeExpr
-> DiscreteDomainDesc CodeExpr CodeExpr
forall a b.
Symbol -> RTopology -> a -> b -> DomainDesc 'Discrete a b
L.BoundedDD Symbol
s RTopology
t (Expr -> CodeExpr
expr Expr
l) (Expr -> CodeExpr
expr Expr
r)

arithBinOp :: LD.ArithBinOp -> ArithBinOp
arithBinOp :: ArithBinOp -> ArithBinOp
arithBinOp LD.Frac = ArithBinOp
Frac
arithBinOp LD.Pow = ArithBinOp
Pow
arithBinOp LD.Subt = ArithBinOp
Subt

eqBinOp :: LD.EqBinOp -> EqBinOp
eqBinOp :: EqBinOp -> EqBinOp
eqBinOp LD.Eq = EqBinOp
Eq
eqBinOp LD.NEq = EqBinOp
NEq

boolBinOp :: LD.BoolBinOp -> BoolBinOp
boolBinOp :: BoolBinOp -> BoolBinOp
boolBinOp LD.Impl = BoolBinOp
Impl
boolBinOp LD.Iff = BoolBinOp
Iff

laBinOp :: LD.LABinOp -> LABinOp
laBinOp :: LABinOp -> LABinOp
laBinOp LD.Index = LABinOp
Index

ordBinOp :: LD.OrdBinOp -> OrdBinOp
ordBinOp :: OrdBinOp -> OrdBinOp
ordBinOp LD.Lt  = OrdBinOp
Lt
ordBinOp LD.Gt  = OrdBinOp
Gt
ordBinOp LD.LEq = OrdBinOp
LEq
ordBinOp LD.GEq = OrdBinOp
GEq

vvvBinOp :: LD.VVVBinOp -> VVVBinOp
vvvBinOp :: VVVBinOp -> VVVBinOp
vvvBinOp LD.Cross = VVVBinOp
Cross

vvnBinOp :: LD.VVNBinOp -> VVNBinOp
vvnBinOp :: VVNBinOp -> VVNBinOp
vvnBinOp LD.Dot = VVNBinOp
Dot

assocArithOp :: LD.AssocArithOper -> AssocArithOper
assocArithOp :: AssocArithOper -> AssocArithOper
assocArithOp LD.AddI = AssocArithOper
AddI -- TODO: These L.'s should be exported through L.D.Development
assocArithOp LD.AddRe = AssocArithOper
AddRe
assocArithOp LD.MulI = AssocArithOper
MulI
assocArithOp LD.MulRe = AssocArithOper
MulRe

assocBoolOp :: LD.AssocBoolOper -> AssocBoolOper
assocBoolOp :: AssocBoolOper -> AssocBoolOper
assocBoolOp LD.And = AssocBoolOper
And -- TODO: These L.'s should be exported through L.D.Development
assocBoolOp LD.Or = AssocBoolOper
Or

uFunc :: LD.UFunc -> UFunc
uFunc :: UFunc -> UFunc
uFunc LD.Abs = UFunc
Abs -- TODO: These L.'s should be exported through L.D.Development
uFunc LD.Log = UFunc
Log
uFunc LD.Ln = UFunc
Ln
uFunc LD.Sin = UFunc
Sin
uFunc LD.Cos = UFunc
Cos
uFunc LD.Tan = UFunc
Tan
uFunc LD.Sec = UFunc
Sec
uFunc LD.Csc = UFunc
Csc
uFunc LD.Cot = UFunc
Cot
uFunc LD.Arcsin = UFunc
Arcsin
uFunc LD.Arccos = UFunc
Arccos
uFunc LD.Arctan = UFunc
Arctan
uFunc LD.Exp = UFunc
Exp
uFunc LD.Sqrt = UFunc
Sqrt
uFunc LD.Neg = UFunc
Neg

uFuncB :: LD.UFuncB -> UFuncB
uFuncB :: UFuncB -> UFuncB
uFuncB LD.Not = UFuncB
Not

uFuncVV :: LD.UFuncVV -> UFuncVV
uFuncVV :: UFuncVV -> UFuncVV
uFuncVV LD.NegV = UFuncVV
NegV

uFuncVN :: LD.UFuncVN -> UFuncVN
uFuncVN :: UFuncVN -> UFuncVN
uFuncVN LD.Norm = UFuncVN
Norm
uFuncVN LD.Dim = UFuncVN
Dim