├── .gitignore ├── LICENSE.md ├── README.md ├── bower.json └── src ├── DSL ├── Cofree.purs ├── CofreeAff.purs ├── Types.purs └── Utils.purs └── Main.purs /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components 2 | /output 3 | /.psci_modules 4 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Coot 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A simple crud DSL with an interpreter written as cofree commonad in Purescript 2 | 3 | The store type is simply 4 | ```purescript 5 | type Store = Array User 6 | ``` 7 | 8 | where 9 | ```purescript 10 | newtype User = User 11 | { id :: Int 12 | , name :: String 13 | } 14 | ``` 15 | 16 | There are four commands in the DSL: 17 | ```purescript 18 | data Command a = Add User a 19 | | Remove Int a 20 | | ChangeName Int String a 21 | | GetUsers (Array User -> a) 22 | | SaveUser User a 23 | ``` 24 | 25 | The type of the DSL is 26 | ```purescript 27 | type StoreDSL a = Free Command a 28 | ``` 29 | 30 | There are two interpreters 31 | * synchronous one 32 | ```purescript 33 | newtype Run a = Run 34 | { addUser :: User -> a 35 | , remove :: Int -> a 36 | , changeName :: Int -> String -> a 37 | , getUsers :: Unit -> Tuple (Array User) a 38 | , saveUser :: User -> a 39 | } 40 | 41 | type Interp a = Cofree Run a 42 | ``` 43 | 44 | The pairing is given by 45 | ```purescript 46 | pair :: forall x y. Command (x -> y) -> Run x -> y 47 | ``` 48 | 49 | We pair the `Free` and `Cofree` using the [`explore`](https://pursuit.purescript.org/packages/purescript-free/3.4.0/docs/Control.Comonad.Cofree#v:explore) function from `Control.Comonad.Cofree` module. 50 | 51 | * asynchronous one with computations in the `Aff` monad 52 | ```purescript 53 | newtype RunAff eff a = RunAff 54 | { addUser :: User -> Aff eff a 55 | , remove :: Int -> Aff eff a 56 | , changeName :: Int -> String -> Aff eff a 57 | , getUsers :: Unit -> Aff eff (Tuple (Array User) a) 58 | , saveUser :: User -> Aff eff a 59 | } 60 | 61 | type AffInterp eff a = Cofree (RunAff eff) a 62 | ``` 63 | 64 | The pairing is given by 65 | ```purescript 66 | pairInAff :: forall eff x y. Command (x -> y) -> RunAff eff x -> Aff eff y 67 | ``` 68 | 69 | Here we pair using a custom [`exploreAff`](https://github.com/coot/purescript-dsl-example/blob/master/src/DSL/Utils.purs#L11) function. 70 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-dsl-store", 3 | "ignore": [ 4 | "**/.*", 5 | "node_modules", 6 | "bower_components", 7 | "output" 8 | ], 9 | "dependencies": { 10 | "purescript-prelude": "^3.0.0", 11 | "purescript-console": "^3.0.0", 12 | "purescript-free": "^4.0.0", 13 | "purescript-pairing": "^4.0.0", 14 | "purescript-freet": "^3.0.0", 15 | "purescript-transformers": "^3.2.0", 16 | "purescript-aff": "^3.0.0" 17 | }, 18 | "devDependencies": { 19 | "purescript-psci-support": "^3.0.0" 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /src/DSL/Cofree.purs: -------------------------------------------------------------------------------- 1 | module DSL.Cofree 2 | ( runExample 3 | , Run(..) 4 | , mkInterp 5 | , pair 6 | , cmds 7 | ) where 8 | 9 | -- | (synchronous) interpreter for the `StoreDSL` using Cofree 10 | 11 | import Prelude 12 | 13 | import DSL.Types (Command(..), StoreDSL, User(..), addUser, changeName, getUsers) 14 | import Data.Array as A 15 | import Control.Comonad.Cofree (Cofree, explore, unfoldCofree) 16 | import Control.Monad.Eff (Eff) 17 | import Control.Monad.Eff.Console (CONSOLE, log) 18 | import Data.Foldable (foldl, sequence_) 19 | import Data.Newtype (unwrap) 20 | import Data.Tuple (Tuple(..)) 21 | 22 | newtype Run a = Run 23 | { addUser :: User -> a 24 | , remove :: Int -> a 25 | , changeName :: Int -> String -> a 26 | -- getUsers could be just `Tuple (Array User) a`, but let's have a fancy function ;) 27 | , getUsers :: Unit -> Tuple (Array User) a 28 | , getUser :: Tuple User a 29 | , saveUser :: User -> a 30 | } 31 | 32 | derive instance functorRun :: Functor Run 33 | 34 | -- | interpreter's type 35 | type Interp a = Cofree Run a 36 | 37 | -- | create an interpreter with initial state 38 | mkInterp :: Array User -> Interp (Array User) 39 | mkInterp state = unfoldCofree id next state 40 | where 41 | addUser :: Array User -> User -> Array User 42 | addUser st = A.snoc st 43 | 44 | remove :: Array User -> Int -> Array User 45 | remove st uid = A.filter (\u -> (unwrap u).id /= uid) st 46 | 47 | changeName :: Array User -> Int -> String -> Array User 48 | changeName st uid name = 49 | let chname acu (User u) = 50 | if u.id /= uid 51 | then A.snoc acu (User u) 52 | else A.snoc acu (User u { name = name }) 53 | in foldl chname [] st 54 | 55 | getUsers :: Array User -> Unit -> Tuple (Array User) (Array User) 56 | getUsers st = 57 | let users = [User {id: 2, name: "Pierre"}, User {id: 3, name: "Diogo"}] 58 | in const $ Tuple users st 59 | 60 | getUser :: Array User -> Tuple User (Array User) 61 | getUser st = Tuple (User {id: 4, name: "Wojtek"}) st 62 | 63 | next :: Array User -> Run (Array User) 64 | next st = Run 65 | { addUser: addUser st 66 | , remove: remove st 67 | , changeName: changeName st 68 | , getUsers: getUsers st 69 | , getUser: getUser st 70 | , saveUser: const st 71 | } 72 | 73 | 74 | -- | pairing between `Command (x -> y)` and `Run` 75 | pair :: forall x y. Command (x -> y) -> Run x -> y 76 | pair (Add u f) (Run interp) = f $ interp.addUser u 77 | pair (Remove uid f) (Run interp) = f $ interp.remove uid 78 | pair (ChangeName uid name f) (Run interp) = f $ interp.changeName uid name 79 | pair (GetUsers f) (Run interp) = case interp.getUsers unit of 80 | Tuple users x -> f users x 81 | pair (SaveUser user f) (Run interp) = f $ interp.saveUser user 82 | pair (GetUser f) (Run interp) = (\(Tuple u x) -> f u x) interp.getUser 83 | 84 | cmds :: StoreDSL (Array User -> Array User) 85 | cmds = do 86 | users <- getUsers 87 | -- interp.getUser is adding users to the state 88 | sequence_ $ addUser <$> users 89 | changeName 1 "coot" 90 | 91 | run :: StoreDSL (Array User -> Array User) -> Array User -> Array User 92 | run cmds_ state = explore pair cmds_ $ mkInterp state 93 | 94 | runExample:: forall e. Eff (console :: CONSOLE | e) Unit 95 | runExample = do 96 | log $ show $ run cmds [User {id: 1, name: "Marcin"}] 97 | -------------------------------------------------------------------------------- /src/DSL/CofreeAff.purs: -------------------------------------------------------------------------------- 1 | module DSL.CofreeAff 2 | ( runAffExample 3 | , RunAff(..) 4 | , AffInterp 5 | , mkAffInterp 6 | , pairInAff 7 | ) where 8 | 9 | -- | (asynchronous) interpreter for the `StoreDSL` using Cofree running 10 | -- | commputations inside Aff monad 11 | 12 | import Prelude 13 | 14 | import Data.Array as A 15 | import Data.Time.Duration (Milliseconds(..)) 16 | import Control.Comonad.Cofree (Cofree, unfoldCofree) 17 | import Control.Monad.Aff (Aff, delay, runAff) 18 | import Control.Monad.Eff (Eff) 19 | import Control.Monad.Eff.Console (CONSOLE, log) 20 | import DSL.Types (Command(..), StoreDSL, User(..), addUser, changeName, getUsers, getUser) 21 | import DSL.Utils (exploreAff) 22 | import Data.Foldable (foldl, sequence_) 23 | import Data.Newtype (unwrap) 24 | import Data.Tuple (Tuple(..)) 25 | 26 | 27 | newtype RunAff eff a = RunAff 28 | { addUser :: User -> Aff eff a 29 | , remove :: Int -> Aff eff a 30 | , changeName :: Int -> String -> Aff eff a 31 | , getUsers :: Aff eff (Tuple (Array User) a) 32 | , getUser :: Aff eff (Tuple User a) 33 | , saveUser :: User -> Aff eff a 34 | } 35 | 36 | derive instance functorRunAff :: Functor (RunAff eff) 37 | 38 | -- | interpreter's type 39 | type AffInterp eff a = Cofree (RunAff eff) a 40 | 41 | -- create the interpreter with initial state 42 | mkAffInterp :: forall eff. Array User -> AffInterp eff (Array User) 43 | mkAffInterp state = unfoldCofree id next state 44 | where 45 | addUser :: Array User -> User -> Aff eff (Array User) 46 | addUser st u = do 47 | delay $ Milliseconds 0.0 48 | pure $ A.snoc st u 49 | 50 | remove :: Array User -> Int -> Aff eff (Array User) 51 | remove st uid = do 52 | delay $ Milliseconds 0.0 53 | pure (A.filter (\user -> (unwrap user).id /= uid) st) 54 | 55 | changeName :: Array User -> Int -> String -> Aff eff (Array User) 56 | changeName st uid name = 57 | let 58 | chname :: Array User -> User -> Array User 59 | chname acu (User u) = 60 | if u.id /= uid 61 | then A.snoc acu (User u) 62 | else A.snoc acu (User u { name = name }) 63 | in do 64 | delay $ Milliseconds 0.0 65 | pure (foldl chname [] st) 66 | 67 | getUsers :: Array User -> Aff eff (Tuple (Array User) (Array User)) 68 | getUsers st = 69 | let users = [User {id: 2, name: "Pierre"}, User {id: 3, name: "Diogo"}] 70 | in do 71 | delay $ Milliseconds 0.0 72 | pure $ Tuple users st 73 | 74 | getUser :: Array User -> Aff eff (Tuple User (Array User)) 75 | getUser st = 76 | let user = User {id: 4, name: "Wojtek"} 77 | in do 78 | delay $ Milliseconds 0.0 79 | pure $ Tuple user st 80 | 81 | saveUser :: Array User -> User -> Aff eff (Array User) 82 | saveUser st user = do 83 | delay $ Milliseconds 0.0 84 | pure st 85 | 86 | next :: Array User -> RunAff eff (Array User) 87 | next st = RunAff 88 | { addUser: addUser st 89 | , remove: remove st 90 | , changeName: changeName st 91 | , getUsers: getUsers st 92 | , getUser: getUser st 93 | , saveUser: saveUser st 94 | } 95 | 96 | pairInAff :: forall eff x y. Command (x -> y) -> RunAff eff x -> Aff eff y 97 | pairInAff (Add u f) (RunAff interp) = f <$> interp.addUser u 98 | pairInAff (Remove uid f) (RunAff interp) = f <$> interp.remove uid 99 | pairInAff (ChangeName uid name f) (RunAff interp) = f <$> interp.changeName uid name 100 | pairInAff (GetUsers f) (RunAff interp) = (\(Tuple users x) -> f users x) <$> interp.getUsers 101 | pairInAff (GetUser f) (RunAff interp) = (\(Tuple user x) -> f user x) <$> interp.getUser 102 | pairInAff (SaveUser user f) (RunAff interp) = f <$> interp.saveUser user 103 | 104 | cmds :: StoreDSL (Array User -> Array User) 105 | cmds = do 106 | users <- getUsers 107 | -- interp.getUser is adding users to the state 108 | sequence_ $ addUser <$> users 109 | u <- getUser 110 | _ <- addUser u 111 | changeName 1 "coot" 112 | 113 | run :: forall eff. StoreDSL (Array User -> Array User) -> Array User -> Aff eff (Array User) 114 | run cmds_ state = exploreAff pairInAff cmds_ $ mkAffInterp state 115 | 116 | runAffExample :: forall e. Eff (console :: CONSOLE | e) Unit 117 | runAffExample = do 118 | _ <- runAff 119 | (\_ -> log "ups...") 120 | (\users -> log $ show users) 121 | $ run cmds [User {id: 1, name: "Marcin"}] 122 | log "done" 123 | -------------------------------------------------------------------------------- /src/DSL/Types.purs: -------------------------------------------------------------------------------- 1 | module DSL.Types 2 | ( User(..) 3 | , Command(..) 4 | , StoreDSL 5 | , addUser 6 | , removeUser 7 | , changeName 8 | , getUsers 9 | , getUser 10 | ) where 11 | 12 | import Prelude 13 | 14 | import Control.Monad.Free (Free, liftF) 15 | import Data.Newtype (class Newtype) 16 | 17 | newtype User = User 18 | { id :: Int 19 | , name :: String 20 | } 21 | 22 | instance showUser :: Show User where 23 | show (User u) = "User " <> show u.name 24 | 25 | derive instance newtypeUser :: Newtype User _ 26 | 27 | -- | DSL commands (crud) 28 | data Command a = Add User a 29 | | Remove Int a 30 | | ChangeName Int String a 31 | | GetUsers (Array User -> a) 32 | | GetUser (User -> a) 33 | | SaveUser User a 34 | 35 | derive instance functorCommand :: Functor Command 36 | 37 | -- | DSL 38 | type StoreDSL a = Free Command a 39 | 40 | addUser :: User -> StoreDSL (Array User -> Array User) 41 | addUser u = liftF (Add u id) 42 | 43 | removeUser :: Int -> StoreDSL (Array User -> Array User) 44 | removeUser uid = liftF (Remove uid id) 45 | 46 | changeName :: Int -> String -> StoreDSL (Array User -> Array User) 47 | changeName uid name = liftF (ChangeName uid name id) 48 | 49 | getUsers :: StoreDSL (Array User) 50 | getUsers = liftF $ GetUsers id 51 | 52 | getUser :: StoreDSL User 53 | getUser = liftF $ GetUser id 54 | -------------------------------------------------------------------------------- /src/DSL/Utils.purs: -------------------------------------------------------------------------------- 1 | module DSL.Utils where 2 | 3 | import Control.Comonad (extract) 4 | import Control.Comonad.Cofree (Cofree, tail) 5 | import Control.Monad.Aff (Aff) 6 | import Control.Monad.Free (Free, runFreeM) 7 | import Control.Monad.State (StateT(..), runStateT) 8 | import Data.Tuple (Tuple(..)) 9 | import Prelude (map, class Functor, ($)) 10 | 11 | exploreAff 12 | :: forall f g a b eff 13 | . Functor f 14 | => Functor g 15 | => (forall x y. f (x -> y) -> g x -> Aff eff y) 16 | -> Free f (a -> b) 17 | -> Cofree g a 18 | -> Aff eff b 19 | exploreAff pair m w = 20 | map eval $ runStateT (runFreeM step m) w 21 | where 22 | step :: f (Free f (a -> b)) -> StateT (Cofree g a) (Aff eff) (Free f (a -> b)) 23 | step ff = StateT \cof -> pair (map Tuple ff) (tail cof) 24 | 25 | eval :: forall x y. Tuple (x -> y) (Cofree g x) -> y 26 | eval (Tuple f cof) = f (extract cof) 27 | -------------------------------------------------------------------------------- /src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | 5 | import DSL.Cofree (runExample) 6 | import DSL.CofreeAff (runAffExample) 7 | import Control.Monad.Eff (Eff) 8 | import Control.Monad.Eff.Console (CONSOLE, log) 9 | 10 | main :: forall e. Eff (console :: CONSOLE | e) Unit 11 | main = do 12 | log "\nCofree" 13 | runExample 14 | log "\nCofreeAff" 15 | runAffExample 16 | --------------------------------------------------------------------------------