{-# LANGUAGE FlexibleContexts #-}
-- | Generic constructors and smart constructors to be used in renderers
module Drasil.Shared.LanguageRenderer.Constructors (
  mkStmt, mkStmtNoEnd, mkStateVal, mkVal, mkStateVar, mkVar, mkClassVar,
  typeFromData, VSOp, mkOp, unOpPrec, compEqualPrec, compPrec, addPrec, multPrec,
  powerPrec, andPrec, orPrec, inPrec, unExpr, unExpr', unExprNumDbl, typeUnExpr,
  binExpr, binExpr', binExprNumDbl', typeBinExpr
) where

import Drasil.Shared.InterfaceCommon (SVariable, Value, SValue, TypeSym(..),
  ValueSym(..), getCodeType, TypeElim)
import Drasil.Shared.RendererClassesCommon (VSUnOp, VSBinOp,
  OpElim(uOpPrec, bOpPrec), RenderVariable(..), RenderValue(..),
  ValueElim(valuePrec), RenderStatement(..))
import qualified Drasil.Shared.RendererClassesCommon as RC (uOp, bOp, value)
import Drasil.Shared.LanguageRenderer (unOpDocD, unOpDocD', binOpDocD, binOpDocD')
import Drasil.Shared.AST (Terminator(..), AttachmentTag(..), OpData, od,
  TypeData, td)
import Drasil.Shared.CodeType (CodeType(..))
import Drasil.Shared.Helpers (toCode, toState, on2StateValues)
import Drasil.Shared.State (MS, VS)

import Text.PrettyPrint.HughesPJ (Doc, parens, text)
import Data.Composition ((.:))
import Control.Monad (join)

-- Statements

-- | Constructs a statement terminated by a semi-colon
mkStmt :: (RenderStatement r smt) => Doc -> MS (r smt)
mkStmt :: forall (r :: * -> *) smt.
RenderStatement r smt =>
Doc -> MS (r smt)
mkStmt = (Doc -> Terminator -> MS (r smt))
-> Terminator -> Doc -> MS (r smt)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Doc -> Terminator -> MS (r smt)
forall (r :: * -> *) smt.
RenderStatement r smt =>
Doc -> Terminator -> MS (r smt)
stmtFromData Terminator
Semi

-- | Constructs a statement without a termination character
mkStmtNoEnd :: (RenderStatement r smt) => Doc -> MS (r smt)
mkStmtNoEnd :: forall (r :: * -> *) smt.
RenderStatement r smt =>
Doc -> MS (r smt)
mkStmtNoEnd = (Doc -> Terminator -> MS (r smt))
-> Terminator -> Doc -> MS (r smt)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Doc -> Terminator -> MS (r smt)
forall (r :: * -> *) smt.
RenderStatement r smt =>
Doc -> Terminator -> MS (r smt)
stmtFromData Terminator
Empty

-- Values --

-- | Constructs a value in a stateful context
mkStateVal :: (RenderValue r) => VS (r TypeData) -> Doc -> SValue r
mkStateVal :: forall (r :: * -> *).
RenderValue r =>
VS (r TypeData) -> Doc -> SValue r
mkStateVal = Maybe Int -> Maybe Integer -> VS (r TypeData) -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Maybe Int -> Maybe Integer -> VS (r TypeData) -> Doc -> SValue r
valFromData Maybe Int
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing

-- | Constructs a value in a non-stateful context
mkVal :: (RenderValue r) => r TypeData -> Doc -> SValue r
mkVal :: forall (r :: * -> *).
RenderValue r =>
r TypeData -> Doc -> SValue r
mkVal r TypeData
t = Maybe Int -> Maybe Integer -> VS (r TypeData) -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Maybe Int -> Maybe Integer -> VS (r TypeData) -> Doc -> SValue r
valFromData Maybe Int
forall a. Maybe a
Nothing Maybe Integer
forall a. Maybe a
Nothing (r TypeData -> VS (r TypeData)
forall a s. a -> State s a
toState r TypeData
t)

-- Variables --

-- | Constructs an instance-level variable in a stateful context
mkStateVar :: (RenderVariable r) => String -> VS (r TypeData) -> Doc -> SVariable r
mkStateVar :: forall (r :: * -> *).
RenderVariable r =>
String -> VS (r TypeData) -> Doc -> SVariable r
mkStateVar = AttachmentTag -> String -> VS (r TypeData) -> Doc -> SVariable r
forall (r :: * -> *).
RenderVariable r =>
AttachmentTag -> String -> VS (r TypeData) -> Doc -> SVariable r
varFromData AttachmentTag
InstanceLevel

-- | Constructs an instance-level variable in a non-stateful context
mkVar :: (RenderVariable r) => String -> r TypeData -> Doc -> SVariable r
mkVar :: forall (r :: * -> *).
RenderVariable r =>
String -> r TypeData -> Doc -> SVariable r
mkVar String
n r TypeData
t = AttachmentTag -> String -> VS (r TypeData) -> Doc -> SVariable r
forall (r :: * -> *).
RenderVariable r =>
AttachmentTag -> String -> VS (r TypeData) -> Doc -> SVariable r
varFromData AttachmentTag
InstanceLevel String
n (r TypeData -> VS (r TypeData)
forall a s. a -> State s a
toState r TypeData
t)

-- | Constructs a classLevel variable in a stateful context
mkClassVar :: (RenderVariable r) => String -> VS (r TypeData) -> Doc -> SVariable r
mkClassVar :: forall (r :: * -> *).
RenderVariable r =>
String -> VS (r TypeData) -> Doc -> SVariable r
mkClassVar = AttachmentTag -> String -> VS (r TypeData) -> Doc -> SVariable r
forall (r :: * -> *).
RenderVariable r =>
AttachmentTag -> String -> VS (r TypeData) -> Doc -> SVariable r
varFromData AttachmentTag
ClassLevel

-- Types --
typeFromData :: (Monad r) => CodeType -> String -> Doc -> VS (r TypeData)
typeFromData :: forall (r :: * -> *).
Monad r =>
CodeType -> String -> Doc -> VS (r TypeData)
typeFromData CodeType
t String
s Doc
d = r TypeData -> StateT ValueState Identity (r TypeData)
forall a. a -> StateT ValueState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (r TypeData -> StateT ValueState Identity (r TypeData))
-> r TypeData -> StateT ValueState Identity (r TypeData)
forall a b. (a -> b) -> a -> b
$ TypeData -> r TypeData
forall a. a -> r a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeData -> r TypeData) -> TypeData -> r TypeData
forall a b. (a -> b) -> a -> b
$ CodeType -> String -> Doc -> TypeData
td CodeType
t String
s Doc
d

