module Copilot.Compile.SBV.ACSLexpr
( ppExpr
) where
import Copilot.Core
import Copilot.Core.Type.Show (showWithType, ShowType(..), showType)
import Prelude hiding (id)
import Text.PrettyPrint.HughesPJ
import Copilot.Compile.SBV.Common
import Copilot.Compile.SBV.MetaTable as MT hiding (ExternFun)
import qualified Data.Map as M
import Data.List (intersperse)
strmName :: Int -> Doc
strmName id = text "queue_" <> int id
ptrName :: Int -> Doc
ptrName id = text "ptr_" <> int id
ppExpr :: MT.MetaTable -> Expr a -> Doc
ppExpr meta e0 = parens $ case e0 of
Const t x -> text (showWithType Haskell t x)
Drop _ 0 id ->
let aa = M.lookup id (MT.streamInfoMap meta)
in case aa of
Just Stream { streamBuffer = ll } ->
let streamSize = (length ll) in
case streamSize of
1 -> strmName id <> lbrack <> (text "0") <> rbrack
_ -> strmName id <> lbrack <> (ptrName id) <> rbrack
Drop _ i id ->
let aa = M.lookup id (MT.streamInfoMap meta)
in case aa of
Just Stream { streamBuffer = ll } ->
let streamSize = (length ll) in
strmName id <> lbrack <> lparen <> ptrName id <> text (" + " ++ show i) <> rparen <> text " % " <> int streamSize <> rbrack
ExternVar _ name _ -> text $ mkExtTmpVar name
ExternFun _ name _ _ tag -> (text $ mkExtTmpTag name tag)
ExternArray _ _ name
_ _ _ tag -> (text $ mkExtTmpTag name tag)
Local _ _ name e1 e2 -> text "\\let" <+> (text name) <+> equals
<+> (ppExpr meta e1) <+> text ";" <+> (ppExpr meta e2)
Var _ name -> (text name)
Op1 op e -> ppOp1 op (ppExpr meta e)
Op2 op e1 e2 -> ppOp2 op (ppExpr meta e1) (ppExpr meta e2)
Op3 op e1 e2 e3 -> ppOp3 op (ppExpr meta e1) (ppExpr meta e2) (ppExpr meta e3)
Label t s e -> (ppExpr meta e)
ppUExpr :: MT.MetaTable -> UExpr -> Doc
ppUExpr meta UExpr { uExprExpr = e0 } = ppExpr meta e0
ppOp1 :: Op1 a b -> Doc -> Doc
ppOp1 op = case op of
Not -> ppPrefix "!"
Abs _ -> \x -> ((parens $ x <> (text " > 0")) <> text "? " <> x <> text " : -" <> x )
Sign _ -> \x -> ((parens $ x <> (text " > 0")) <> text "? 1 : ") <> (parens $ x <> (text " < 0 ? -1 : ") <> x)
Recip _ -> ppPrefix "\\recip"
Exp _ -> ppPrefix "\\exp"
Sqrt _ -> ppPrefix "\\sqrt"
Log _ -> ppPrefix "\\log"
Sin _ -> ppPrefix "\\sin"
Tan _ -> ppPrefix "\\tan"
Cos _ -> ppPrefix "\\cos"
Asin _ -> ppPrefix "\\asin"
Atan _ -> ppPrefix "\\atan"
Acos _ -> ppPrefix "\\acos"
Sinh _ -> ppPrefix "\\sinh"
Tanh _ -> ppPrefix "\\tanh"
Cosh _ -> ppPrefix "\\cosh"
Asinh _ -> ppPrefix "\\asinh"
Atanh _ -> ppPrefix "\\atanh"
Acosh _ -> ppPrefix "\\acosh"
BwNot _ -> ppPrefix "~"
Cast _ _ -> ppPrefix ""
ppOp2 :: Op2 a b c -> Doc -> Doc -> Doc
ppOp2 op = case op of
And -> ppInfix "&&"
Or -> ppInfix "||"
Add _ -> ppInfix "+"
Sub _ -> ppInfix "-"
Mul _ -> ppInfix "*"
Div _ -> ppInfix "/"
Mod _ -> ppInfix "%"
Fdiv _ -> ppInfix "/"
Pow _ -> ppPrefix2 "\\pow"
Logb _ -> \ a b -> (text "(\\log" <> (a) <> (text ") / ( \\log") <> (b) <> text ")")
Eq _ -> ppInfix "=="
Ne _ -> ppInfix "!="
Le _ -> ppInfix "<="
Ge _ -> ppInfix ">="
Lt _ -> ppInfix "<"
Gt _ -> ppInfix ">"
BwAnd _ -> ppInfix "&"
BwOr _ -> ppInfix "|"
BwXor _ -> ppInfix "^"
BwShiftL _ _ -> ppInfix "<<"
BwShiftR _ _ -> ppInfix ">>"
ppOp3 :: Op3 a b c d -> Doc -> Doc -> Doc -> Doc
ppOp3 op = case op of
Mux _ -> \ doc1 doc2 doc3 ->
text "(" <+> doc1 <+>
text "?" <+> doc2 <+>
text ":" <+> doc3 <> text ")"
ppInfix :: String -> Doc -> Doc -> Doc
ppInfix cs doc1 doc2 = parens $ doc1 <+> text cs <+> doc2
ppPrefix2 :: String -> Doc -> Doc -> Doc
ppPrefix2 cs doc1 doc2 = parens $ text cs <+> doc1 <> text "," <+> doc2
ppPrefix :: String -> Doc -> Doc
ppPrefix cs doc = (text cs <+> lparen <> doc <> rparen)