module DDC.Core.Babel.PHP where
import DDC.Core.Collect
import DDC.Core.Module
import DDC.Core.Exp.Annot
import DDC.Base.Pretty
import DDC.Type.DataDef
import qualified DDC.Core.Tetra.Prim as T
import qualified DDC.Type.Env as Env
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe (isNothing)
phpOfModule
:: (Show a)
=> Module a T.Name
-> Doc
phpOfModule mm
= let ds = phpOfDataDefs $ moduleDataDefsLocal mm
m = Map.fromList
$ map arityOfImport $ moduleImportValues mm
xs = phpOfExp (moduleBody mm) CTop m
in vcat [ text "<?php"
, ds
, xs
, text "?>" ]
where
arityOfImport (n,i)
= case i of
ImportValueModule{}
| Just (_,a, _) <- importValueModuleArity i
-> (n, a)
| otherwise
-> (n, arityOfType' (importValueModuleType i))
ImportValueSea{}
-> (n, arityOfType' (importValueSeaType i))
arityOfType' = arityOfType . eraseTForalls
phpOfDataDefs
:: [DataDef T.Name]
-> Doc
phpOfDataDefs ds
= vcat $ concatMap def ds
where
def d
| Just cs <- dataDefCtors d
= map ctor cs
| otherwise
= []
ctor c
= let name = dataCtorName c
args = map (("_"++) . show) [1..length (dataCtorFieldTypes c)]
in vcat
[ text "class" <+> bare_name name <+> text "{"
, indent 4 $ vcat $
[ text "function __construct" <> parenss (map var_name_t args) <+> text "{"
, indent 4 $ vcat
$ map (\i -> obj_field_tt "this" i
<> text " = " <> var_name_t i <> text ";") args
, indent 4 $ obj_field_tt "this" "tag" <+> text " = " <+> string_of name <> text ";"
, text "}"
]
, text "}"
]
data Context
= CLet (Bind T.Name)
| CRet
| CTop
| CExp
phpOfExp
:: (Show a)
=> Exp a T.Name
-> Context
-> Map.Map T.Name Int
-> Doc
phpOfExp xx ctx m
= case xx of
XVar _ v
| UName n <- v
, Just arity <- Map.lookup n m
-> wrap $ text "DDC::curry(" <> bare_name n <> text ", "
<> text (show arity) <> text ")"
| UPrim p _ <- v
-> wrap $ phpOfPrimOp p []
| otherwise
-> wrap $ var_name_u v
XCon _ DaConUnit
-> wrap $ text "1"
XCon _ (DaConPrim n _t)
-> wrap $ sanitise_prim n
XCon _ (DaConBound n)
-> wrap $ text "new " <> bare_name n
XLAM _ _ x
-> phpOfExp x ctx m
XLam a _ _
| Just (bs, f) <- takeXLamFlags xx
, bs' <- filter (not.fst) bs
-> wrap $ text "DDC::curry(/* Lam " <+> text (show a)
<+> text "*/" <+> makeFunction Nothing bs f m <> text ", "
<> text (show (length bs')) <> text ")"
XApp _ f x
| (f',xs) <- takeXApps1 f x
, xs' <- noTypes xs
, XVar _ (UName n)
<- f'
, Just arity <- Map.lookup n m
-> if arity == length xs'
then wrap $ bare_name n <> parenss (map (\arg -> phpOfExp arg CExp m) xs')
else wrap $ text "DDC::apply"
<> parenss ((text "DDC::curry(" <> bare_name n <> text ", " <> text (show arity)
<> text ")") : map (\arg -> phpOfExp arg CExp m) xs')
| (f',xs) <- takeXApps1 f x
, xs' <- noTypes xs
, XVar _ (UPrim p _)
<- f'
-> wrap $ phpOfPrimOp p (map (\arg -> phpOfExp arg CExp m) xs')
| (f',xs) <- takeXApps1 f x
, xs' <- noTypes xs
-> wrap $ phpOfExp f' CExp m <> parenss (map (\arg -> phpOfExp arg CExp m) xs')
XLet a lets x
| (ldocs, m') <- phpOfLets lets ctx m
-> vcat
[ text "/* Let " <> text (show a) <> text " */"
, ldocs
, phpOfExp x ctx m'
]
XCase a x alts
-> vcat
[ text "/* Case " <> text (show a) <> text " */"
, text "$SCRUT = " <> phpOfExp x CExp m <> text ";"
, phpOfAlts "SCRUT" alts ctx m
]
XCast _ _ x
-> phpOfExp x ctx m
_
-> error ("ddc-core-babel.phpOfExp No can do: " ++ show (ppr xx))
where
wrap d
= case ctx of
CTop -> text ""
CExp -> d
CLet (BNone _) -> d <> text ";"
CLet b -> var_name_b b <> text " = " <> d <> text ";"
CRet -> text "return " <> d <> text ";"
phpOfLets
:: (Show a)
=> Lets a T.Name
-> Context
-> Map.Map T.Name Int
-> (Doc, Map.Map T.Name Int)
phpOfLets lets ctx m
= case lets of
LLet b x
| Just (bs, f) <- takeXLamFlags x
, CTop <- ctx
-> (makeFunction (Just b) bs f m, insertArity (b,x) m)
| otherwise
-> (phpOfExp x (CLet b) m <> line, m)
LRec bxs
| m' <- foldr insertArity m bxs
-> ( foldl (<>) empty $ map (\(b,x) -> fst $ phpOfLets (LLet b x) ctx m') bxs
, m')
_
-> error "ddc-core-babel.phpOfLets: no private or withregion"
where
insertArity (b,x) mm
| Just (bs, _) <- takeXLamFlags x
, BName n _<- b
, bs' <- filter (not.fst) bs
, CTop <- ctx
= Map.insert n (length bs') mm
| otherwise
= mm
phpOfAlts
:: (Show a)
=> String
-> [Alt a T.Name]
-> Context
-> Map.Map T.Name Int
-> Doc
phpOfAlts scrut alts ctx m
= go alts
where
go []
= text ""
go (AAlt (PData dc bs) x : as)
= vcat
[ text "if (" <> cond dc <> text ") {"
, indent 4 (grabfields bs)
, indent 4 (phpOfExp x ctx m)
, text " }"
, case as of [] -> text ""
(_:_) -> text "else" <> go as
]
go (AAlt PDefault x : _)
= vcat
[ text "{"
, indent 4 (phpOfExp x ctx m)
, text "}" ]
cond DaConUnit
= text "true"
cond (DaConPrim n _t)
= var_name_t scrut <> text " == " <> (sanitise_prim n)
cond (DaConBound n)
= obj_field_tt scrut "tag" <> text " == " <> string_of n
grabfields bs
= vcat $ zipWith grabfield bs [1 :: Int ..]
grabfield b i
= var_name_b b <> text " = " <> obj_field_tt scrut ("_" ++ show i) <> text ";"
makeFunction
:: (Show a)
=> Maybe (Bind T.Name)
-> [(Bool, Bind T.Name)]
-> Exp a T.Name
-> Map.Map T.Name Int
-> Doc
makeFunction nm bs x m
= text "function "
<> maybe (text "") bare_name_b nm
<> parenss (map (var_name_b.snd) $ filter (not.fst) bs)
<> use_
<> text " { "
<> line
<> indent 4 (phpOfExp x CRet m)
<> line
<> text " }"
where
fx = map var_name_u
$ filter (\vu -> case vu of UName _ -> True ; _ -> False)
$ Set.toList
$ freeX Env.empty
$ makeXLamFlags (annotOfExp x) bs x
use_
= case nm of
Nothing
| not $ null fx
-> text " use " <> parenss fx
_
-> text ""
noTypes :: [Exp a T.Name] -> [Exp a T.Name]
noTypes xs
= filter (isNothing.takeXWitness)
$ filter (isNothing.takeXType) xs
bare_name :: T.Name -> Doc
bare_name = ppr
bare_name_b :: Bind T.Name -> Doc
bare_name_b (BName n _) = bare_name n
bare_name_b (BNone _) = text "__NONE__"
bare_name_b _ = error "ddc-core-babel.bare_name: Only named vars allowed"
var_name_b :: Bind T.Name -> Doc
var_name_b b = text "$" <> bare_name_b b
var_name_u :: Bound T.Name -> Doc
var_name_u (UName n) = text "$" <> bare_name n
var_name_u (UIx _) = error "ddc-core-babel.var_name: Only named vars allowed"
var_name_u (UPrim n _) = sanitise_prim n
var_name_t :: String -> Doc
var_name_t n = text "$" <> text n
obj_field :: Doc -> Doc -> Doc
obj_field n m = text "$" <> n <> text "->" <> m
obj_field_tt :: String -> String -> Doc
obj_field_tt n m = obj_field (text n) (text m)
sanitise_prim :: T.Name -> Doc
sanitise_prim n
| T.NameLitBool True <- n
= text "true"
| T.NameLitBool False <- n
= text "false"
| T.NameLitNat i <- n
= text (show i)
| T.NameLitInt i <- n
= text (show i)
| T.NameLitSize i <- n
= text (show i)
| T.NameLitWord i _ <- n
= text (show i)
| T.NameLitFloat i _ <- n
= text (show i)
| T.NameLitTextLit t <- n
= text (show t)
| T.NamePrimArith p _ <- n
= text ("DDC::" ++ show p)
| T.NameLitUnboxed nn <- n
= sanitise_prim nn
| otherwise
= ppr n
string_of :: T.Name -> Doc
string_of n = text $ show $ show $ ppr n
parenss :: [Doc] -> Doc
parenss xs = encloseSep lparen rparen (comma <> space) xs
phpOfPrimOp :: T.Name -> [Doc] -> Doc
phpOfPrimOp op args
| Just (ty, s) <- getOp
= case (ty, args) of
(Infix, [l,r])
-> text "(" <> l <+> text s <+> r <> text ")"
(Prefix, [r])
-> text "(" <> text s <+> r <> text ")"
(Suffix, [l])
-> text "(" <> l <+> text s <> text ")"
_
-> fallback
| otherwise
= fallback
where
fallback
= text "DDC::apply"
<> parenss ((text "DDC::curry(" <> sanitise_prim op <> text ", "
<> sanitise_prim op <> text "_arity)") : args)
getOp
= go operators
go []
= Nothing
go ((o,t,s):os)
| o == op
= Just (t,s)
| otherwise
= go os
data OpType
= Infix
| Prefix
| Suffix
operators :: [(T.Name,OpType,String)]
operators
= lmap (flip T.NamePrimArith False) ariths
where
lmap f = map (\(n,o,s) -> (f n, o, s))
ariths
= [(T.PrimArithNeg, Prefix, "-")
,(T.PrimArithAdd, Infix, "+")
,(T.PrimArithSub, Infix, "-")
,(T.PrimArithMul, Infix, "*")
,(T.PrimArithDiv, Infix, "/")
,(T.PrimArithMod, Infix, "%")
,(T.PrimArithRem, Infix, "%")
,(T.PrimArithEq, Infix, "==")
,(T.PrimArithNeq, Infix, "!=")
,(T.PrimArithGt, Infix, ">")
,(T.PrimArithGe, Infix, ">=")
,(T.PrimArithLt, Infix, "<")
,(T.PrimArithLe, Infix, "<=")
,(T.PrimArithAnd, Infix, "&&")
,(T.PrimArithOr, Infix, "||")
]