-- Operators --

type VSOp r = VS (r OpData)

-- | Construct an operator with given precedence and rendering
mkOp :: (Monad r) => Int -> Doc -> VSOp r
mkOp :: forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
p Doc
d = r OpData -> State ValueState (r OpData)
forall a s. a -> State s a
toState (r OpData -> State ValueState (r OpData))
-> r OpData -> State ValueState (r OpData)
forall a b. (a -> b) -> a -> b
$ OpData -> r OpData
forall (r :: * -> *) a. Monad r => a -> r a
toCode (OpData -> r OpData) -> OpData -> r OpData
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> OpData
od Int
p Doc
d

-- | Construct an operator with typical unary-operator precedence
unOpPrec :: (Monad r) => String -> VSOp r
unOpPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
unOpPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
9 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- | Construct an operator with equality-comparison-level precedence
compEqualPrec :: (Monad r) => String -> VSOp r
compEqualPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
compEqualPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
4 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- | Construct an operator with comparison-level precedence
compPrec :: (Monad r) => String -> VSOp r
compPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
compPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
5 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- | Construct an operator with addition-level precedence
addPrec :: (Monad r) => String -> VSOp r
addPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
addPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
6 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- | Construct an operator with multiplication-level precedence
multPrec :: (Monad r) => String -> VSOp r
multPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
multPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
7 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- | Construct an operator with exponentiation-level precedence
powerPrec :: (Monad r) => String -> VSOp r
powerPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
powerPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
8 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- | Construct an operator with conjunction-level precedence
andPrec :: (Monad r) => String -> VSOp r
andPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
andPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
3 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- | Construct an operator with disjunction-level precedence
orPrec :: (Monad r) => String -> VSOp r
orPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
orPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
2 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

