diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.2.1.0 + +* Add `Bluefin.DslBuilder` + ## 0.2.2.0 * `Bluefin.Compound`: add `OneWayCoercible`, `OneWayCoercibleHandle`, diff --git a/bluefin.cabal b/bluefin.cabal --- a/bluefin.cabal +++ b/bluefin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: bluefin -version: 0.2.2.0 +version: 0.2.3.0 license: MIT license-file: LICENSE author: Tom Ellis @@ -24,6 +24,7 @@ Bluefin.Compound, Bluefin.Consume, Bluefin.Coroutine, + Bluefin.DslBuilder, Bluefin.EarlyReturn, Bluefin.Eff, Bluefin.Exception, @@ -39,6 +40,6 @@ Bluefin.System.IO, Bluefin.Writer, build-depends: - bluefin-internal >= 0.3.0.0 && < 0.4 + bluefin-internal >= 0.3.1.0 && < 0.4 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Bluefin/Compound.hs b/src/Bluefin/Compound.hs --- a/src/Bluefin/Compound.hs +++ b/src/Bluefin/Compound.hs @@ -661,8 +661,8 @@ -- | The documentation for 'Handle' shows how to use -- @OneWayCoercible@ to define @Handle@ instances. - OneWayCoercible.OneWayCoercible, - OneWayCoercibleHandle, + OneWayCoercible.OneWayCoercible(OneWayCoercible.oneWayCoercibleImpl), + OneWayCoercibleHandle(MkOneWayCoercibleHandle), OneWayCoercible.gOneWayCoercible, OneWayCoercible.Generic, diff --git a/src/Bluefin/DslBuilder.hs b/src/Bluefin/DslBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Bluefin/DslBuilder.hs @@ -0,0 +1,342 @@ +module Bluefin.DslBuilder + ( -- | Haksell is great for writing domain specific languages (DSLs) + -- and @Bluefin.DslBuilder@ provides an easy way to write DSLs + -- using Bluefin. + + -- * Robot arena example + + -- ** Data types for the robot arena + + -- | Here's an example of the use of @Bluefin.DslBuilder@. Suppose + -- we have a data type that represents the location of robots and + -- obstacles in a two-dimensional square arena: + -- + -- @ + -- data Arena = MkArena + -- { arenaRobots :: [RobotEntry], + -- arenaObstacles :: [ObstacleEntry] + -- } + -- @ + -- + -- Each @RobotEntry@ stores the robot's name, coordinates on the + -- 2d grid, facing direction, and instructions for robot to carry + -- out + -- + -- @ + -- type RobotEntry = (String, (Int, Int), Direction, [Instruction]) + -- @ + -- + -- The instructions that a robot can perform are to wait for a + -- given number of time units, move forward, turn left and turn + -- right. + -- + -- @ + -- data Instruction = Wait Int | Forward | TurnLeft | TurnRight + -- data Direction = N | E | S | W + -- @ + -- + -- The @ObstacleEntry@s store the type of each obstacle and its + -- coordinates on the 2d grid. + -- + -- @ + -- type ObstacleEntry = (Obstacle, (Int, Int)) + -- + -- data Obstacle = Sand | Rock | Iron + -- @ + + -- ** Defining an @Arena@ by hand + + -- | Suppose we want an @Arena@ with a red robot which moves + -- towards a sand obstacle, and a blue robot that is stuck behind + -- iron obstacles and can only turn around on the spot. Here's an + -- ASCII diagram of the initial position we want, where @r@ is the + -- red robot, @S@ is a sand obstacle, @b@ is the blue robot and + -- @I@ is an iron obstacle: + -- + -- @ + -- 5| + -- 4| III + -- 3| IbI + -- 2| III + -- 1| + -- 0|r S + -- +------ + -- 012345 + -- @ + -- + -- We can define such an @Arena@ by hand like this: + -- + -- @ + -- myArena :: Arena + -- myArena = + -- MkArena + -- { arenaRobots = + -- [ ("red", (0, 0), E, [Wait 100, Forward, Forward, Forward, Forward]), + -- ("blue", (3, 3), N, [TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight, TurnRight]) + -- ], + -- arenaObstacles = [(Sand, (5, 0)), (Iron, (2, 2)), (Iron, (2, 3)), (Iron, (2, 4)), (Iron, (3, 2)), (Iron, (3, 4)), (Iron, (4, 2)), (Iron, (4, 3)), (Iron, (4, 4))] + -- } + -- @ + -- + -- That's messy and contains a lot of repetition! We can use + -- Haskell constructs to do a bit better: + -- + -- @ + -- myArena2 :: Arena + -- myArena2 = + -- MkArena + -- { arenaRobots = + -- [ ("red", (0, 0), E, Wait 100 : replicate 4 Forward), + -- ("blue", (3, 3), N, replicate 20 TurnRight) + -- ], + -- arenaObstacles = + -- (Sand, (5, 0)) + -- : [ (Iron, (x, y)) + -- | x <- [2 .. 4], + -- y <- [2 .. 4], + -- (x, y) /= (3, 3) + -- ] + -- } + -- @ + -- + -- That's more compressed but it doesn't describe our intent + -- clearly. + + -- ** Defining an @Arena@ with a DSL + + -- | Let's use @Bluefin.DslBuilder@ to write a DSL that allows us + -- to express our intent more clearly. Before we define the DSL, + -- let's look at what it will allow us to write. In @myDslArena@ + -- below I can define the red robot and its obstacles separately + -- from the blue robot and its obstacles, and I can use `for_` + -- loops to conveniently define the blue robot's iron cage. + -- + -- @ + -- myDslArena :: Arena + -- myDslArena = buildArena $ do + -- -- 5| + -- -- 4| + -- -- 3| + -- -- 2| + -- -- 1| + -- -- 0|R S + -- -- +------ + -- -- 012345 + -- robot "red" (0, 0) E $ do + -- wait 100 + -- forward 4 + -- + -- obstacle Sand (5, 0) + -- + -- -- 5| + -- -- 4| III + -- -- 3| IBI + -- -- 2| III + -- -- 1| + -- -- 0| + -- -- +------ + -- -- 012345 + -- robot "blue" (3, 3) N $ do + -- replicateM_ 10 aboutFace + -- + -- for_ [2 .. 4] $ \\x -> do + -- for_ [2 .. 4] $ \\y -> do + -- unless ((x, y) == (3, 3)) $ do + -- obstacle Iron (x, y) + -- @ + + -- ** Arena DSL definitions + + -- | So what are the definitions of the components that go into + -- building an @Arena@? + + -- *** @buildArena@ and @ArenaBuilder@ + + -- | Firstly, what does @buildArena@ do? It's going to have this + -- type: + -- + -- @ + -- buildArena :: ArenaBuilder -> Arena + -- @ + -- + -- @ArenaBuilder@ is the type of the @do@ block which contains the + -- @robot@ and @obstacle@ entries, and is a convenience type + -- synonym: + -- + -- @ + -- type ArenaBuilder = ArenaBuilder_ () + -- @ + -- + -- @ArenaBuilder_@ is a @Monad@ and is the first component + -- we are going to build using @Bluefin.DslBuilder@: + -- + -- @ + -- newtype ArenaBuilder_ r + -- = MkArenaBuilder ('DslBuilder' ArenaH r) + -- deriving (Functor, Applicative, Monad) + -- @ + -- + -- @DslBuilder ArenaH@ is a @Monad@ that allows us access to the + -- effects inside the handle @ArenaH@ (and no others). So what is + -- @ArenaH@? It is defined like this: + -- + -- @ + -- data ArenaH e = MkArenaH ('Bluefin.Stream.Stream' RobotEntry e) (Stream ObstacleEntry e) + -- deriving t'Bluefin.Compound.Generic' + -- deriving t'Bluefin.Compound.Handle' via t'Bluefin.Compound.OneWayCoercibleHandle' ArenaH + -- + -- instance (e :> es) => 'Bluefin.Compound.OneWayCoercible' (ArenaH e) (ArenaH es) where + -- 'Bluefin.Compound.oneWayCoercibleImpl' = 'Bluefin.Compound.gOneWayCoercible' + -- @ + -- + -- What does that mean? Well, @ArenaH@ is defined according to one + -- of the recipes from "Bluefin.Compound", and gives the ability + -- to yield to a @Stream@ of @RobotEntry@s and a stream of + -- @ObstacleEntry@s, i.e. the components that make up an @Arena@. + -- The only things we can do with the @ArenaH@ then are to give it + -- @RobotEntry@s or @ObstacleEntry@s. How do we get them? + + -- *** @obstacle@ + + -- | To get an @ObstacleEntry@ we use the @obstacle@ command. + -- It has type + -- + -- @ + -- obstacle :: Strength -> (Int, Int) -> ArenaBuilder + -- @ + -- + -- When calling @obstacle@ we specify the strength of the obstacle + -- and its coordinates in the arena. In fact, having those gives + -- us exactly what we need to yield an @ObstacleEntry@ to the + -- @Stream ObstacleEntry@ inside the @ArenaBuilder@: + -- + -- @ + -- obstacle o coord = + -- MkArenaBuilder $ 'dslBuilder' $ \(MkArenaH _ yobstacle) -> do + -- 'Bluefin.Stream.yield' yobstacle (o, coord) + -- @ + + -- *** @robot@ and @InstructionsBuilder@ + + -- | To get a @RobotEntry@ we use the @robot@ component. It has + -- type + -- + -- @ + -- robot :: + -- String -> (Int, Int) -> Direction -> InstructionsBuilder -> ArenaBuilder + -- @ + -- + -- When calling @robot@ we specify the name, coordinates, and + -- facing direction for our robot. We also specify the + -- instructions for the robot by providing an + -- @InstructionsBuilder@? What's that? It's /another/ @Monad@ + -- defined in terms of @DslBuilder@: + -- + -- @ + -- type InstructionsBuilder = InstructionsBuilder_ () + -- + -- newtype InstructionsBuilder_ r + -- = MkInstructionsBuilder ('DslBuilder' InstructionsH r) + -- deriving (Functor, Applicative, Monad) + -- @ + -- + -- Like with @ArenaBuilder@, to define the @Monad@ we define a + -- handle, this time @InstructionsH@: + -- + -- @ + -- data InstructionsH e = MkInstructionsH ('Bluefin.Stream.Stream' Instruction e) + -- deriving t'Bluefin.Compound.Generic' + -- deriving t'Bluefin.Compound.Handle' via t'Bluefin.Compound.OneWayCoercibleHandle' InstructionsH + -- + -- instance (e :> es) => t'Bluefin.Compound.OneWayCoercible' (InstructionsH e) (InstructionsH es) where + -- oneWayCoercibleImpl = 'Bluefin.Compound.gOneWayCoercible' + -- @ + -- + -- @InstructionsH@ allows us to yield to a sequence of + -- @Instruction@s, i.e. the type of robot instructions defined + -- above and used in @Arena@ via @RobotEntry@. In fact, the job + -- of @robot@ is exactly to allow us to define a @RobotEntry@ and + -- yield it to the @Stream RobotEntry@ of @Arena@: + -- + -- @ + -- robot name coords dir (MkInstructionsBuilder ibuilder) = + -- MkArenaBuilder $ 'dslBuilder' $ \\(MkArenaH yrobot _) -> do + -- (insns, ()) \<- 'Bluefin.Stream.yieldToList' $ \\yinsns -> do + -- 'runDslBuilder' (MkInstructionsH ('Bluefin.Compound.mapHandle' yinsns)) ibuilder + -- + -- 'Bluefin.Stream.yield' yrobot (name, coords, dir, insns) + -- @ + + -- *** Creating @InstructionsBuilder@s + + -- | In a @do@ block of type @InstructionsBuilder@ we want to be + -- able to write things like @wait 100@, @forward 4@ and + -- @aboutFace@. What are they? To define commands of type + -- @InstructionsBuilder@ we use this convenience function: + -- + -- @ + -- instructionsBuilder :: Instruction -> InstructionsBuilder + -- instructionsBuilder insn = + -- MkInstructionsBuilder $ dslBuilder $ \\(MkInstructionsH yinsn) -> do + -- yield yinsn insn + -- @ + -- + -- which we can use as follows to define commands as follows: + -- + -- @ + -- wait :: Int -> InstructionsBuilder + -- wait n = instructionsBuilder (Wait n) + -- + -- turnLeft :: InstructionsBuilder + -- turnLeft = instructionsBuilder TurnLeft + -- + -- turnRight :: InstructionsBuilder + -- turnRight = instructionsBuilder TurnRight + -- + -- aboutFace :: InstructionsBuilder + -- aboutFace = do + -- turnRight + -- turnRight + -- + -- forward :: Int -> InstructionsBuilder + -- forward n = replicateM_ n (instructionsBuilder Forward) + -- @ + + -- *** Implementing @buildArena@ + + -- | We're now ready to implement @buildArena@. We create a + -- @Stream RobotEntry@ and a @Stream ObstacleEntry@ to pass to the + -- @MkArenaH@ constructor, and use @runDslBuilder@ to run the + -- @ArenaBuilder@ provided. (This is a lot like some of the approaches + -- in "Bluefin.Compound".) + -- + -- @ + -- buildArena :: ArenaBuilder -> Arena + -- buildArena (MkArenaBuilder arenaBuilder) = runPureEff $ do + -- (robots, obstacles) \<- 'Bluefin.Stream.yieldToList' $ \\yrobots -> do + -- (obstacles, ()) \<- yieldToList $ \\yobstacles -> do + -- 'runDslBuilder' + -- (MkArenaH ('Bluefin.Compound.mapHandle' yrobots) (mapHandle yobstacles)) + -- arenaBuilder + -- + -- pure obstacles + -- + -- pure + -- MkArena + -- { arenaRobots = robots, + -- arenaObstacles = obstacles + -- } + -- @ + -- + -- And that's all we need to support the implementation of + -- @myDslArena :: Arena@ given above! + + -- * @DslBuilder@ + + DslBuilder, + dslBuilder, + runDslBuilder, + ) +where + +import Bluefin.Internal.DslBuilder