From 5e6bb66fc8ef903a66fb794cb4c4e4e08935af90 Mon Sep 17 00:00:00 2001 From: Anupam Jain Date: Mon, 15 Apr 2019 15:06:32 +0530 Subject: [PATCH] Remove unsafeCoerce hacks! Fixes https://github.com/ajnsit/purescript-concur/issues/15 --- package.json | 2 +- src/Concur/Core/Types.purs | 2 +- src/Concur/React.purs | 8 +++----- src/Control/Cofree.purs | 11 ++++++----- src/Control/ShiftMap.purs | 36 ++++++++++++++++++++---------------- 5 files changed, 31 insertions(+), 28 deletions(-) diff --git a/package.json b/package.json index 2702f82..55d871c 100644 --- a/package.json +++ b/package.json @@ -12,7 +12,7 @@ "scripts": { "test": "echo \"Error: no test specified\" && exit 1", "clean": "rimraf output && rimraf .pulp-cache && rimraf temp", - "build": "pulp build -- --censor-lib --strict", + "build": "pulp build -I examples -- --censor-lib --strict", "dev": "rimraf temp && bower install && pulp build -I examples && parcel build index.html", "prod": "rimraf temp && bower install && mkdir temp && pulp build --to temp/index.prod.js -I examples && java -jar closure-compiler/closure-compiler-v20190301.jar --js temp/index.prod.js --js_output_file temp/index.prod.minified.js && cp index.prod.html temp && parcel build temp/index.prod.html && rimraf temp", "prod1": "rimraf temp && bower install && mkdir temp && pulp build --to temp/index.prod.js -I examples && java -jar closure-compiler/closure-compiler-v20190301.jar --compilation_level ADVANCED_OPTIMIZATIONS --js temp/index.prod.js --js_output_file temp/index.prod.minified.js && cp index.prod.html temp && parcel build temp/index.prod.html && rimraf temp", diff --git a/src/Concur/Core/Types.purs b/src/Concur/Core/Types.purs index 59b5f3f..a2b645d 100644 --- a/src/Concur/Core/Types.purs +++ b/src/Concur/Core/Types.purs @@ -68,7 +68,7 @@ instance widgetMonad :: Monad (Widget v) derive newtype instance widgetMonadRec :: MonadRec (Widget v) instance widgetShiftMap :: ShiftMap (Widget v) (Widget v) where - shiftMap = identity + shiftMap f = f identity -- Util flipEither :: diff --git a/src/Concur/React.purs b/src/Concur/React.purs index 4b8c6b5..ca356d5 100644 --- a/src/Concur/React.purs +++ b/src/Concur/React.purs @@ -14,7 +14,6 @@ import Data.Tuple (Tuple(..)) import Effect.Console (log) import React as R import React.DOM.Props as P -import Unsafe.Coerce (unsafeCoerce) type HTML = Array R.ReactElement @@ -28,7 +27,6 @@ type NodeTag type LeafTag = Array P.Props -> R.ReactElement --- BIG HACK! We use UnsafeCoerce to allow this to typecheck. This MIGHT cause RUNTIME errors! Verify! -- | Wrap a widget with a node that can have eventHandlers attached el :: forall m a. @@ -37,8 +35,8 @@ el :: Array (Props a) -> m a -> m a -el e props = shiftMap (wrapViewEvent \h v -> - [e (map (mkProp h) (unsafeCoerce props)) v]) +el e props = shiftMap (\f w -> wrapViewEvent (\h v -> + [e (map (mkProp h <<< map f) props) v]) w) -- | Promote a leaf node to a widget elLeaf :: @@ -48,7 +46,7 @@ elLeaf :: Array (Props a) -> m a elLeaf e props = liftWidget $ mkLeafWidget \h -> - [e (map (mkProp h) (unsafeCoerce props))] + [e (map (mkProp h) props)] -- | Wrap some widgets with a node that can have eventHandlers attached el' :: diff --git a/src/Control/Cofree.purs b/src/Control/Cofree.purs index b8c2cc7..dacba2c 100644 --- a/src/Control/Cofree.purs +++ b/src/Control/Cofree.purs @@ -21,19 +21,18 @@ import Concur.Core.Types (Widget) import Control.Alternative (class Alternative, (<|>), empty) import Control.Comonad (class Comonad, extract) import Control.Extend (class Extend) +import Control.Lazy as Z import Control.Monad.Free (Free, runFreeM) import Control.Monad.Rec.Class (class MonadRec) import Control.Monad.State (State, StateT(..), runState, runStateT, state) import Control.ShiftMap (class ShiftMap) import Data.Eq (class Eq1, eq1) import Data.Foldable (class Foldable, foldr, foldl, foldMap) -import Data.Lazy (Lazy, force, defer) +import Data.Lazy (Lazy, defer, force) import Data.Ord (class Ord1, compare1) import Data.Traversable (class Traversable, traverse) import Data.Tuple (Tuple(..), fst, snd) -import Control.Lazy as Z - -- | The `Cofree` `Comonad` for a functor. -- | -- | A value of type `Cofree f a` consists of an `f`-branching @@ -221,5 +220,7 @@ instance lazyCofree :: Z.Lazy (Cofree f a) where let (Cofree t) = k unit in force t) -instance shiftMapCofree :: ShiftMap (Widget v) (Cofree (Widget v)) where - shiftMap = hoistCofree +instance shiftMapCofree :: Monoid v => ShiftMap (Widget v) (Cofree (Widget v)) where + shiftMap f (Cofree l) = deferCofree \_ -> + let Tuple a rest = force l + in Tuple a (f pure rest) diff --git a/src/Control/ShiftMap.purs b/src/Control/ShiftMap.purs index 6b8dd4a..3356ce5 100644 --- a/src/Control/ShiftMap.purs +++ b/src/Control/ShiftMap.purs @@ -2,28 +2,32 @@ module Control.ShiftMap where import Prelude -import Control.Monad.Except (ExceptT, mapExceptT) -import Control.Monad.RWS (RWST, mapRWST) -import Control.Monad.Reader (ReaderT, mapReaderT) -import Control.Monad.State (StateT, mapStateT) -import Control.Monad.Writer (WriterT, mapWriterT) - --- | Mapping between Endo Natural Transformations +import Control.Monad.Except.Trans (ExceptT(..)) +import Control.Monad.RWS.Trans (RWSResult(..), RWST(..)) +import Control.Monad.Reader.Trans (ReaderT(..)) +import Control.Monad.State.Trans (StateT(..)) +import Control.Monad.Writer.Trans (WriterT(..)) +import Data.Either (Either(..)) +import Data.Tuple (Tuple(..)) + +-- | Avoiding monad-control for as long as possible class ShiftMap s t where - shiftMap :: (s ~> s) -> (t ~> t) + shiftMap :: forall a. (forall b. (a -> b) -> s b -> s b) -> t a -> t a -- Instances for common transformers +-- It's not possible to use the `map*` functions anymore + instance exceptShiftMap :: ShiftMap m (ExceptT e m) where - shiftMap = mapExceptT + shiftMap f (ExceptT m) = ExceptT do f Right m -instance rwsShiftMap :: ShiftMap m (RWST r w s m) where - shiftMap = mapRWST +instance rwsShiftMap :: Monoid w => ShiftMap m (RWST r w s m) where + shiftMap f (RWST g) = RWST \r s -> f (\a -> RWSResult s a mempty) (g r s) instance readerShiftMap :: ShiftMap m (ReaderT r m) where - shiftMap = mapReaderT + shiftMap f (ReaderT m) = ReaderT \r -> f identity (m r) -instance stateShiftMap :: ShiftMap m (StateT s m) where - shiftMap = mapStateT +instance stateShiftMap :: Monad m => ShiftMap m (StateT s m) where + shiftMap f (StateT g) = StateT \s -> f (\a -> Tuple a s) (g s) -instance writerShiftMap :: ShiftMap m (WriterT s m) where - shiftMap = mapWriterT +instance writerShiftMap :: Monoid w => ShiftMap m (WriterT w m) where + shiftMap f (WriterT m) = WriterT do f (\a -> Tuple a mempty) m