inPrec :: (Monad r) => String -> VSOp r
inPrec :: forall (r :: * -> *). Monad r => String -> VSOp r
inPrec = Int -> Doc -> VSOp r
forall (r :: * -> *). Monad r => Int -> Doc -> VSOp r
mkOp Int
2 (Doc -> VSOp r) -> (String -> Doc) -> String -> VSOp r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text

-- Expressions --

-- | Constructs a unary expression like ln(v), for some operator ln and value v
unExpr
  :: (OpElim r, RenderValue r, ValueElim r, ValueSym r)
  => VSUnOp r -> SValue r -> SValue r
unExpr :: forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r, ValueSym r) =>
VSUnOp r -> SValue r -> SValue r
unExpr = StateT ValueState Identity (StateT ValueState Identity (r Value))
-> StateT ValueState Identity (r Value)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (StateT ValueState Identity (StateT ValueState Identity (r Value))
 -> StateT ValueState Identity (r Value))
-> (VSUnOp r
    -> StateT ValueState Identity (r Value)
    -> StateT
         ValueState Identity (StateT ValueState Identity (r Value)))
-> VSUnOp r
-> StateT ValueState Identity (r Value)
-> StateT ValueState Identity (r Value)
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: (r OpData -> r Value -> StateT ValueState Identity (r Value))
-> VSUnOp r
-> StateT ValueState Identity (r Value)
-> StateT
     ValueState Identity (StateT ValueState Identity (r Value))
forall a b c s.
(a -> b -> c) -> State s a -> State s b -> State s c
on2StateValues ((Doc -> Doc -> Doc)
-> r OpData -> r Value -> StateT ValueState Identity (r Value)
forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r, ValueSym r) =>
(Doc -> Doc -> Doc) -> r OpData -> r Value -> SValue r
mkUnExpr Doc -> Doc -> Doc
unOpDocD)

-- | Constructs a unary expression like -v, for some operator - and value v
unExpr'
  :: (OpElim r, RenderValue r, ValueElim r, ValueSym r)
  => VSUnOp r -> SValue r -> SValue r
unExpr' :: forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r, ValueSym r) =>
VSUnOp r -> SValue r -> SValue r
unExpr' VSUnOp r
u' SValue r
v'= do
  r OpData
u <- VSUnOp r
u'
  r Value
