diff options
Diffstat (limited to 'compiler/GHC/JS/Transform.hs')
| -rw-r--r-- | compiler/GHC/JS/Transform.hs | 138 |
1 files changed, 60 insertions, 78 deletions
diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs index 9c45ebdd57..3415b04b86 100644 --- a/compiler/GHC/JS/Transform.hs +++ b/compiler/GHC/JS/Transform.hs @@ -6,13 +6,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform ( identsS , identsV , identsE -- * Saturation - , jsSaturate + , satJStat + , satJExpr -- * Generic traversal (via compos) , JMacro(..) , JMGadt(..) @@ -21,8 +23,6 @@ module GHC.JS.Transform , composOpM , composOpM_ , composOpFold - , satJExpr - , satJStat ) where @@ -33,11 +33,12 @@ import GHC.JS.Unsat.Syntax import Data.Functor.Identity import Control.Monad -import Control.Arrow ((***)) +import Data.List (sortBy) import GHC.Data.FastString import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map +import GHC.Types.Unique.FM {-# INLINE identsS #-} @@ -205,69 +206,62 @@ jmcompos ret app f' v = -- | Given an optional prefix, fills in all free variable names with a supply -- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) - -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) +satJStat :: Maybe FastString -> JStat -> Sat.JStat +satJStat str x = evalState (jsSaturateS x) (newIdentSupply str) + +satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr +satJExpr str x = evalState (jsSaturateE x) (newIdentSupply str) + +jsSaturateS :: JStat -> State [Ident] Sat.JStat +jsSaturateS = \case + DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs + ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e + IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e + WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e + ForStat init p step body -> Sat.ForStat <$> jsSaturateS init <*> jsSaturateE p + <*> jsSaturateS step <*> jsSaturateS body + ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body + SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct + <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps + <*> jsSaturateS def + TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f + BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs + ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand + UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand + AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> pure Sat.AssignOp <*> jsSaturateE rhs + LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt + BreakStat m_l -> return $ Sat.BreakStat $! m_l + ContinueStat m_l -> return $ Sat.ContinueStat $! m_l + FuncStat i args body -> Sat.FuncStat i args <$> jsSaturateS body + UnsatBlock us -> jsSaturateS =<< runIdentSupply us + +jsSaturateE :: JExpr -> State [Ident] Sat.JExpr +jsSaturateE = \case + ValExpr v -> Sat.ValExpr <$> jsSaturateV v + SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i + IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i + InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r + UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r + IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e + ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands + UnsatExpr us -> jsSaturateE =<< runIdentSupply us + +jsSaturateV :: JVal -> State [Ident] Sat.JVal +jsSaturateV = \case + JVar i -> return $ Sat.JVar i + JList xs -> Sat.JList <$> mapM jsSaturateE xs + JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) + JInt i -> return $ Sat.JInt i + JStr s -> return $ Sat.JStr s + JRegEx f -> return $ Sat.JRegEx f + JHash m -> Sat.JHash <$> mapUniqMapM satHash m where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v - - --------------------------------------------------------------------------------- --- Translation --- --------------------------------------------------------------------------------- -satJStat :: JStat -> Sat.JStat -satJStat = witness . proof - where proof = jsSaturate Nothing - - -- This is an Applicative but we can't use it because no type variables :( - witness :: JStat -> Sat.JStat - witness (DeclStat i rhs) = Sat.DeclStat i (fmap satJExpr rhs) - witness (ReturnStat e) = Sat.ReturnStat (satJExpr e) - witness (IfStat c t e) = Sat.IfStat (satJExpr c) (witness t) (witness e) - witness (WhileStat is_do c e) = Sat.WhileStat is_do (satJExpr c) (witness e) - witness (ForStat init p step body) = Sat.ForStat - (witness init) (satJExpr p) - (witness step) (witness body) - witness (ForInStat is_each i iter body) = Sat.ForInStat is_each i - (satJExpr iter) - (witness body) - witness (SwitchStat struct ps def) = Sat.SwitchStat - (satJExpr struct) - (map (satJExpr *** witness) ps) - (witness def) - witness (TryStat t i c f) = Sat.TryStat (witness t) i (witness c) (witness f) - witness (BlockStat bs) = Sat.BlockStat $! fmap witness bs - witness (ApplStat rator rand) = Sat.ApplStat (satJExpr rator) (satJExpr <$> rand) - witness (UOpStat rator rand) = Sat.UOpStat (satJUOp rator) (satJExpr rand) - witness (AssignStat lhs rhs) = Sat.AssignStat (satJExpr lhs) Sat.AssignOp (satJExpr rhs) - witness (LabelStat lbl stmt) = Sat.LabelStat lbl (witness stmt) - witness (BreakStat Nothing) = Sat.BreakStat Nothing - witness (BreakStat (Just l)) = Sat.BreakStat $! Just l - witness (ContinueStat Nothing) = Sat.ContinueStat Nothing - witness (ContinueStat (Just l)) = Sat.ContinueStat $! Just l - witness (FuncStat i args body) = Sat.FuncStat i args (witness body) - witness UnsatBlock{} = error "satJStat: discovered an Unsat...impossibly" - - -satJExpr :: JExpr -> Sat.JExpr -satJExpr = go - where - go (ValExpr v) = Sat.ValExpr (satJVal v) - go (SelExpr obj i) = Sat.SelExpr (satJExpr obj) i - go (IdxExpr o i) = Sat.IdxExpr (satJExpr o) (satJExpr i) - go (InfixExpr op l r) = Sat.InfixExpr (satJOp op) (satJExpr l) (satJExpr r) - go (UOpExpr op r) = Sat.UOpExpr (satJUOp op) (satJExpr r) - go (IfExpr c t e) = Sat.IfExpr (satJExpr c) (satJExpr t) (satJExpr e) - go (ApplExpr rator rands) = Sat.ApplExpr (satJExpr rator) (satJExpr <$> rands) - go UnsatExpr{} = error "satJExpr: discovered an Unsat...impossibly" + satHash (i, x) = (i,) . (i,) <$> jsSaturateE x + compareHash (i,_) (j,_) = lexicalCompareFS i j + -- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided + mapUniqMapM f (UniqMap m) = UniqMap . listToUFM <$> (mapM f . sortBy compareHash $ nonDetEltsUFM m) + JFunc args body -> Sat.JFunc args <$> jsSaturateS body + UnsatVal us -> jsSaturateV =<< runIdentSupply us satJOp :: JOp -> Sat.Op satJOp = go @@ -313,15 +307,3 @@ satJUOp = go go PreDecOp = Sat.PreDecOp go PostDecOp = Sat.PostDecOp -satJVal :: JVal -> Sat.JVal -satJVal = go - where - go (JVar i) = Sat.JVar i - go (JList xs) = Sat.JList (satJExpr <$> xs) - go (JDouble d) = Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) - go (JInt i) = Sat.JInt i - go (JStr f) = Sat.JStr f - go (JRegEx f) = Sat.JRegEx f - go (JHash m) = Sat.JHash (satJExpr <$> m) - go (JFunc args body) = Sat.JFunc args (satJStat body) - go UnsatVal{} = error "jvalToSatVar: discovered an Sat...impossibly" |