do-notation-dsl (empty) → 0.1.0.0

raw patch · 16 files changed

+492/−0 lines, 16 filesdep +basedep +containersdep +do-notation-dslsetup-changed

Dependencies added: base, containers, do-notation-dsl, doctest, doctest-discover, temporary

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +14/−0
• Setup.hs +2/−0
• do-notation-dsl.cabal +63/−0
• src/Control/Dsl.hs +74/−0
• src/Control/Dsl/Cont.hs +16/−0
• src/Control/Dsl/Do.hs +23/−0
• src/Control/Dsl/Dsl.hs +22/−0
• src/Control/Dsl/Empty.hs +25/−0
• src/Control/Dsl/Monadic.hs +13/−0
• src/Control/Dsl/Return.hs +38/−0
• src/Control/Dsl/Shift.hs +55/−0
• src/Control/Dsl/State.hs +66/−0
• src/Control/Dsl/Yield.hs +47/−0
• test/doctest-driver.hs +1/−0

@@ -0,0 +1,3 @@+# Changelog for dsl++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Yang Bo here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,14 @@+# Dsl++The `Prelude.>>=` combinator limits the return type as a `m b`, which cause Monads not composable. In order to ease this restrictions, this proposal introduces another type class `Dsl` for do notation.++Motivation+----------++Monads do not compose. Normally a `do` block cannot contains operators defined in different monad instances.++The state of art solution is [using only one monad](http://okmij.org/ftp/Haskell/extensible/) `Eff`, which forwards all monadic bind operations to custom effect handlers, instead of defining new monads.++However, the `Eff` approach is heavy weight than ordinary monad. It's not very convenient to create an additional indirect layer for simple use cases.++The  `Eff` approach of bypassing  `>>=` combinator is quite embarrassing. Since  `>>=` settles on our logo, In this proposal we present a new approach to enable multiple operations at once by improving  `>>=`. This proposal aims to port the approach used in [Dsl.scala](https://github.com/ThoughtWorksInc/Dsl.scala) to Haskell. This approach improves the extensibility of `>>=`.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,63 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: ccaebc69f4e2a90c260f2f0aae7895664f69da64f434fe09d967182f13b83aa2++name:           do-notation-dsl+version:        0.1.0.0+synopsis:       An alternative to monads+description:    Please see the README on GitHub at <https://github.com/Atry/dsl#readme>+category:       Control, DSL, Effect, General, Language, Mutable State, IO, Polymorphism+homepage:       https://github.com/Atry/dsl#readme+bug-reports:    https://github.com/Atry/dsl/issues+author:         Yang Bo+maintainer:     pop.atry@gmail.com+copyright:      2018 Yang Bo+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/Atry/dsl++library+  exposed-modules:+      Control.Dsl+      Control.Dsl.Cont+      Control.Dsl.Do+      Control.Dsl.Empty+      Control.Dsl.Monadic+      Control.Dsl.Return+      Control.Dsl.Shift+      Control.Dsl.State+      Control.Dsl.Yield+  other-modules:+      Control.Dsl.Dsl+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+  default-language: Haskell2010++test-suite doctests+  type: exitcode-stdio-1.0+  main-is: doctest-driver.hs+  other-modules:+      Paths_do_notation_dsl+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers+    , do-notation-dsl+    , doctest+    , doctest-discover+    , temporary+  default-language: Haskell2010

@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}++{- |+>>> :set -XTypeFamilies+>>> :set -XMultiParamTypeClasses+>>> :set -XFlexibleInstances+>>> :set -XFlexibleContexts+>>> :set -XRebindableSyntax+>>> :set -XTypeApplications+>>> import qualified Prelude+>>> import Prelude hiding ((>>), (>>=), return)+>>> import Control.Dsl+>>> import Control.Dsl.State+>>> import Control.Dsl.Yield+>>> import Control.Dsl.Return+>>> import Data.Void++>>> :{+f = do+  Yield "foo"+  config <- Get @Bool+  when config $ do+    Yield "bar"+    return ()+  return "baz"+:}++>>> :type f+f :: (Dsl (Yield [Char]) r (), Dsl (Return [Char]) r Void,+      Dsl Get r Bool) =>+     r++>>> f True :: [String]+["foo","bar","baz"]++>>> :{+instance Dsl (Yield String) (IO ()) () where+  cpsApply (Yield a) = (Prelude.>>=) (putStrLn $ "Yield " ++ a)+:}++>>> :{+instance Dsl Get (IO ()) Bool where+  cpsApply Get f = (putStrLn "Get") Prelude.>> f False+:}++>>> :{+instance Dsl (Return String) (IO ()) Void where+  cpsApply (Return a) _ = putStrLn $ "Return " ++ a+:}++>>> f :: IO ()+Yield foo+Get+Return baz+-}+module Control.Dsl(+  module Control.Dsl.Dsl,+  module Control.Dsl.Return,+  module Control.Dsl.Do,+  module Control.Dsl.Cont+) where++import Control.Dsl.Return (return)+import Control.Dsl.Dsl (Dsl(..))+import Control.Dsl.Cont (when)+import Control.Dsl.Do ((>>=), (>>))++-- Import modules that contains orphan instances+import Control.Dsl.Shift ()+-- import Control.Dsl.State ()