v <- SValue r
v'
  (StateT ValueState Identity (SValue r) -> SValue r
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (StateT ValueState Identity (SValue r) -> SValue r)
-> (VSUnOp r -> SValue r -> StateT ValueState Identity (SValue r))
-> VSUnOp r
-> SValue r
-> SValue r
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: (r OpData -> r Value -> SValue r)
-> VSUnOp r -> SValue r -> StateT ValueState Identity (SValue r)
forall a b c s.
(a -> b -> c) -> State s a -> State s b -> State s c
on2StateValues ((Doc -> Doc -> Doc) -> r OpData -> r Value -> SValue r
forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r, ValueSym r) =>
(Doc -> Doc -> Doc) -> r OpData -> r Value -> SValue r
mkUnExpr
    (if Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< r OpData -> Int
forall (r :: * -> *). OpElim r => r OpData -> Int
uOpPrec r OpData
u) (r Value -> Maybe Int
forall (r :: * -> *). ValueElim r => r Value -> Maybe Int
valuePrec r Value
v)
       then Doc -> Doc -> Doc
unOpDocD
        else Doc -> Doc -> Doc
unOpDocD')))
    VSUnOp r
u' SValue r
v'

mkUnExpr
  :: (OpElim r, RenderValue r, ValueElim r, ValueSym r)
  => (Doc -> Doc -> Doc) -> r OpData -> r Value -> SValue r
mkUnExpr :: forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r, ValueSym r) =>
(Doc -> Doc -> Doc) -> r OpData -> r Value -> SValue r
mkUnExpr Doc -> Doc -> Doc
d r OpData
u r Value
v = Int -> r TypeData -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Int -> r TypeData -> Doc -> SValue r
mkExpr (r OpData -> Int
forall (r :: * -> *). OpElim r => r OpData -> Int
uOpPrec r OpData
u) (r Value -> r TypeData
forall (r :: * -> *). ValueSym r => r Value -> r TypeData
valueType r Value
v) (Doc -> Doc -> Doc
d (r OpData -> Doc
forall (r :: * -> *). OpElim r => r OpData -> Doc
RC.uOp r OpData
u) (r Value -> Doc
forall (r :: * -> *). ValueElim r => r Value -> Doc
RC.value r Value
v))

-- | To be used in languages where the unary operator returns a double. If the
-- value passed to the operator is a float, this function preserves that type
-- by casting the result to a float.
unExprNumDbl
  :: (OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r)
  => VSUnOp r -> SValue r -> SValue r
unExprNumDbl :: forall (r :: * -> *).
(OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r) =>
VSUnOp r -> SValue r -> SValue r
unExprNumDbl VSUnOp r
u' SValue r
v' = do
  r OpData
u <- VSUnOp r
u'
  r Value
v <- SValue r
v'
  r Value
w <- (Doc -> Doc -> Doc) -> r OpData -> r Value -> SValue r
forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r, ValueSym r) =>
(Doc -> Doc -> Doc) -> r OpData -> r Value -> SValue r
mkUnExpr Doc -> Doc -> Doc
unOpDocD r OpData
u r Value
v
  r TypeData -> r Value -> SValue r
forall (r :: * -> *).
(RenderValue r, TypeElim r) =>
r TypeData -> r Value -> SValue r
unExprCastFloat (r Value -> r TypeData
forall (r :: * -> *). ValueSym r => r Value -> r TypeData
valueType r Value
v) r Value
w

-- Only used by unExprNumDbl
unExprCastFloat
  :: (RenderValue r, TypeElim r)
  => r TypeData -> r Value -> SValue r
unExprCastFloat :: forall (r :: * -> *).
(RenderValue r, TypeElim r) =>
r TypeData -> r Value -> SValue r
unExprCastFloat r TypeData
t = CodeType -> SValue r -> SValue r
forall {r :: * -> *}.
(RenderValue r, TypeSym r) =>
CodeType -> SValue r -> SValue r
castType (r TypeData -> CodeType
forall (r :: * -> *). TypeElim r => r TypeData -> CodeType
getCodeType r TypeData
t) (SValue r -> SValue r)
-> (r Value -> SValue r) -> r Value -> SValue r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r Value -> SValue r
forall a s. a -> State s a
toState
  where castType :: CodeType -> SValue r -> SValue r
castType CodeType
Float = VS (r TypeData) -> SValue r -> SValue r
forall (r :: * -> *).
RenderValue r =>
VS (r TypeData) -> SValue r -> SValue r
cast VS (r TypeData)
forall (r :: * -> *). TypeSym r => VS (r TypeData)
float
        castType CodeType
_ = SValue r -> SValue r
forall a. a -> a
id

