diff options
Diffstat (limited to 'compiler/GHC/JS/Syntax.hs')
| -rw-r--r-- | compiler/GHC/JS/Syntax.hs | 275 |
1 files changed, 119 insertions, 156 deletions
diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs index 66067ced9e..0b8a6c05b2 100644 --- a/compiler/GHC/JS/Syntax.hs +++ b/compiler/GHC/JS/Syntax.hs @@ -48,92 +48,60 @@ -- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides -- helper functions that use the deeply embedded DSL defined in this module -- to provide some of the benefits of a shallow embedding. +-- ----------------------------------------------------------------------------- + module GHC.JS.Syntax ( -- * Deeply embedded JS datatypes JStat(..) , JExpr(..) , JVal(..) - , JOp(..) - , JUOp(..) + , Op(..) + , UOp(..) , Ident(..) - , identFS - , JsLabel + , JLabel -- * pattern synonyms over JS operators - , pattern New - , pattern Not - , pattern Negate - , pattern Add - , pattern Sub - , pattern Mul - , pattern Div - , pattern Mod - , pattern BOr - , pattern BAnd - , pattern BXor - , pattern BNot - , pattern LOr - , pattern LAnd - , pattern Int - , pattern String - , pattern PreInc - , pattern PostInc - , pattern PreDec - , pattern PostDec - -- * Ident supply - , IdentSupply(..) - , newIdentSupply - , pseudoSaturate + , pattern JNew + , pattern JNot + , pattern JNegate + , pattern JAdd + , pattern JSub + , pattern JMul + , pattern JDiv + , pattern JMod + , pattern JBOr + , pattern JBAnd + , pattern JBXor + , pattern JBNot + , pattern JLOr + , pattern JLAnd + , pattern SatInt + , pattern JString + , pattern JPreInc + , pattern JPostInc + , pattern JPreDec + , pattern JPostDec -- * Utility , SaneDouble(..) + , jassignAll + , jassignAllEqual + , jvar ) where import GHC.Prelude +import GHC.JS.Unsat.Syntax (Ident(..)) +import GHC.Data.FastString +import GHC.Types.Unique.Map +import GHC.Utils.Misc + import Control.DeepSeq -import Data.Function import Data.Data -import Data.Word import qualified Data.Semigroup as Semigroup import GHC.Generics -import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Types.Unique -import GHC.Types.Unique.Map - --- | A supply of identifiers, possibly empty -newtype IdentSupply a - = IS {runIdentSupply :: State [Ident] a} - deriving Typeable - -instance NFData (IdentSupply a) where rnf IS{} = () - -inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b -inIdentSupply f x = IS $ f (runIdentSupply x) - -instance Functor IdentSupply where - fmap f x = inIdentSupply (fmap f) x - -newIdentSupply :: Maybe FastString -> [Ident] -newIdentSupply Nothing = newIdentSupply (Just "jmId") -newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) - | x <- [(0::Word64)..] - ] - --- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers. -pseudoSaturate :: IdentSupply a -> a -pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>") - -instance Eq a => Eq (IdentSupply a) where - (==) = (==) `on` pseudoSaturate -instance Ord a => Ord (IdentSupply a) where - compare = compare `on` pseudoSaturate -instance Show a => Show (IdentSupply a) where - show x = "(" ++ show (pseudoSaturate x) ++ ")" - -------------------------------------------------------------------------------- -- Statements @@ -142,26 +110,25 @@ instance Show a => Show (IdentSupply a) where -- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) -- for details data JStat - = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] - | ReturnStat JExpr -- ^ Return - | IfStat JExpr JStat JStat -- ^ If - | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True - | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If + | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch - | TryStat JStat Ident JStat JStat -- ^ Try - | BlockStat [JStat] -- ^ Blocks - | ApplStat JExpr [JExpr] -- ^ Application - | UOpStat JUOp JExpr -- ^ Unary operators - | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ - | UnsatBlock (IdentSupply JStat) -- ^ /Unsaturated/ blocks see 'pseudoSaturate' - | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic - | BreakStat (Maybe JsLabel) -- ^ Break - | ContinueStat (Maybe JsLabel) -- ^ Continue + | TryStat JStat Ident JStat JStat -- ^ Try + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat UOp JExpr -- ^ Unary operators + | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ + | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JLabel) -- ^ Break + | ContinueStat (Maybe JLabel) -- ^ Continue deriving (Eq, Typeable, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of -- course 'LabelStat' -type JsLabel = LexicalFastString +type JLabel = LexicalFastString instance Semigroup JStat where (<>) = appendJStat @@ -178,10 +145,10 @@ appendJStat :: JStat -> JStat -> JStat appendJStat mx my = case (mx,my) of (BlockStat [] , y ) -> y (x , BlockStat []) -> x - (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys - (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] - (xs , BlockStat ys) -> BlockStat $ xs : ys - (xs , ys ) -> BlockStat [xs,ys] + (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys + (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $! xs : ys + (xs , ys ) -> BlockStat [xs,ys] -------------------------------------------------------------------------------- @@ -189,16 +156,13 @@ appendJStat mx my = case (mx,my) of -------------------------------------------------------------------------------- -- | JavaScript Expressions data JExpr - = ValExpr JVal -- ^ All values are trivially expressions - | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' - | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' - -- pattern synonyms - | UOpExpr JUOp JExpr -- ^ Unary Expressions - | IfExpr JExpr JExpr JExpr -- ^ If-expression + | InfixExpr Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms + | UOpExpr UOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression | ApplExpr JExpr [JExpr] -- ^ Application - | UnsatExpr (IdentSupply JExpr) -- ^ An /Unsaturated/ expression. - -- See 'pseudoSaturate' deriving (Eq, Typeable, Generic) -- * Useful pattern synonyms to ease programming with the deeply embedded JS @@ -207,110 +171,110 @@ data JExpr -- and Integer literals. -- | pattern synonym for a unary operator new -pattern New :: JExpr -> JExpr -pattern New x = UOpExpr NewOp x +pattern JNew :: JExpr -> JExpr +pattern JNew x = UOpExpr NewOp x -- | pattern synonym for prefix increment @++x@ -pattern PreInc :: JExpr -> JExpr -pattern PreInc x = UOpExpr PreIncOp x +pattern JPreInc :: JExpr -> JExpr +pattern JPreInc x = UOpExpr PreIncOp x -- | pattern synonym for postfix increment @x++@ -pattern PostInc :: JExpr -> JExpr -pattern PostInc x = UOpExpr PostIncOp x +pattern JPostInc :: JExpr -> JExpr +pattern JPostInc x = UOpExpr PostIncOp x -- | pattern synonym for prefix decrement @--x@ -pattern PreDec :: JExpr -> JExpr -pattern PreDec x = UOpExpr PreDecOp x +pattern JPreDec :: JExpr -> JExpr +pattern JPreDec x = UOpExpr PreDecOp x -- | pattern synonym for postfix decrement @--x@ -pattern PostDec :: JExpr -> JExpr -pattern PostDec x = UOpExpr PostDecOp x +pattern JPostDec :: JExpr -> JExpr +pattern JPostDec x = UOpExpr PostDecOp x -- | pattern synonym for logical not @!@ -pattern Not :: JExpr -> JExpr -pattern Not x = UOpExpr NotOp x +pattern JNot :: JExpr -> JExpr +pattern JNot x = UOpExpr NotOp x -- | pattern synonym for unary negation @-@ -pattern Negate :: JExpr -> JExpr -pattern Negate x = UOpExpr NegOp x +pattern JNegate :: JExpr -> JExpr +pattern JNegate x = UOpExpr NegOp x -- | pattern synonym for addition @+@ -pattern Add :: JExpr -> JExpr -> JExpr -pattern Add x y = InfixExpr AddOp x y +pattern JAdd :: JExpr -> JExpr -> JExpr +pattern JAdd x y = InfixExpr AddOp x y -- | pattern synonym for subtraction @-@ -pattern Sub :: JExpr -> JExpr -> JExpr -pattern Sub x y = InfixExpr SubOp x y +pattern JSub :: JExpr -> JExpr -> JExpr +pattern JSub x y = InfixExpr SubOp x y -- | pattern synonym for multiplication @*@ -pattern Mul :: JExpr -> JExpr -> JExpr -pattern Mul x y = InfixExpr MulOp x y +pattern JMul :: JExpr -> JExpr -> JExpr +pattern JMul x y = InfixExpr MulOp x y -- | pattern synonym for division @*@ -pattern Div :: JExpr -> JExpr -> JExpr -pattern Div x y = InfixExpr DivOp x y +pattern JDiv :: JExpr -> JExpr -> JExpr +pattern JDiv x y = InfixExpr DivOp x y -- | pattern synonym for remainder @%@ -pattern Mod :: JExpr -> JExpr -> JExpr -pattern Mod x y = InfixExpr ModOp x y +pattern JMod :: JExpr -> JExpr -> JExpr +pattern JMod x y = InfixExpr ModOp x y -- | pattern synonym for Bitwise Or @|@ -pattern BOr :: JExpr -> JExpr -> JExpr -pattern BOr x y = InfixExpr BOrOp x y +pattern JBOr :: JExpr -> JExpr -> JExpr +pattern JBOr x y = InfixExpr BOrOp x y -- | pattern synonym for Bitwise And @&@ -pattern BAnd :: JExpr -> JExpr -> JExpr -pattern BAnd x y = InfixExpr BAndOp x y +pattern JBAnd :: JExpr -> JExpr -> JExpr +pattern JBAnd x y = InfixExpr BAndOp x y -- | pattern synonym for Bitwise XOr @^@ -pattern BXor :: JExpr -> JExpr -> JExpr -pattern BXor x y = InfixExpr BXorOp x y +pattern JBXor :: JExpr -> JExpr -> JExpr +pattern JBXor x y = InfixExpr BXorOp x y -- | pattern synonym for Bitwise Not @~@ -pattern BNot :: JExpr -> JExpr -pattern BNot x = UOpExpr BNotOp x +pattern JBNot :: JExpr -> JExpr +pattern JBNot x = UOpExpr BNotOp x -- | pattern synonym for logical Or @||@ -pattern LOr :: JExpr -> JExpr -> JExpr -pattern LOr x y = InfixExpr LOrOp x y +pattern JLOr :: JExpr -> JExpr -> JExpr +pattern JLOr x y = InfixExpr LOrOp x y -- | pattern synonym for logical And @&&@ -pattern LAnd :: JExpr -> JExpr -> JExpr -pattern LAnd x y = InfixExpr LAndOp x y - +pattern JLAnd :: JExpr -> JExpr -> JExpr +pattern JLAnd x y = InfixExpr LAndOp x y -- | pattern synonym to create integer values -pattern Int :: Integer -> JExpr -pattern Int x = ValExpr (JInt x) +pattern SatInt :: Integer -> JExpr +pattern SatInt x = ValExpr (JInt x) -- | pattern synonym to create string values -pattern String :: FastString -> JExpr -pattern String x = ValExpr (JStr x) +pattern JString :: FastString -> JExpr +pattern JString x = ValExpr (JStr x) -------------------------------------------------------------------------------- -- Values -------------------------------------------------------------------------------- + -- | JavaScript values data JVal - = JVar Ident -- ^ A variable reference - | JList [JExpr] -- ^ A JavaScript list, or what JS - -- calls an Array - | JDouble SaneDouble -- ^ A Double - | JInt Integer -- ^ A BigInt - | JStr FastString -- ^ A String - | JRegEx FastString -- ^ A Regex + = JVar Ident -- ^ A variable reference + | JList [JExpr] -- ^ A JavaScript list, or what JS calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ - | JFunc [Ident] JStat -- ^ A function - | UnsatVal (IdentSupply JVal) -- ^ An /Unsaturated/ value, see 'pseudoSaturate' + | JFunc [Ident] JStat -- ^ A function deriving (Eq, Typeable, Generic) + -------------------------------------------------------------------------------- -- Operators -------------------------------------------------------------------------------- + -- | JS Binary Operators. We do not deeply embed the comma operator and the -- assignment operators -data JOp +data Op = EqOp -- ^ Equality: `==` | StrictEqOp -- ^ Strict Equality: `===` | NeqOp -- ^ InEquality: `!=` @@ -336,10 +300,10 @@ data JOp | InOp -- ^ @in@ deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) -instance NFData JOp +instance NFData Op -- | JS Unary Operators -data JUOp +data UOp = NotOp -- ^ Logical Not: @!@ | BNotOp -- ^ Bitwise Not: @~@ | NegOp -- ^ Negation: @-@ @@ -355,7 +319,7 @@ data JUOp | PostDecOp -- ^ Postfix Decrement: @x--@ deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) -instance NFData JUOp +instance NFData UOp -- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' -- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on @@ -376,17 +340,16 @@ instance Ord SaneDouble where instance Show SaneDouble where show (SaneDouble x) = show x - -------------------------------------------------------------------------------- --- Identifiers +-- Helper Functions -------------------------------------------------------------------------------- --- We use FastString for identifiers in JS backend --- | A newtype wrapper around 'FastString' for JS identifiers. -newtype Ident = TxtI { itxt :: FastString } - deriving stock (Show, Eq) - deriving newtype (Uniquable) +jassignAllEqual :: [JExpr] -> [JExpr] -> JStat +jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" AssignStat xs ys) + +jassignAll :: [JExpr] -> [JExpr] -> JStat +jassignAll xs ys = mconcat (zipWith AssignStat xs ys) + +jvar :: FastString -> JExpr +jvar = ValExpr . JVar . TxtI -identFS :: Ident -> FastString -identFS = \case - TxtI fs -> fs |