@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}++module Control.Dsl.Cont where++import Prelude hiding ((>>), (>>=), return)++type r !! a = (a -> r) -> r++newtype Cont r a = Cont (r !! a)++when True k = Cont k+when False _ = Cont $ \f -> f ()

@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}++module Control.Dsl.Do where++import Control.Dsl.Dsl+import Control.Dsl.Cont+import Prelude hiding ((>>), (>>=), return)++class Do k r a where+  (>>=) :: k r a -> r !! a+  (>>) :: k r a -> r -> r+  k >> a = k >>= const a++instance {-# OVERLAPPABLE #-} Dsl k r a => Do k r a where+  (>>=) = cpsApply++instance Do Cont r a where+  (>>=) (Cont k) = k+

@@ -0,0 +1,22 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}++module Control.Dsl.Dsl where++import Control.Dsl.Cont+import Control.Applicative+import Data.Void+import Prelude hiding ((>>), (>>=), return)++{- | This type class witnesses a use case of @k@,+which is an ad-hoc delimited continuation adaptive to the answer type @r@.+-}+class Dsl k r a where+  cpsApply :: k r0 a -> r !! a++instance {-# OVERLAPPABLE #-} Dsl k r a => Dsl k (b -> r) a where+  cpsApply k f b = cpsApply k $ \a -> f a b

@@ -0,0 +1,25 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FunctionalDependencies #-}++module Control.Dsl.Empty where++import Control.Dsl.Dsl+import Data.Void+import Control.Applicative+import Prelude hiding ((>>), (>>=), return)++data Empty r a where+  Empty :: Empty r Void++instance Dsl Empty [r] Void where+  cpsApply Empty _ = []++instance Dsl Empty (Maybe r) Void where+  cpsApply Empty _ = Nothing++empty :: Dsl Empty r Void => r+empty = cpsApply Empty absurd

@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RebindableSyntax #-}++module Control.Dsl.Monadic where++import Control.Dsl.Dsl+import qualified Prelude++newtype Monadic m r a = Monadic (m a)++instance Prelude.Monad m => Dsl (Monadic m) (m b) a where+  cpsApply (Monadic k) = (Prelude.>>=) k

@@ -0,0 +1,38 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}++module Control.Dsl.Return where++import Prelude hiding ((>>), (>>=), return)+import Control.Dsl.Dsl+import Control.Dsl.Cont+import Control.Exception+import Data.Void++data Return r0 r b where+  Return :: r0 -> Return r0 r Void++instance Dsl (Return r) r Void where+  cpsApply (Return r) _ = r++return r = cpsApply (Return r) absurd++instance Dsl (Return a) (r !! a) Void where+  cpsApply (Return a) _ f = f a++instance Dsl (Return r) [r] Void where+  cpsApply (Return r) _ = [r]++instance Dsl (Return r) (Maybe r) Void where+  cpsApply (Return r) _ = Just r++instance Dsl (Return r) (IO r) Void where+  cpsApply (Return r) _ = evaluate r