-- | To be used when the type of the value is different from the type of the
-- resulting expression. The type of the result is passed as a parameter.
typeUnExpr
  :: (OpElim r, RenderValue r, ValueElim r)
  => VSUnOp r -> VS (r TypeData) -> SValue r -> SValue r
typeUnExpr :: forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r) =>
VSUnOp r -> VS (r TypeData) -> SValue r -> SValue r
typeUnExpr VSUnOp r
u' VS (r TypeData)
t' SValue r
s' = do
  r OpData
u <- VSUnOp r
u'
  r TypeData
t <- VS (r TypeData)
t'
  r Value
s <- SValue r
s'
  Int -> r TypeData -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Int -> r TypeData -> Doc -> SValue r
mkExpr (r OpData -> Int
forall (r :: * -> *). OpElim r => r OpData -> Int
uOpPrec r OpData
u) r TypeData
t (Doc -> Doc -> Doc
unOpDocD (r OpData -> Doc
forall (r :: * -> *). OpElim r => r OpData -> Doc
RC.uOp r OpData
u) (r Value -> Doc
forall (r :: * -> *). ValueElim r => r Value -> Doc
RC.value r Value
s))

-- | Constructs binary expressions like v + w, for some operator + and values v
-- and w, parenthesizing v and w if needed.
binExpr
  :: (OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r)
  => VSBinOp r -> SValue r -> SValue r -> SValue r
binExpr :: forall (r :: * -> *).
(OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r) =>
VSBinOp r -> SValue r -> SValue r -> SValue r
binExpr VSBinOp r
b' SValue r
v1' SValue r
v2'= do
  r OpData
b <- VSBinOp r
b'
  r TypeData
exprType <- SValue r -> SValue r -> VS (r TypeData)
forall (r :: * -> *).
(TypeElim r, ValueSym r) =>
SValue r -> SValue r -> VS (r TypeData)
numType SValue r
v1' SValue r
v2'
  Doc
exprRender <- (r OpData -> r Value -> r Value -> Doc)
-> VSBinOp r -> SValue r -> SValue r -> VS Doc
forall (r :: * -> *).
(r OpData -> r Value -> r Value -> Doc)
-> VSBinOp r -> SValue r -> SValue r -> VS Doc
exprRender' r OpData -> r Value -> r Value -> Doc
forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> r Value -> Doc
binExprRender VSBinOp r
b' SValue r
v1' SValue r
v2'
  Int -> r TypeData -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Int -> r TypeData -> Doc -> SValue r
mkExpr (r OpData -> Int
forall (r :: * -> *). OpElim r => r OpData -> Int
bOpPrec r OpData
b) r TypeData
exprType Doc
exprRender

-- | Constructs binary expressions like pow(v,w), for some operator pow and
-- values v and w
binExpr'
  :: (OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r)
  => VSBinOp r -> SValue r -> SValue r -> SValue r
binExpr' :: forall (r :: * -> *).
(OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r) =>
VSBinOp r -> SValue r -> SValue r -> SValue r
binExpr' VSBinOp r
b' SValue r
v1' SValue r
v2' = do
  r TypeData
exprType <- SValue r -> SValue r -> VS (r TypeData)
forall (r :: * -> *).
(TypeElim r, ValueSym r) =>
SValue r -> SValue r -> VS (r TypeData)
numType SValue r
v1' SValue r
v2'
  Doc
exprRender <- (r OpData -> r Value -> r Value -> Doc)
-> VSBinOp r -> SValue r -> SValue r -> VS Doc
forall (r :: * -> *).
(r OpData -> r Value -> r Value -> Doc)
-> VSBinOp r -> SValue r -> SValue r -> VS Doc
exprRender' r OpData -> r Value -> r Value -> Doc
forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> r Value -> Doc
binOpDocDRend VSBinOp r
b' SValue r
v1' SValue r
v2'
  Int -> r TypeData -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Int -> r TypeData -> Doc -> SValue r
mkExpr Int
9 r TypeData
exprType Doc
exprRender

