git.iko.soy/jsaddle
on master help sign in
Add JSadddleHasCallStack
commit6357f1a7f953c362f0fb58c5802e9eb617e0e416 authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateTue 4 Apr 2017, 17:57 (10 years ago) parent2e1bdcf
4 files changed+52−5
compare with master
unifiedsplit
jsaddle-warp/jsaddle-warp.cabal+1−1 jsaddle/jsaddle.cabal+12 jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+21−2 jsaddle/src/Language/Javascript/JSaddle/Types.hs+18−2
jsaddle-warp/jsaddle-warp.cabal+1−1
@@ -36,7 +36,7 @@ library
3636 wai >=3.0.3.0 && <3.3,
3737 wai-websockets >=3.0.0.6 && <3.1,
3838 warp >=3.1.2 && <3.3,
39− websockets >=0.9.5.0 && <0.10
39+ websockets >=0.9.5.0 && <0.11
4040 exposed-modules:
4141 Language.Javascript.JSaddle.Warp
4242 build-depends:
jsaddle/jsaddle.cabal+12
@@ -19,6 +19,14 @@ source-repository head
1919 location: https://github.com/ghcjs/jsaddle
2020 subdir: jsaddle
2121
22+flag call-stacks
23+ description: Include HasCallStack constraint on calls unchecked calls
24+ default: False
25+
26+flag check-unchecked
27+ description: Fail unchecked calls when they are called (rather than when the result is evaluated)
28+ default: False
29+
2230library
2331
2432 if impl(ghcjs -any)
@@ -105,5 +113,9 @@ library
105113 default-language: Haskell2010
106114 hs-source-dirs: src
107115 ghc-options: -ferror-spans -Wall
116+ if flag(check-unchecked)
117+ cpp-options: -DCHECK_UNCHECKED
118+ if flag(call-stacks) || flag(check-unchecked)
119+ cpp-options: -DJSADDLE_HAS_CALL_STACK
108120
109121
jsaddle/src-ghc/GHCJS/Marshal/Internal.hs+21−2
@@ -1,4 +1,4 @@
1−{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
1+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,
22 TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,
33 LambdaCase
44 #-}
@@ -34,7 +34,7 @@ import qualified Data.JSString.Internal.Type as JSS
3434import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp)
3535import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO)
3636
37−import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap)
37+import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap, JSadddleHasCallStack)
3838import Language.Javascript.JSaddle.String (textToStr)
3939
4040data Purity = PureShared -- ^ conversion is pure even if the original value is shared
@@ -61,17 +61,36 @@ class ToJSVal a where
6161 default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal
6262 toJSVal = toJSVal_generic id
6363
64+fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a
65+fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing"
66+fromJustWithStack (Just x) = x
67+
6468class FromJSVal a where
6569 fromJSVal :: JSVal -> JSM (Maybe a)
6670
71+#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
72+ fromJSValUnchecked :: JSadddleHasCallStack => JSVal -> JSM a
73+#ifdef CHECK_UNCHECKED
74+ fromJSValUnchecked v = fromJSVal v >>= \case
75+ Nothing -> error "fromJSValUnchecked: fromJSVal result was Nothing"
76+ Just x -> return x
77+#else
78+ fromJSValUnchecked = fmap fromJustWithStack . fromJSVal
79+#endif
80+#else
6781 fromJSValUnchecked :: JSVal -> JSM a
6882 fromJSValUnchecked = fmap fromJust . fromJSVal
83+#endif
6984 {-# INLINE fromJSValUnchecked #-}
7085
7186 fromJSValListOf :: JSVal -> JSM (Maybe [a])
7287 fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array
7388
89+#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)
90+ fromJSValUncheckedListOf :: JSadddleHasCallStack => JSVal -> JSM [a]
91+#else
7492 fromJSValUncheckedListOf :: JSVal -> JSM [a]
93+#endif
7594 fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce
7695
7796 -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)
jsaddle/src/Language/Javascript/JSaddle/Types.hs+18−2
@@ -1,6 +1,5 @@
11{-# LANGUAGE CPP #-}
22#ifdef ghcjs_HOST_OS
3−{-# LANGUAGE ConstraintKinds #-}
43{-# OPTIONS_GHC -Wno-dodgy-exports #-}
54#else
65{-# LANGUAGE TypeFamilies #-}
@@ -8,11 +7,13 @@
87{-# LANGUAGE GeneralizedNewtypeDeriving #-}
98{-# LANGUAGE DeriveGeneric #-}
109{-# LANGUAGE DataKinds #-}
11−{-# LANGUAGE KindSignatures #-}
1210{-# LANGUAGE PolyKinds #-}
1311{-# LANGUAGE FlexibleContexts #-}
1412{-# LANGUAGE DefaultSignatures #-}
13+{-# LANGUAGE ImplicitParams #-}
1514#endif
15+{-# LANGUAGE ConstraintKinds #-}
16+{-# LANGUAGE KindSignatures #-}
1617-----------------------------------------------------------------------------
1718--
1819-- Module : Language.Javascript.JSaddle.Types
@@ -53,6 +54,9 @@ module Language.Javascript.JSaddle.Types (
5354 , Nullable(..)
5455 , JSCallAsFunction
5556
57+ -- * Debugging
58+ , JSadddleHasCallStack
59+
5660 -- * JavaScript Context Commands
5761#ifndef ghcjs_HOST_OS
5862 , MutabilityType(..)
@@ -100,6 +104,12 @@ import Data.Aeson
100104import GHC.Generics (Generic)
101105#endif
102106
107+#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)
108+import GHC.Stack (HasCallStack)
109+#else
110+import GHC.Exts (Constraint)
111+#endif
112+
103113-- | Identifies a JavaScript execution context.
104114-- When using GHCJS this is just '()' since their is only one context.
105115-- When using GHC it includes the functions JSaddle needs to communicate
@@ -384,5 +394,11 @@ instance ToJSON Results where
384394instance FromJSON Results
385395#endif
386396
397+-- | Like HasCallStack, but only when jsaddle cabal flag check-unchecked is set
398+#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)
399+type JSadddleHasCallStack = HasCallStack
400+#else
401+type JSadddleHasCallStack = (() :: Constraint)
402+#endif
387403
388404