@@ -0,0 +1,55 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{- |+Description : Delimited continuations+-}+module Control.Dsl.Shift where++import Data.Void+import Control.Dsl.Cont+import Control.Dsl.Dsl+import Prelude hiding ((>>), (>>=), return)++{- |+>>> :set -XTypeOperators+>>> :set -XRebindableSyntax+>>> import Prelude hiding ((>>), (>>=), return)+>>> import Control.Dsl+>>> import Control.Dsl.Return+>>> import Control.Dsl.Yield+>>> import Control.Dsl.Empty++>>> :{+earlyGenerator :: Bool -> [String] !! Integer+earlyGenerator earlyReturn = do+  Yield "inside earlyGenerator"+  when earlyReturn $ do+    Yield "early return"+    return 1+  Yield "normal return"+  return 0+:}++>>> :{+earlyGeneratorTest :: [String]+earlyGeneratorTest = do+  Yield "before earlyGenerator"+  i <- Shift $ earlyGenerator True+  Yield "after earlyGenerator"+  Yield $ "the return value of earlyGenerator is " ++ show i+  empty+:}++>>> earlyGeneratorTest+["before earlyGenerator","inside earlyGenerator","early return","after earlyGenerator","the return value of earlyGenerator is 1"]+-}+newtype Shift r0 r a = Shift (r0 !! a)++instance Dsl (Shift r) r a where+  cpsApply (Shift k) f = k f++-- instance Dsl m a d => Dsl m a (Shift d b) where+--   cpsApply k f = Shift $ \g -> cpsApply k $ \a -> cpsApply (f a) g

@@ -0,0 +1,66 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++{- |+Description : Mutable variables++This module provides the ability to 'Put' and 'Get' the value of multiple mutable variables in a @do@ block.++>>> :set -XTypeApplications+>>> :set -XRebindableSyntax+>>> import Prelude hiding ((>>), (>>=), return)+>>> import Control.Dsl+>>> import Data.Sequence++>>> :set -fprint-potential-instances+>>> :{+formatter :: Double -> Integer -> Seq String -> String+formatter = do+  --+  -- Equivalent of `!Put(!Get[Vector[Any]] :+ "x=")` in Dsl.scala+  tmpBuffer0 <- Get @(Seq String)+  Put $ tmpBuffer0 |> "x="+  --+  -- Equivalent of `!Put(!Get[Vector[Any]] :+ !Get[Double])` in Dsl.scala+  tmpBuffer1 <- Get @(Seq String)+  d <- Get @Double+  Put $ tmpBuffer1 |> show d+  --+  -- Equivalent of `!Put(!Get[Vector[Any]] :+ ",y=")` in Dsl.scala+  tmpBuffer2 <- Get @(Seq String)+  Put $ tmpBuffer2 |> ",y="+  --+  -- Equivalent of `!Put(!Get[Vector[Any]] :+ !Get[Int])` in Dsl.scala+  tmpBuffer3 <- Get @(Seq String)+  i <- Get @Integer+  Put $ tmpBuffer3 |>  show i+  --+  -- Equivalent of `!Return((!Get[Vector[Any]]).mkString)` in Dsl.scala+  tmpBuffer4 <- Get @(Seq String)+  return $ foldl1 (++) tmpBuffer4+:}++>>> formatter 0.5 42 Empty+"x=0.5,y=42"+-}+module Control.Dsl.State where++import Prelude hiding ((>>), (>>=), return)+import Control.Dsl.Dsl++type State a b = a -> b++data Put a r u where+  Put :: a -> Put a r ()++instance Dsl (Put a) (State a b) () where+  cpsApply (Put a) f _ = f () a++data Get r a where+  Get :: forall a r. Get r a++instance Dsl Get (State a b) a where+  cpsApply Get f a = f a a

@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RebindableSyntax #-}++{- |+Description : Generators++This module contains the 'Yield' data type and related 'Dsl' instances.++The 'Yield' data type can be used to create generators,+similar to the @yield@ keyword in C#, Python, and ECMAScript.++=== Examples++@randomGenerator@ is an example to create+an xorshift pseudo-random number generator+that returns an infinite list of generated numbers.++>>> :set -XTypeApplications+>>> :set -XRebindableSyntax+>>> import Prelude hiding ((>>), (>>=), return)+>>> import Control.Dsl+>>> import Data.Word+>>> import Data.Bits+>>> :{+randomGenerator :: Word32 -> [Word32]+randomGenerator seed =+  do let tmp1 = xor seed $ shiftL seed 13+     let tmp2 = xor tmp1 $ shiftR tmp1 17+     let tmp3 = xor tmp2 $ shiftL tmp2 5+     Yield tmp3+     randomGenerator tmp3+:}++>>> take 5 $ randomGenerator 2463534242+[723471715,2497366906,2064144800,2008045182,3532304609]+-}+module Control.Dsl.Yield where++import Control.Dsl.Dsl++data Yield a r b where+  Yield :: a -> Yield a r ()++instance Dsl (Yield a) [a] () where+  cpsApply (Yield a) f = a : f ()

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF doctest-discover #-}