-- | To be used in languages where the binary operator returns a double. If
-- either value passed to the operator is a float, this function preserves that
-- type by casting the result to a float.
binExprNumDbl'
  :: (OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r)
  => VSBinOp r -> SValue r -> SValue r -> SValue r
binExprNumDbl' :: forall (r :: * -> *).
(OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r) =>
VSBinOp r -> SValue r -> SValue r -> SValue r
binExprNumDbl' VSBinOp r
b' SValue r
v1' SValue r
v2' = do
  r Value
v1 <- SValue r
v1'
  r Value
v2 <- SValue r
v2'
  let t1 :: r TypeData
t1 = r Value -> r TypeData
forall (r :: * -> *). ValueSym r => r Value -> r TypeData
valueType r Value
v1
      t2 :: r TypeData
t2 = r Value -> r TypeData
forall (r :: * -> *). ValueSym r => r Value -> r TypeData
valueType r Value
v2
  r Value
e <- VSBinOp r -> SValue r -> SValue r -> SValue r
forall (r :: * -> *).
(OpElim r, RenderValue r, TypeElim r, ValueElim r, ValueSym r) =>
VSBinOp r -> SValue r -> SValue r -> SValue r
binExpr' VSBinOp r
b' SValue r
v1' SValue r
v2'
  r TypeData -> r TypeData -> r Value -> SValue r
forall (r :: * -> *).
(RenderValue r, TypeElim r) =>
r TypeData -> r TypeData -> r Value -> SValue r
binExprCastFloat r TypeData
t1 r TypeData
t2 r Value
e

-- Only used by binExprNumDbl'
binExprCastFloat
  :: (RenderValue r, TypeElim r)
  => r TypeData -> r TypeData -> r Value -> SValue r
binExprCastFloat :: forall (r :: * -> *).
(RenderValue r, TypeElim r) =>
r TypeData -> r TypeData -> r Value -> SValue r
binExprCastFloat r TypeData
t1 r TypeData
t2 = CodeType -> CodeType -> SValue r -> SValue r
forall {r :: * -> *}.
(RenderValue r, TypeSym r) =>
CodeType -> CodeType -> SValue r -> SValue r
castType (r TypeData -> CodeType
forall (r :: * -> *). TypeElim r => r TypeData -> CodeType
getCodeType r TypeData
t1) (r TypeData -> CodeType
forall (r :: * -> *). TypeElim r => r TypeData -> CodeType
getCodeType r TypeData
t2) (SValue r -> SValue r)
-> (r Value -> SValue r) -> r Value -> SValue r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r Value -> SValue r
forall a s. a -> State s a
toState
  where castType :: CodeType -> CodeType -> SValue r -> SValue r
castType CodeType
Float CodeType
_ = VS (r TypeData) -> SValue r -> SValue r
forall (r :: * -> *).
RenderValue r =>
VS (r TypeData) -> SValue r -> SValue r
cast VS (r TypeData)
forall (r :: * -> *). TypeSym r => VS (r TypeData)
float
        castType CodeType
_ CodeType
Float = VS (r TypeData) -> SValue r -> SValue r
forall (r :: * -> *).
RenderValue r =>
VS (r TypeData) -> SValue r -> SValue r
cast VS (r TypeData)
forall (r :: * -> *). TypeSym r => VS (r TypeData)
float
        castType CodeType
_ CodeType
_ = SValue r -> SValue r
forall a. a -> a
id

-- | To be used when the types of the values are different from the type of the
-- resulting expression. The type of the result is passed as a parameter.
typeBinExpr
  :: (OpElim r, RenderValue r, ValueElim r)
  => VSBinOp r -> VS (r TypeData) -> SValue r -> SValue r -> SValue r
