diff options
Diffstat (limited to 'compiler/GHC/JS/Ppr.hs')
| -rw-r--r-- | compiler/GHC/JS/Ppr.hs | 189 |
1 files changed, 125 insertions, 64 deletions
diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs index 9315156eeb..5f3dd737e7 100644 --- a/compiler/GHC/JS/Ppr.hs +++ b/compiler/GHC/JS/Ppr.hs @@ -10,10 +10,46 @@ -- For Outputable instances for JS syntax {-# OPTIONS_GHC -Wno-orphans #-} --- | Pretty-printing JavaScript +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ppr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io> +-- Luite Stegeman <luite.stegeman@iohk.io> +-- Sylvain Henry <sylvain.henry@iohk.io> +-- Josh Meredith <josh.meredith@iohk.io> +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Ppr defines the code generation facilities for the JavaScript +-- backend. That is, this module exports a function from the JS backend IR +-- to JavaScript compliant concrete syntax that can readily be executed by +-- nodejs or called in a browser. +-- +-- * Design +-- +-- This module follows the architecture and style of the other backends in +-- GHC: it intances Outputable for the relevant types, creates a class that +-- describes a morphism from the IR domain to JavaScript concrete Syntax and +-- then generates that syntax on a case by case basis. +-- +-- * How to use +-- +-- The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record. +-- Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for +-- specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a +-- custom renderer ensures all @Ident@ generated by the linker optimization +-- pass are prefixed differently than the default. Use @renderJS@ to +-- generate JavaScript concrete syntax in the general case, suitable for +-- human consumption. +----------------------------------------------------------------------------- + module GHC.JS.Ppr ( renderJs - , renderJs' , renderPrefixJs , renderPrefixJs' , JsToDoc(..) @@ -21,9 +57,10 @@ module GHC.JS.Ppr , RenderJs(..) , jsToDoc , pprStringLit - , flattenBlocks , braceNest , hangBrace + , interSemi + , addSemi ) where @@ -49,9 +86,9 @@ instance Outputable JExpr where instance Outputable JVal where ppr = docToSDoc . renderJs - -($$$) :: Doc -> Doc -> Doc -x $$$ y = nest 2 $ x $+$ y +-------------------------------------------------------------------------------- +-- Top level API +-------------------------------------------------------------------------------- -- | Render a syntax tree as a pretty-printable document -- (simply showing the resultant doc produces a nice, @@ -84,26 +121,17 @@ renderPrefixJs = renderPrefixJs' defaultRenderJs renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc renderPrefixJs' r = jsToDocR r -braceNest :: Doc -> Doc -braceNest x = char '{' <+> nest 2 x $$ char '}' - --- | Hang with braces: --- --- hdr { --- body --- } -hangBrace :: Doc -> Doc -> Doc -hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] +-------------------------------------------------------------------------------- +-- Code Generator +-------------------------------------------------------------------------------- class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc -instance JsToDoc JStat where jsToDocR r = renderJsS r r -instance JsToDoc JExpr where jsToDocR r = renderJsE r r -instance JsToDoc JVal where jsToDocR r = renderJsV r r -instance JsToDoc Ident where jsToDocR r = renderJsI r r -instance JsToDoc [JExpr] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) -instance JsToDoc [JStat] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +instance JsToDoc [JStat] where jsToDocR r = vcat . map ((<> semi) . jsToDocR r) defRenderJsS :: RenderJs -> JStat -> Doc defRenderJsS r = \case @@ -120,12 +148,16 @@ defRenderJsS r = \case ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s where - printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss + printBS (BlockStat ss) = vcat $ interSemi $ map (jsToDocR r) ss printBS x = jsToDocR r x - interSemi [x] = [jsToDocR r x] - interSemi [] = [] - interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs + ForStat init p s1 sb -> hangBrace (text "for" <> forCond) (jsToDocR r sb) + where + forCond = parens $ hcat $ interSemi + [ jsToDocR r init + , jsToDocR r p + , parens (jsToDocR r s1) + ] ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) where txt | each = "for each" | otherwise = "for" @@ -134,12 +166,15 @@ defRenderJsS r = \case cases = vcat l' ReturnStat e -> text "return" <+> jsToDocR r e ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) + FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i + <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) + (jsToDocR r b) TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally where mbCatch | s1 == BlockStat [] = PP.empty | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) mbFinally | s2 == BlockStat [] = PP.empty | otherwise = hangBrace (text "finally") (jsToDocR r s2) - AssignStat i x -> case x of + AssignStat i op x -> case x of -- special treatment for functions, otherwise there is too much left padding -- (more than the length of the expression assigned to). E.g. -- @@ -148,19 +183,13 @@ defRenderJsS r = \case -- ... -- }); -- - ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] - _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + ValExpr (JFunc is b) -> sep [jsToDocR r i <+> ftext (aOpText op) <+> text " function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] + _ -> jsToDocR r i <+> ftext (aOpText op) <+> jsToDocR r x UOpStat op x | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x | isPre op -> ftext (uOpText op) <> optParens r x | otherwise -> optParens r x <> ftext (uOpText op) - BlockStat xs -> jsToDocR r (flattenBlocks xs) - -flattenBlocks :: [JStat] -> [JStat] -flattenBlocks = \case - BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys - y:ys -> y : flattenBlocks ys - [] -> [] + BlockStat xs -> jsToDocR r xs optParens :: RenderJs -> JExpr -> Doc optParens r x = case x of @@ -204,33 +233,12 @@ defRenderJsV r = \case defRenderJsI :: RenderJs -> Ident -> Doc defRenderJsI _ (TxtI t) = ftext t +aOpText :: AOp -> FastString +aOpText = \case + AssignOp -> "=" + AddAssignOp -> "+=" + SubAssignOp -> "-=" -pprStringLit :: FastString -> Doc -pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] - -encodeJson :: FastString -> Doc -encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) - -encodeJsonChar :: Char -> Doc -encodeJsonChar = \case - '/' -> text "\\/" - '\b' -> text "\\b" - '\f' -> text "\\f" - '\n' -> text "\\n" - '\r' -> text "\\r" - '\t' -> text "\\t" - '"' -> text "\\\"" - '\\' -> text "\\\\" - c - | not (isControl c) && ord c <= 127 -> char c - | ord c <= 0xff -> hexxs "\\x" 2 (ord c) - | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) - | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair - in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> - hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) - where hexxs prefix pad cp = - let h = showHex cp "" - in text (prefix ++ replicate (pad - length h) '0' ++ h) uOpText :: UOp -> FastString uOpText = \case @@ -289,3 +297,56 @@ isAlphaOp = \case YieldOp -> True VoidOp -> True _ -> False + +pprStringLit :: FastString -> Doc +pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +encodeJson :: FastString -> Doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: Char -> Doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +interSemi :: [Doc] -> [Doc] +interSemi [] = [] +interSemi [s] = [s] +interSemi (x:xs) = x <> text ";" : interSemi xs + +addSemi :: Doc -> Doc +addSemi x = x <> text ";" + +-- | Hang with braces: +-- +-- hdr { +-- body +-- } +hangBrace :: Doc -> Doc -> Doc +hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] + +($$$) :: Doc -> Doc -> Doc +x $$$ y = nest 2 $ x $+$ y |