module Language.Sunroof.JavaScript
( Expr, ExprE(..), E(..)
, Id, Stmt(..), Type(..)
, Rhs(..)
, showExpr, showStmt
, operator, binOp, uniOp
, literal
, scopeForEffect
) where
import Data.List ( intercalate )
import Data.Reify ( MuRef(..) )
import Control.Applicative ( Applicative, pure, (<$>), (<*>))
import Data.Traversable ( Traversable(..) )
import Data.Foldable ( Foldable(..) )
import Data.Monoid ( Monoid(..) )
import Data.Char ( isAlpha, isAlphaNum )
type Id = String
type Expr = E ExprE
data ExprE = ExprE Expr deriving Show
data E expr = Lit String
| Var Id
| Dot expr expr Type
| Apply expr [expr]
| Function [Id] [Stmt]
deriving Show
instance MuRef ExprE where
type DeRef ExprE = E
mapDeRef f (ExprE e) = traverse f e
instance Traversable E where
traverse _ (Lit s) = pure (Lit s)
traverse _ (Var s) = pure (Var s)
traverse f (Dot o n a) = Dot <$> f o <*> f n <*> pure a
traverse f (Apply s xs) = Apply <$> f s <*> traverse f xs
traverse _ (Function nms stmts) = pure (Function nms stmts)
instance Foldable E where
foldMap _ (Lit _) = mempty
foldMap _ (Var _) = mempty
foldMap f (Dot o n _) = f o `mappend` f n
foldMap f (Apply o xs) = f o `mappend` foldMap f xs
foldMap _ (Function _nms _stmts) = mempty
instance Functor E where
fmap _ (Lit s) = Lit s
fmap _ (Var s) = Var s
fmap f (Dot o n a) = Dot (f o) (f n) a
fmap f (Apply s xs) = Apply (f s) (map f xs)
fmap _ (Function nms stmts) = Function nms stmts
showExpr :: Bool -> Expr -> String
showExpr _ (Lit a) = a
showExpr _ (Var v) = v
showExpr b e = p $ case e of
(Apply (ExprE (Var "?:")) [ExprE a,ExprE x,ExprE y]) -> showExpr True a ++ "?" ++ showExpr True x ++ ":" ++ showExpr True y
(Apply (ExprE (Var op)) [ExprE x,ExprE y]) | not (any isAlpha op) -> showExpr True x ++ op ++ showExpr True y
(Apply (ExprE (Var "!")) [ExprE ex]) -> "!" ++ showExpr True ex
(Apply (ExprE (Lit op)) args) | isNewConstructor op -> op ++ showArgs args
(Apply (ExprE fn) args) -> showFun fn args
(Dot (ExprE a) (ExprE x) Base) -> showIdx a x
(Dot (ExprE a) (ExprE x) (Fun xs _)) ->
"function(" ++ intercalate "," args ++ ") { return (" ++
showIdx a x ++ ")(" ++ intercalate "," args ++ "); }"
where args = [ "a" ++ show i | i <- take (length xs) ([0..] :: [Int])]
(Dot (ExprE _a) (ExprE _x) Unit) ->
error "Dot pattern on unit type. Don't know what to do."
(Function args body) ->
"function" ++
"(" ++ intercalate "," args ++ ") {\n" ++
indent 2 (unlines (map showStmt body)) ++
"}"
_ -> error "should never happen"
where
p txt = if b then "(" ++ txt ++ ")" else txt
showIdx :: Expr -> Expr -> String
showIdx a (Lit x) | Just n <- isGoodSelectName x
= showExpr True a ++ "." ++ n
showIdx a ix = showExpr True a ++ "[" ++ showExpr False ix ++ "]"
showArgs :: [ExprE] -> String
showArgs args = "(" ++ intercalate "," (map (\ (ExprE e') -> showExpr False e') args) ++ ")"
showFun :: Expr -> [ExprE] -> String
showFun e args = case e of
(Dot (ExprE a) (ExprE (Lit x)) _)
| Just n <- isGoodSelectName x -> showExpr True a ++ "." ++ n ++ showArgs args
(Dot (ExprE a) (ExprE x) _) -> "(" ++ showIdx a x ++ ")" ++ showArgs args
_ -> showExpr True e ++ showArgs args
isIdentifier :: Id -> Bool
isIdentifier x | not (null x) = isAlpha (head x) && all isAlphaNum (drop 1 x)
isIdentifier _ = False
isNewConstructor :: Id -> Bool
isNewConstructor x = take 4 x == "new " && isIdentifier (drop 4 x)
isGoodSelectName :: Id -> Maybe Id
isGoodSelectName xs
| length xs < 2 = Nothing
| head xs == '"' &&
last xs == '"' &&
all isAlpha xs' = return xs'
| otherwise = Nothing
where
xs' = tail (init xs)
operator :: Id -> [Expr] -> Expr
operator n ps = Apply (ExprE $ Var n) (fmap ExprE ps)
binOp :: String -> Expr -> Expr -> E ExprE
binOp o e1 e2 = operator o [e1, e2]
uniOp :: String -> Expr -> E ExprE
uniOp o e = operator o [e]
literal :: String -> Expr
literal = Lit
indent :: Int -> String -> String
indent n = unlines . map (take n (cycle " ") ++) . lines
scopeForEffect :: [Stmt] -> Expr
scopeForEffect stmts = Apply (ExprE $ Function [] stmts) []
data Rhs = VarRhs Id
| DotRhs Expr Expr
showRhs :: Rhs -> String
showRhs (VarRhs var) = "var " ++ var
showRhs (DotRhs e1 e2) = showIdx e1 e2
data Stmt = AssignStmt Rhs Expr
| DeleteStmt Expr
| ExprStmt Expr
| ReturnStmt Expr
| IfStmt Expr [Stmt] [Stmt]
| WhileStmt Expr [Stmt]
| CommentStmt String
instance Show Stmt where
show = showStmt
showStmt :: Stmt -> String
showStmt (AssignStmt e1 e2) = showRhs e1 ++ " = " ++ showExpr False e2 ++ ";"
showStmt (DeleteStmt e) = "delete " ++ showExpr False e ++ ";"
showStmt (ExprStmt e) = showExpr False e ++ ";"
showStmt (ReturnStmt e) = "return " ++ showExpr False e ++ ";"
showStmt (IfStmt i t e) = "if(" ++ showExpr False i ++ "){\n"
++ indent 2 (unlines (map showStmt t))
++ "} else {\n"
++ indent 2 (unlines (map showStmt e))
++ "}"
showStmt (WhileStmt b stmts) = "while(" ++ showExpr False b ++ "){\n"
++ indent 2 (unlines (map showStmt stmts))
++ "}"
showStmt (CommentStmt msg) = "/* " ++ msg ++ " */"
data Type = Base
| Unit
| Fun [Type] Type
deriving (Eq,Ord)
instance Show Type where
show Base = "*"
show Unit = "()"
show (Fun xs t) = show xs ++ " -> " ++ show t
data Doc = Text String
| Indent Int Doc
| Sep [Doc]
text :: String -> Doc
text = Text
sep :: [Doc] -> Doc
sep = Sep
pretty :: Doc -> String
pretty (Text txt) = txt
pretty (Sep docs) = unlines $ map pretty docs
pretty (Indent n doc) = unlines $ map (take n (cycle " ") ++) $ lines $ pretty doc