typeBinExpr :: forall (r :: * -> *).
(OpElim r, RenderValue r, ValueElim r) =>
VSBinOp r -> VS (r TypeData) -> SValue r -> SValue r -> SValue r
typeBinExpr VSBinOp r
b' VS (r TypeData)
t' SValue r
v1' SValue r
v2' = do
  r OpData
b <- VSBinOp r
b'
  r TypeData
t <- VS (r TypeData)
t'
  Doc
bnexr <- (r OpData -> r Value -> r Value -> Doc)
-> VSBinOp r -> SValue r -> SValue r -> VS Doc
forall (r :: * -> *).
(r OpData -> r Value -> r Value -> Doc)
-> VSBinOp r -> SValue r -> SValue r -> VS Doc
exprRender' r OpData -> r Value -> r Value -> Doc
forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> r Value -> Doc
binExprRender VSBinOp r
b' SValue r
v1' SValue r
v2'
  Int -> r TypeData -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Int -> r TypeData -> Doc -> SValue r
mkExpr (r OpData -> Int
forall (r :: * -> *). OpElim r => r OpData -> Int
bOpPrec r OpData
b) r TypeData
t Doc
bnexr

-- For numeric binary expressions, checks that both types are numeric and
-- returns result type. Selects the type with lowest precision.
numType
  :: (TypeElim r, ValueSym r)
  => SValue r-> SValue r -> VS (r TypeData)
numType :: forall (r :: * -> *).
(TypeElim r, ValueSym r) =>
SValue r -> SValue r -> VS (r TypeData)
numType SValue r
v1' SValue r
v2' = do
  r Value
v1 <- SValue r
v1'
  r Value
v2 <- SValue r
v2'
  let t1 :: r TypeData
t1 = r Value -> r TypeData
forall (r :: * -> *). ValueSym r => r Value -> r TypeData
valueType r Value
v1
      t2 :: r TypeData
t2 = r Value -> r TypeData
forall (r :: * -> *). ValueSym r => r Value -> r TypeData
valueType r Value
v2
      numericType :: CodeType -> CodeType -> r TypeData
numericType CodeType
Integer CodeType
Integer = r TypeData
t1
      numericType CodeType
Float CodeType
_ = r TypeData
t1
      numericType CodeType
_ CodeType
Float = r TypeData
t2
      numericType CodeType
Double CodeType
_ = r TypeData
t1
      numericType CodeType
_ CodeType
Double = r TypeData
t2
      numericType CodeType
_ CodeType
_ = String -> r TypeData
forall a. HasCallStack => String -> a
error String
"Numeric types required for numeric expression"
  r TypeData -> VS (r TypeData)
forall a s. a -> State s a
toState (r TypeData -> VS (r TypeData)) -> r TypeData -> VS (r TypeData)
forall a b. (a -> b) -> a -> b
$ CodeType -> CodeType -> r TypeData
numericType (r TypeData -> CodeType
forall (r :: * -> *). TypeElim r => r TypeData -> CodeType
getCodeType r TypeData
t1) (r TypeData -> CodeType
forall (r :: * -> *). TypeElim r => r TypeData -> CodeType
getCodeType r TypeData
t2)

exprRender' :: (r OpData -> r Value -> r Value -> Doc) ->
  VSBinOp r -> SValue r -> SValue r -> VS Doc
exprRender' :: forall (r :: * -> *).
(r OpData -> r Value -> r Value -> Doc)
-> VSBinOp r -> SValue r -> SValue r -> VS Doc
exprRender' r OpData -> r Value -> r Value -> Doc
f VSBinOp r
b' SValue r
v1' SValue r
v2' = do
  r OpData
b <- VSBinOp r
b'
  r Value
v1 <- SValue r
v1'
  r Value
v2 <- SValue r
v2'
  Doc -> VS Doc
forall a s. a -> State s a
toState (Doc -> VS Doc) -> Doc -> VS Doc
forall a b. (a -> b) -> a -> b
$ r OpData -> r Value -> r Value -> Doc
f r OpData
b r Value
v1 r Value
v2

