packages feed

control-dsl (empty) → 0.2.0.0

raw patch · 19 files changed

+849/−0 lines, 19 filesdep +basedep +containersdep +control-dslsetup-changed

Dependencies added: base, containers, control-dsl, doctest, doctest-discover, temporary

Files

+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Changelog for `Control.Dsl`++## 0.2.0.0++* Renamed package `do-notation-dsl` to `control-dsl`.+* Renamed type class `Dsl` to `PolyCont`+* Renamed type class `Do` to `Dsl`+* Addd many utility functions.+* Improved documentation and tests.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,3 @@+# `Control.Dsl`: An alternative to monads++See [`Control.Dsl` on Hackage](https://hackage.haskell.org/package/control-dsl/docs/Control-Dsl.html) for more information.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ control-dsl.cabal view
@@ -0,0 +1,65 @@+cabal-version: >=1.10+name: control-dsl+version: 0.2.0.0+license: BSD3+license-file: LICENSE+copyright: 2018 Yang Bo+maintainer: pop.atry@gmail.com+author: Yang Bo+homepage: https://github.com/Atry/Control.Dsl#readme+bug-reports: https://github.com/Atry/Control.Dsl/issues+synopsis: An alternative to monads+description:+    This \"control-dsl\" package is a toolkit to create extensible Domain Specific Languages in @do@-notation.+    .+    See "Control.Dsl" for more information.+category: Control, DSL, Effect, General, Language, Mutable State, IO, Polymorphism+build-type: Simple+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+    type: git+    location: https://github.com/Atry/Control.Dsl++library+    exposed-modules:+        Control.Dsl+        Control.Dsl.Cont+        Control.Dsl.Empty+        Control.Dsl.Monadic+        Control.Dsl.PolyCont+        Control.Dsl.Return+        Control.Dsl.Shift+        Control.Dsl.State+        Control.Dsl.State.Get+        Control.Dsl.State.Put+        Control.Dsl.Yield+    hs-source-dirs: src+    other-modules:+        Control.Dsl.Dsl+        Control.Dsl.State.State+    default-language: Haskell2010+    other-extensions: RebindableSyntax MultiParamTypeClasses+                      TypeOperators FlexibleInstances FlexibleContexts+                      UndecidableInstances RankNTypes GADTs+    build-depends:+        base >=4.8 && <5++test-suite doctests+    type: exitcode-stdio-1.0+    main-is: doctest-driver.hs+    hs-source-dirs: test+    other-modules:+        Paths_control_dsl+    default-language: Haskell2010+    other-extensions: TypeApplications+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base >=4.8 && <5,+        containers >=0.5.11.0 && <0.6,+        control-dsl -any,+        doctest >=0.16.0.1 && <0.17,+        doctest-discover >=0.1.0.9 && <0.2,+        temporary ==1.3.*
+ src/Control/Dsl.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE FlexibleContexts #-}++{- | This "Control.Dsl" module and its submodules provide a toolkit+to create extensible Domain Specific Languages in @do@-notation.++A DSL @do@ block contains heterogeneous statements from different vendors.+A statement can be defined as a GADT,+interpreted by a 'Dsl' type class instance, either effectful or purely.++A DSL @do@ block is abstract.+When creating the block, the type class requirements is automatically inferred.+Therefore, the data structures and implementation of interpreters+can be switched by providing different instances.++= Getting started++This package provides 'Dsl' type class used in @do@ notation,+as a replacement to 'Control.Monad.Monad'.++@RebindableSyntax@ extension is required to enable DSL @do@ notation.++>>> :set -XRebindableSyntax+>>> import Prelude hiding ((>>), (>>=), return, fail)+>>> import Control.Dsl++== DSL model++Suppose you are creating a DSL for console IO,+you need to define some keywords allowed in the DSL.++Each keyword is a GADT:++>>> data MaxLengthConfig r a where MaxLengthConfig :: MaxLengthConfig r Int+>>> data GetLine r a where GetLine :: GetLine r String+>>> data PutStrLn r a where PutStrLn :: String -> PutStrLn r ()++== DSL @do@ block++Then those keywords can be used in @do@ blocks:++>>> :{+dslBlock = do+  maxLength <- MaxLengthConfig+  line1 <- GetLine+  line2 <- GetLine+  when (length line1 + length line2 > maxLength) $ do+    PutStrLn "The input is too long"+    fail "Illegal input"+  PutStrLn ("The input is " ++ line1 ++ " and " ++ line2)+  return ()+:}++The above @dslBlock@ function creates an abstract code block of DSL +from keywords and some built-in control flow functions.++Keywords and the result statement 'return' and 'fail'+are ad-hoc polymorphic delimited continuations,+interpreted by 'Contro.Dsl.PolyCont.PolyCont',+which can be automatically inferred:++>>> :type dslBlock+dslBlock+  :: (PolyCont (Return IOError) r Void, PolyCont (Return ()) r Void,+      PolyCont MaxLengthConfig r Int, PolyCont GetLine r [Char],+      PolyCont PutStrLn r ()) =>+     r++=== Creating a pure interpreter++The type of @r@ varies from different 'Contro.Dsl.PolyCont.PolyCont' instances.+By defining 'Contro.Dsl.PolyCont.PolyCont' instances for @PureInterpreter@,+you can make @r@ be a @PureInterpreter@:++>>> type PureInterpreter = Int -> [String] -> Cont [String] IOError++>>> :{+instance PolyCont MaxLengthConfig PureInterpreter Int where+  runPolyCont MaxLengthConfig = runPolyCont Get+:}++>>> :{+instance PolyCont PutStrLn PureInterpreter () where+  runPolyCont (PutStrLn s) = runPolyCont (Yield s)+:}++>>> :{+instance PolyCont (Return ()) PureInterpreter Void where+  runPolyCont (Return ()) = runPolyCont Empty+:}++The above three 'Contro.Dsl.PolyCont.PolyCont' instances are implemented as+forwarders to other existing keywords.++>>> :{+instance PolyCont GetLine PureInterpreter String where+  runPolyCont k = runCont $ do+    x : xs <- Get @[String]+    Put xs+    return x+:}++The 'Contro.Dsl.PolyCont.PolyCont' instance for @GetLine@ is implemented as a+'Contro.Dsl.Cont' that contains a DSL @do@ block of atomic statements.++=== Running the DSL purely++>>> runPurely = dslBlock :: PureInterpreter++>>> errorHandler e = ["(handled) " ++ show e]+>>> runCont (runPurely 80 ["LINE_1", "LINE_2"]) errorHandler+["The input is LINE_1 and LINE_2"]++>>> longInput = [replicate 40 '*', replicate 41 '*']+>>> runCont (runPurely 80 longInput) errorHandler+["The input is too long","(handled) user error (Illegal input)"]++>>> runCont (runPurely 80 ["ONE_LINE"]) errorHandler+["(handled) user error (Pattern match failure in do expression at <interactive>..."]++=== Creating an effectful interpreter++Alternatively, @dslBlock@ can run effectfully by providing effectful+'Contro.Dsl.PolyCont.PolyCont' instances.++>>> type EffectfulInterpreter = Handle -> IO ()++>>> :{+instance PolyCont GetLine EffectfulInterpreter String where+  runPolyCont GetLine = runCont $ do+    h <- Get+    line <- Monadic (hGetLine h)+    return line+:}++'Contro.Dsl.Monadic.Monadic' is a built-in keyword to perform old-fashioned+monadic action in a DSL @do@ block.++Other keywords can be used together with 'Contro.Dsl.Monadic.Monadic'.+No monad transformer is required.++>>> :{+instance PolyCont MaxLengthConfig (IO ()) Int where+  runPolyCont MaxLengthConfig f = f 80+:}++>>> :{+instance PolyCont PutStrLn (IO ()) () where+  runPolyCont (PutStrLn s) = (Prelude.>>=) (putStrLn s)+:}++>>> :{+instance PolyCont (Return IOError) (IO ()) Void where+  runPolyCont (Return e) _ = hPutStrLn stderr (show e)+:}++=== Running the DSL effectfully++>>> runEffectfully = dslBlock :: EffectfulInterpreter++>>> :{+withSystemTempFile "tmp-input-file" $ \_ -> \h -> do+  Monadic $ hPutStrLn h "LINE_1"+  Monadic $ hPutStrLn h "LINE_2"+  Monadic $ hSeek h AbsoluteSeek 0+  runEffectfully h+:}+The input is LINE_1 and LINE_2+-}+module Control.Dsl(+  module Control.Dsl.Dsl,+  module Control.Dsl.Return,+  module Control.Dsl.Cont+) where++import Control.Dsl.Dsl hiding (cpsApply)+import Control.Dsl.Return (return, fail)+import Control.Dsl.Cont (when, unless, guard)++import Control.Dsl.State.State -- For orphan instances++import qualified Control.Monad -- For resolving haddock links+import qualified Control.Dsl.PolyCont -- For resolving haddock links+import qualified Control.Dsl.Cont -- For resolving haddock links+import qualified Control.Dsl.Return -- For resolving haddock links+import qualified Control.Dsl.Empty -- For resolving haddock links+import qualified Control.Dsl.Yield -- For resolving haddock links+import qualified Control.Dsl.State.Get -- For resolving haddock links+import qualified Control.Dsl.State.Put -- For resolving haddock links++-- $setup+-- >>> :set -XGADTs+-- >>> :set -XFlexibleContexts+-- >>> :set -XFlexibleInstances+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XUndecidableInstances+-- >>> :set -XTypeApplications+-- >>> import qualified Prelude+-- >>> import Control.Dsl.PolyCont+-- >>> import Control.Dsl.Monadic+-- >>> import Control.Dsl.Cont+-- >>> import Control.Dsl.Yield+-- >>> import Control.Dsl.Return+-- >>> import Control.Dsl.Empty+-- >>> import Control.Dsl.State+-- >>> import Data.Void+-- >>> import System.IO+-- >>> import System.IO.Temp
+ src/Control/Dsl/Cont.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}++module Control.Dsl.Cont where++import Control.Dsl.Return+import Control.Dsl.Empty+import Control.Dsl.PolyCont+import Data.Void+import Prelude hiding ((>>), (>>=), return, fail)++{- | A type alias to 'Cont' for a deeply nested delimited continuation.++==== __Examples__++>>> :set -XTypeOperators+>>> :set -XRebindableSyntax+>>> import Prelude hiding ((>>), (>>=), return, fail)+>>> import Control.Dsl+>>> import Control.Dsl.Yield+>>> import Control.Dsl.Empty+>>> :{+f :: IO () !! [Integer] !! [String] !! [Double]+f = do+  Yield "foo"+  Yield 0.5+  Yield 42+  empty+:}+-}+type (!!) = Cont++-- ! A delimited continuation that can be used in a @do@ block.+newtype Cont r a = Cont { runCont :: (a -> r) -> r }++when :: Bool -> Cont r () -> Cont r ()+when True k = k+when False _ = Cont ($ ())++unless True _ = Cont $ \f -> f ()+unless False (Cont k) = Cont k++guard True = Cont $ \f -> f ()+guard False = Cont $ \f -> empty++instance {-# OVERLAPS #-} PolyCont k r a => PolyCont k (Cont r a') a where+  runPolyCont k f = Cont $ \g -> runPolyCont k $ \a -> runCont (f a) g++instance PolyCont (Return r) (Cont r' r) Void where+  runPolyCont (Return r) _ = Cont ($ r)++instance PolyCont Empty r Void => PolyCont Empty (Cont r a) Void where+  runPolyCont k _ = Cont (const empty)
+ src/Control/Dsl/Dsl.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}++module Control.Dsl.Dsl where++import Control.Dsl.PolyCont+import Control.Dsl.Cont+import Prelude hiding ((>>), (>>=), return, fail)++{- | Witnesses a use case of a statement in a @do@ block.++== Allowed statements in DSL @do@ blocks++A statement in a DSL @do@ block is a delimited continuation,+which can be a GADT keyword, a control flow operator,+or the final result:+++-------------------+-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+-----------------------------------------+----------------------------------------------------------------------------------------------++|                   |                                                                                                Keywords                                                                                               |          Control flow operators         |                                            Results                                           |++-------------------+-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+-----------------------------------------+----------------------------------------------------------------------------------------------++|      Examples     | 'Control.Dsl.Shift.Shift', 'Control.Dsl.Yield.Yield', 'Control.Dsl.State.Get.Get', 'Control.Dsl.State.Put.Put', 'Control.Dsl.Monadic.Monadic', 'Control.Dsl.Return.Return', 'Control.Dsl.Empty.Empty' | 'ifThenElse', 'when', 'unless', 'guard' | 'Control.Dsl.Return.return', 'Control.Dsl.Return.fail', 'Control.Dsl.Empty.empty', 'forever' |++-------------------+-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+-----------------------------------------+----------------------------------------------------------------------------------------------++|        Type       |                                                                                              custom GADT                                                                                              |         'Control.Dsl.Cont.Cont'         |                                      the answer type @r@                                     |++-------------------+-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+-----------------------------------------+----------------------------------------------------------------------------------------------++|   Interpreted by  |                                                                                    'Control.Dsl.PolyCont.PolyCont'                                                                                    |                   N/A                   |                                'Control.Dsl.PolyCont.PolyCont'                               |++-------------------+-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+-----------------------------------------+----------------------------------------------------------------------------------------------++| Can be present at |                                                                                                      not the last statement of a @do@ block                                                                                                     |                              the last statement of a @do@ block                              |++-------------------+-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------+----------------------------------------------------------------------------------------------+++Don't create custom instances of 'Dsl' for statement.+Instead, create 'PolyCont' instances for your custom GADT keywords.++==== __Examples__++>>> :set -XGADTs+>>> :set -XMultiParamTypeClasses+>>> :set -XFlexibleInstances+>>> :set -XFlexibleContexts+>>> :set -XRebindableSyntax+>>> :set -XTypeApplications+>>> import qualified Prelude+>>> import Prelude hiding ((>>), (>>=), return, fail)+>>> import Control.Dsl+>>> import Control.Dsl.State.Get+>>> 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"+:}++@f@ is a @do@ block that contains keywords of+'Control.Dsl.State.Get.Get',+'Control.Dsl.Yield.Yield',+and 'Control.Dsl.Return.return'.+With the help of built-in 'PolyCont' instances for those keywords,+@f@ can be used as a function that accepts a boolean parameter.++>>> f False :: [String]+["foo","baz"]++>>> f True :: [String]+["foo","bar","baz"]++In fact, @f@ can be any type+as long as 'PolyCont' instances for involved keywords are provided.++>>> :type f+f :: (PolyCont (Yield [Char]) r (),+      PolyCont (Return [Char]) r Void, PolyCont Get r Bool) =>+     r++For example, @f@ can be interpreted as an impure @IO ()@,+providing the following instances:++>>> :{+instance PolyCont (Yield String) (IO ()) () where+  runPolyCont (Yield a) = (Prelude.>>=) (putStrLn $ "Yield " ++ a)+instance PolyCont Get (IO ()) Bool where+  runPolyCont Get f = putStrLn "Get" Prelude.>> f False+instance PolyCont (Return String) (IO ()) Void where+  runPolyCont (Return r) _ = putStrLn $ "Return " ++ r+:}++>>> f :: IO ()+Yield foo+Get+Return baz+-}+class Dsl k r a where+  cpsApply :: k r a -> (a -> r) -> r++{- | The implementation of @<-@ statements in a @do@ block,+which forwards to 'runCont' if @k@ is 'Cont',+otherwise forwards to 'runPolyCont' from 'PolyCont'.+-}+(>>=) k = cpsApply k++f =<< k = k >>= f++(f >=> g) k = f k >>= g++f <=< g = f >=> g++-- | The implementation of statements with no value in a @do@ block.+k >> a = cpsApply k $ const a++-- | Statements based on ad-hoc polymorphic delimited continuations.+instance {-# OVERLAPS #-} PolyCont k r a => Dsl k r a where+  cpsApply = runPolyCont++-- | Statements based on monomorphic delimited continuations.+instance Dsl Cont r a where+  cpsApply = runCont++forever :: Dsl k r a => k r a -> r+forever k = k >> forever k++ifThenElse True k _ = k+ifThenElse False _ k = k
+ src/Control/Dsl/Empty.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}++module Control.Dsl.Empty where++import Control.Dsl.PolyCont+import Data.Void+import qualified Control.Applicative+import Prelude hiding ((>>), (>>=), return, fail)++data Empty r a where+  Empty :: Empty r Void++instance {-# OVERLAPS #-} Control.Applicative.Alternative m => PolyCont Empty (m a) Void where+  runPolyCont Empty _ = Control.Applicative.empty++{- | Return an empty @a@, similar to 'Control.Alternative.empty'.++This 'empty' function aims to be used as the last statement of a @do@ block.+-}+empty :: PolyCont Empty a Void => a+empty = runPolyCont Empty absurd
+ src/Control/Dsl/Monadic.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RebindableSyntax #-}++module Control.Dsl.Monadic where++import Control.Dsl.PolyCont+import qualified Prelude++-- | This @Monadic@ keyword extracts the monadic value of a monadic expression.+newtype Monadic m r a = Monadic (m a)++instance Prelude.Monad m => PolyCont (Monadic m) (m b) a where+  runPolyCont (Monadic k) = (Prelude.>>=) k
+ src/Control/Dsl/PolyCont.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}++module Control.Dsl.PolyCont where++import Prelude hiding ((>>), (>>=), return, fail)++{- | A use case of an __ad-hoc polymorphic delimited continuation__.++Note that a 'PolyCont' is not a __polymorphic delimited continuation__,+since a 'PolyCont' does not support answer type modification.+-}+class PolyCont k r a where+  -- | Run as a CPS function .+  runPolyCont :: k r' a -> (a -> r) -> r
+ src/Control/Dsl/Return.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE GADTs #-}++module Control.Dsl.Return where++import Prelude hiding ((>>), (>>=), return, fail)+import Control.Dsl.PolyCont+import Control.Exception+import Data.Void++data Return r' r a where+  Return :: r' -> Return r' r Void++instance PolyCont (Return r) r Void where+  runPolyCont (Return r) _ = r++{- | Lift @r@ to the answer type, similar to 'Prelude.return'.++This 'return' function aims to be used as the last statement of a @do@ block.++When 'return' is present in a nested @do@ block for 'when' or 'unless',+if the @r@ is not @()@,+it will create a 'Cont' that performs early return,+skipping the rest statements of the outer @do@ notation.++==== __Examples__++>>> :set -XTypeOperators+>>> :set -XRebindableSyntax+>>> import Prelude hiding ((>>), (>>=), return, fail)+>>> import Control.Dsl+>>> import Control.Dsl.Return+>>> import Control.Dsl.Yield+>>> import Control.Dsl.Cont+>>> import Control.Dsl.Empty++>>> :{+earlyGenerator :: Bool -> Cont [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 <- 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"]+-}+return r = runPolyCont (Return r) absurd++{- | Lift an 'IOError' to the answer type, similar to 'Prelude.fail'.++This 'fail' function aims to be used as the last statement of a @do@ block.+-}+fail r = return (userError r)++instance {-# OVERLAPS #-} Applicative m => PolyCont (Return r) (m r) Void where+  runPolyCont (Return r) _ = pure r
+ src/Control/Dsl/Shift.hs view
@@ -0,0 +1,19 @@++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{- |+Description : Delimited continuations+-}+module Control.Dsl.Shift where++import Data.Void+import Control.Dsl.PolyCont+import Prelude hiding ((>>), (>>=), return, fail)++-- | A keyword to extract the value of a CPS function .+newtype Shift r' r a = Shift ((a -> r') -> r')++instance PolyCont (Shift r) r a where+  runPolyCont (Shift k) = k
+ src/Control/Dsl/State.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE GADTs #-}++{- |+Description : Mutable variables++This module provides keywords to 'Put' and 'Get' the value of multiple mutable variables in a @do@ block.+-}+module Control.Dsl.State (+  module Control.Dsl.State.Put,+  module Control.Dsl.State.Get,+  module Control.Dsl.State.State,+) where++import Control.Dsl.State.Put+import Control.Dsl.State.Get+import Control.Dsl.State.State
+ src/Control/Dsl/State/Get.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module Control.Dsl.State.Get where++import Prelude hiding ((>>), (>>=), return, fail)+import Control.Dsl.PolyCont+import Control.Dsl.State.State++data Get r a where+  Get :: forall s r. Get r s++instance PolyCont Get (State s r) s where+  runPolyCont Get f s = f s s
+ src/Control/Dsl/State/Put.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE GADTs #-}++module Control.Dsl.State.Put where++import Prelude hiding ((>>), (>>=), return, fail)+import Control.Dsl.PolyCont+import Control.Dsl.State.State++data Put s r a where+  Put :: s -> Put s r ()++instance PolyCont (Put s) (State s r) () where+  runPolyCont (Put s) f _ = f () s
+ src/Control/Dsl/State/State.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module Control.Dsl.State.State where++import Data.Void+import Control.Dsl.Empty+import Control.Dsl.Return+import Control.Dsl.PolyCont+import Prelude hiding ((>>), (>>=), return, fail)++{- |+The type that holds states, which is defined as a plain function.++==== __Examples__++>>> :set -XFlexibleContexts+>>> :set -XTypeApplications+>>> :set -XRebindableSyntax+>>> import Prelude hiding ((>>), (>>=), return, fail)+>>> import Control.Dsl+>>> import Control.Dsl.Cont+>>> import Control.Dsl.Shift+>>> import Control.Dsl.State+>>> import Data.Sequence (Seq, (|>))+>>> import qualified Data.Sequence+>>> import Data.Foldable++The following @append@ function 'Control.Dsl.State.Get's a @Seq String@ state,+appends @s@ to the 'Data.Sequence.Seq',+and 'Control.Dsl.State.Put's the new 'Data.Sequence.Seq' to the updated state.++>>> :{+append s = do+  buffer <- Get @(Seq String)+  Put $ buffer |> s+  Cont ($ ())+:}++@($ ())@ creates a CPS function ,+which can be then converted to 'Control.Dsl.Cont.Cont's.++A @formatter@ @append@s 'String' to its internal buffer,+and 'Control.Dsl.return' the concatenated buffer.++>>> :{+formatter = do+  append "x="+  d <- Get @Double+  append $ show d+  append ",y="+  i <- Get @Integer+  append $ show i+  buffer <- Get @(Seq String)+  return $ concat buffer+:}++>>> x = 0.5 :: Double+>>> y = 42 :: Integer+>>> initialBuffer = Data.Sequence.empty :: Seq String+>>> formatter x y initialBuffer :: String+"x=0.5,y=42"++Note that @formatter@ accepts arbitrary order of the parameters,+or additional unused parameters.++>>> formatter "unused parameter" initialBuffer y x :: String+"x=0.5,y=42"+-}+type State = (->)++instance {-# OVERLAPS #-} PolyCont k r a => PolyCont k (State s r) a where+  runPolyCont k f s = runPolyCont k $ \a -> f a s++instance {-# OVERLAPS #-} PolyCont k r Void => PolyCont k (State s r) Void where+  runPolyCont k _ _ = runPolyCont k absurd++instance {-# OVERLAPS #-} PolyCont Empty r Void => PolyCont Empty (State s r) Void where+  runPolyCont k _ _ = empty+      +instance PolyCont (Return r) (State s r) Void where+  runPolyCont (Return r) _ _ = r
+ src/Control/Dsl/Yield.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE TypeOperators #-}++{- |+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.+-}+module Control.Dsl.Yield where++import Control.Dsl.Cont+import Control.Dsl.PolyCont+import Prelude hiding ((>>), (>>=), return, fail)++{- | This @Yield@ keyword produces an element in a list generator++==== __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, fail)+>>> 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]+-}+data Yield x r a where+  Yield :: x -> Yield x r ()++instance PolyCont (Yield x) [x] () where+  runPolyCont (Yield x) f = x : f ()++instance PolyCont (Yield x) (Cont r [x]) () where+  runPolyCont (Yield x) f = Cont $ \g -> runCont (f ()) $ \xs -> g (x : xs)
+ test/doctest-driver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF doctest-discover #-}