mkExpr :: (RenderValue r) => Int -> r TypeData -> Doc -> SValue r
mkExpr :: forall (r :: * -> *).
RenderValue r =>
Int -> r TypeData -> Doc -> SValue r
mkExpr Int
p r TypeData
t = Maybe Int -> Maybe Integer -> VS (r TypeData) -> Doc -> SValue r
forall (r :: * -> *).
RenderValue r =>
Maybe Int -> Maybe Integer -> VS (r TypeData) -> Doc -> SValue r
valFromData (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
p) Maybe Integer
forall a. Maybe a
Nothing (r TypeData -> VS (r TypeData)
forall a s. a -> State s a
toState r TypeData
t)

binOpDocDRend
  :: (OpElim r, ValueElim r)
  => r OpData -> r Value -> r Value -> Doc
binOpDocDRend :: forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> r Value -> Doc
binOpDocDRend r OpData
b r Value
v1 r Value
v2 = Doc -> Doc -> Doc -> Doc
binOpDocD' (r OpData -> Doc
forall (r :: * -> *). OpElim r => r OpData -> Doc
RC.bOp r OpData
b) (r Value -> Doc
forall (r :: * -> *). ValueElim r => r Value -> Doc
RC.value r Value
v1) (r Value -> Doc
forall (r :: * -> *). ValueElim r => r Value -> Doc
RC.value r Value
v2)

-- Adds parentheses around an expression passed as the left argument to a
-- left-associative binary operator if the precedence of the expression is less
-- than the precedence of the operator
exprParensL :: (OpElim r, ValueElim r) => r OpData -> r Value -> Doc
exprParensL :: forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> Doc
exprParensL r OpData
o r Value
v = (if Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< r OpData -> Int
forall (r :: * -> *). OpElim r => r OpData -> Int
bOpPrec r OpData
o) (r Value -> Maybe Int
forall (r :: * -> *). ValueElim r => r Value -> Maybe Int
valuePrec r Value
v) then Doc -> Doc
parens else
  Doc -> Doc
forall a. a -> a
id) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ r Value -> Doc
forall (r :: * -> *). ValueElim r => r Value -> Doc
RC.value r Value
v

-- Adds parentheses around an expression passed as the right argument to a
-- left-associative binary operator if the precedence of the expression is less
-- than or equal to the precedence of the operator
exprParensR :: (OpElim r, ValueElim r) => r OpData -> r Value -> Doc
exprParensR :: forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> Doc
exprParensR r OpData
o r Value
v = (if Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= r OpData -> Int
forall (r :: * -> *). OpElim r => r OpData -> Int
bOpPrec r OpData
o) (r Value -> Maybe Int
forall (r :: * -> *). ValueElim r => r Value -> Maybe Int
valuePrec r Value
v) then Doc -> Doc
parens else
  Doc -> Doc
forall a. a -> a
id) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ r Value -> Doc
forall (r :: * -> *). ValueElim r => r Value -> Doc
RC.value r Value
v

-- Renders binary expression, adding parentheses if needed
binExprRender
  :: (OpElim r, ValueElim r)
  =>  r OpData -> r Value -> r Value -> Doc
binExprRender :: forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> r Value -> Doc
binExprRender r OpData
b r Value
v1 r Value
v2 =
  let leftExpr :: Doc
leftExpr = r OpData -> r Value -> Doc
forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> Doc
exprParensL r OpData
b r Value
v1
      rightExpr :: Doc
rightExpr = r OpData -> r Value -> Doc
forall (r :: * -> *).
(OpElim r, ValueElim r) =>
r OpData -> r Value -> Doc
exprParensR r OpData
b r Value
v2
  in Doc -> Doc -> Doc -> Doc
binOpDocD (r OpData -> Doc
forall (r :: * -> *). OpElim r => r OpData -> Doc
RC.bOp r OpData
b) Doc
leftExpr Doc
rightExpr