├── LICENSE ├── README.md ├── Setup.hs ├── Toody.cabal ├── lib ├── Toody.hs └── Toody │ ├── Box.hs │ ├── Grid.hs │ ├── Helpers.hs │ ├── Neighborhood.hs │ ├── Parser.hs │ ├── Point.hs │ ├── Search.hs │ ├── Size.hs │ ├── Utils.hs │ └── Zipper.hs ├── stack.yaml └── test └── Spec.hs /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017 Jon Purdy 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the “Software”), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Toody 2 | 3 | Toody is a comonadic parser combinator library for parsing two-dimensional data, 4 | such as ASCII art diagrams and 2D programming languages. Whereas most parsing 5 | libraries are concerned with one-dimensional streams, Toody works on 2D grids of 6 | cells, extracting data based on spatial relationships. 7 | 8 | It is presented primarily as a proof of concept, and has not been designed for 9 | efficiency. 10 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /Toody.cabal: -------------------------------------------------------------------------------- 1 | name: Toody 2 | version: 0.1.0.0 3 | synopsis: Two-dimensional parser combinators. 4 | description: 5 | Toody is a comonadic parser combinator library for parsing two-dimensional 6 | data, such as ASCII art diagrams and 2D programming languages. Whereas most 7 | parsing libraries are concerned with one-dimensional streams, Toody works on 8 | 2D grids of cells, extracting data based on spatial relationships. 9 | 10 | It is presented primarily as a proof of concept, and has not been designed 11 | for efficiency. 12 | 13 | homepage: https://github.com/evincarofautumn/Toody#readme 14 | license: MIT 15 | license-file: LICENSE 16 | author: Jon Purdy 17 | maintainer: evincarofautumn@gmail.com 18 | copyright: 2017 Jon Purdy 19 | category: Parsing 20 | build-type: Simple 21 | extra-source-files: README.md 22 | cabal-version: >=1.10 23 | 24 | library 25 | hs-source-dirs: lib 26 | exposed-modules: Toody 27 | , Toody.Box 28 | , Toody.Grid 29 | , Toody.Helpers 30 | , Toody.Neighborhood 31 | , Toody.Parser 32 | , Toody.Point 33 | , Toody.Search 34 | , Toody.Size 35 | , Toody.Utils 36 | , Toody.Zipper 37 | ghc-options: -Wall 38 | build-depends: base >= 4.7 && < 5 39 | , comonad 40 | default-language: Haskell2010 41 | 42 | test-suite toody-test 43 | type: exitcode-stdio-1.0 44 | hs-source-dirs: test 45 | main-is: Spec.hs 46 | build-depends: base 47 | , HUnit 48 | , Toody 49 | , hspec 50 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 51 | default-language: Haskell2010 52 | 53 | source-repository head 54 | type: git 55 | location: https://github.com/evincarofautumn/Toody 56 | -------------------------------------------------------------------------------- /lib/Toody.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody 3 | Description : Kitchen sink that reexports all general Toody modules. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | module Toody 10 | ( module Toody 11 | ) where 12 | 13 | import Toody.Box as Toody 14 | import Toody.Grid as Toody 15 | import Toody.Helpers as Toody 16 | import Toody.Neighborhood as Toody 17 | import Toody.Parser as Toody 18 | import Toody.Point as Toody 19 | import Toody.Search as Toody 20 | import Toody.Size as Toody 21 | import Toody.Zipper as Toody 22 | -------------------------------------------------------------------------------- /lib/Toody/Box.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Box 3 | Description : Representation of a box with location and size. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | module Toody.Box 10 | ( Box(..) 11 | , Point(..) 12 | , Size(..) 13 | ) where 14 | 15 | import Toody.Point (Point(..)) 16 | import Toody.Size (Size(..)) 17 | 18 | -- | A box within a grid, used for reporting source spans in error messages and 19 | -- extracting sub-grids from grids. 20 | data Box = Box !Point !Size 21 | deriving (Eq, Show) 22 | -------------------------------------------------------------------------------- /lib/Toody/Grid.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Grid 3 | Description : A 2D zipper representing a grid of cells with a focus. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | {-# LANGUAGE DeriveFoldable #-} 10 | {-# LANGUAGE DeriveFunctor #-} 11 | {-# LANGUAGE DeriveTraversable #-} 12 | {-# LANGUAGE InstanceSigs #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | 15 | module Toody.Grid 16 | ( Grid(..) 17 | , Move 18 | , eastward 19 | , gridFrom 20 | , gridLocation 21 | , northeastward 22 | , northward 23 | , northwestward 24 | , southeastward 25 | , southward 26 | , southwestward 27 | , westward 28 | ) where 29 | 30 | import Control.Arrow ((&&&)) 31 | import Control.Comonad (Comonad(..)) 32 | import Control.Monad ((<=<)) 33 | import Data.Foldable (Foldable(..)) 34 | import Data.List (intercalate) 35 | import Toody.Point 36 | import Toody.Utils 37 | import Toody.Zipper 38 | 39 | -- | A 2D zipper representing a grid of values with a focus. 40 | newtype Grid a = Grid { unGrid :: Zipper (Zipper a) } 41 | deriving (Eq, Foldable, Functor, Traversable) 42 | 43 | -- | A motion within a grid that may fail, for example if it goes out of bounds. 44 | type Move a = Grid a -> Maybe (Grid a) 45 | 46 | -- | Standard motions within a grid. 47 | northwestward, northward, northeastward, 48 | westward, eastward, 49 | southwestward, southward, southeastward 50 | :: Move a 51 | 52 | northward = fmap Grid . leftward . unGrid 53 | southward = fmap Grid . rightward . unGrid 54 | westward = fmap Grid . traverse leftward . unGrid 55 | eastward = fmap Grid . traverse rightward . unGrid 56 | 57 | northwestward = northward <=< westward 58 | northeastward = northward <=< eastward 59 | southwestward = southward <=< westward 60 | southeastward = southward <=< eastward 61 | 62 | -- | Create a grid from a list of lists, using a default element as the focus if 63 | -- there are no rows or columns, as well as to pad all rows to the same width. 64 | gridFrom :: a -> [[a]] -> Grid a 65 | gridFrom p rows0 = let 66 | z0 = zipperFrom p [] 67 | in if null rows0 68 | then Grid (zipperFrom z0 [z0]) 69 | else let 70 | width = maximum (map length rows0) 71 | pad = take width . (++ repeat p) 72 | in Grid (zipperFrom z0 (map (zipperFrom p . pad) rows0)) 73 | 74 | -- | Extracts the current horizontal and vertical offset. 75 | gridLocation :: Grid a -> Point 76 | gridLocation = uncurry Point . (zipperIndex &&& zipperIndex . zipperCurrent) . unGrid 77 | 78 | instance Comonad Grid where 79 | 80 | extract :: Grid a -> a 81 | extract = extract . extract . unGrid 82 | 83 | duplicate :: forall a. Grid a -> Grid (Grid a) 84 | duplicate grid@(Grid z) = let 85 | 86 | focusInner :: Zipper (Grid a) 87 | focusInner = let 88 | befores = innerBefores grid 89 | afters = innerAfters grid 90 | in Zipper befores grid afters 91 | 92 | outerIndex, outerLength, innerIndex, innerLength :: Int 93 | outerIndex = zipperIndex z 94 | innerIndex = zipperIndex (extract z) 95 | outerIndex' = outerLength - outerIndex - 1 96 | innerIndex' = innerLength - innerIndex - 1 97 | outerLength = zipperLength z 98 | innerLength = zipperLength (extract z) 99 | 100 | outerBefores, outerAfters :: Zipper (Grid a) -> [Zipper (Grid a)] 101 | outerBefores = reverse . iterateMaybeN outerIndex (traverse northward) . traverse northward 102 | outerAfters = iterateMaybeN outerIndex' (traverse southward) . traverse southward 103 | 104 | innerBefores, innerAfters :: Grid a -> [Grid a] 105 | innerBefores = reverse . iterateMaybeN innerIndex westward . westward 106 | innerAfters = iterateMaybeN innerIndex' eastward . eastward 107 | 108 | in Grid 109 | (Zipper 110 | (outerBefores focusInner) 111 | focusInner 112 | (outerAfters focusInner)) 113 | 114 | -- Debugging utilities. 115 | 116 | instance (Show a) => Show (Grid a) where 117 | show (Grid z) = let 118 | before = map show (reverse (zipperBefore z)) 119 | after = map show (zipperAfter z) 120 | width = case map length (before ++ after) of 121 | [] -> 1 122 | lengths -> maximum lengths 123 | sep = concat ["\n", replicate width '-', "\n"] 124 | in concat 125 | [ "\n", intercalate "\n" before 126 | , sep, show (zipperCurrent z), sep 127 | , intercalate "\n" after, "\n" 128 | ] 129 | -------------------------------------------------------------------------------- /lib/Toody/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Helpers 3 | Description : Higher-level parsing helpers. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | {-# LANGUAGE DeriveFunctor #-} 10 | 11 | module Toody.Helpers 12 | ( BoxStyle(..) 13 | , asciiBox 14 | , asciiBoxStyle 15 | , box 16 | , doubleBox 17 | , doubleBoxStyle 18 | , lightBox 19 | , lightBoxStyle 20 | ) where 21 | 22 | import Control.Applicative (many) 23 | import Control.Monad (guard) 24 | import Toody.Box (Box(..), Size(..)) 25 | import Toody.Parser 26 | import qualified Toody.Grid as Grid 27 | 28 | -- | The style of a basic box described by the cells of its corners and edges. 29 | data BoxStyle c = BoxStyle 30 | { boxTopLeft, boxTopRight, boxBottomLeft, boxBottomRight 31 | , boxHorizontal, boxVertical :: c 32 | } deriving (Eq, Functor, Show) 33 | 34 | -- | Predefined box styles. 35 | asciiBoxStyle, lightBoxStyle, doubleBoxStyle :: BoxStyle Char 36 | 37 | asciiBoxStyle = BoxStyle 38 | { boxTopLeft = '+' 39 | , boxTopRight = '+' 40 | , boxBottomLeft = '+' 41 | , boxBottomRight = '+' 42 | , boxHorizontal = '-' 43 | , boxVertical = '|' 44 | } 45 | 46 | lightBoxStyle = BoxStyle 47 | { boxTopLeft = '┌' 48 | , boxTopRight = '┐' 49 | , boxBottomLeft = '└' 50 | , boxBottomRight = '┘' 51 | , boxHorizontal = '─' 52 | , boxVertical = '│' 53 | } 54 | 55 | doubleBoxStyle = BoxStyle 56 | { boxTopLeft = '╔' 57 | , boxTopRight = '╗' 58 | , boxBottomLeft = '╚' 59 | , boxBottomRight = '╝' 60 | , boxHorizontal = '═' 61 | , boxVertical = '║' 62 | } 63 | 64 | -- | Convenience parsers for different box styles. 65 | asciiBox, lightBox, doubleBox :: Parser Char Box 66 | 67 | asciiBox = box asciiBoxStyle 68 | lightBox = box lightBoxStyle 69 | doubleBox = box doubleBoxStyle 70 | 71 | -- | Parse a box clockwise from the top left corner according to the given style 72 | -- and return its location and size. 73 | box :: (Eq c, Show c) => BoxStyle c -> Parser c Box 74 | box style = do 75 | location <- maybe (fail "cannot parse box outside grid") pure =<< getLocation 76 | 77 | width <- moving Grid.eastward (between topLeft (lookahead topRight) horizontal) 78 | height <- moving Grid.southward (between topRight (lookahead bottomRight) vertical) 79 | width' <- moving Grid.westward (between bottomRight (lookahead bottomLeft) horizontal) 80 | height' <- moving Grid.northward (between bottomLeft (lookahead topLeft) vertical) 81 | 82 | guard (width == width' && height == height') 83 | pure (Box location (Size width height)) 84 | where 85 | 86 | topLeft = equal (boxTopLeft style) 87 | topRight = equal (boxTopRight style) 88 | bottomLeft = equal (boxBottomLeft style) 89 | bottomRight = equal (boxBottomRight style) 90 | 91 | horizontal = edge (equal (boxHorizontal style)) 92 | vertical = edge (equal (boxVertical style)) 93 | 94 | edge = fmap length . many 95 | -------------------------------------------------------------------------------- /lib/Toody/Neighborhood.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Neighborhood 3 | Description : An 8-way neighborhood of cells in a grid. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | {-# LANGUAGE DeriveFunctor #-} 10 | {-# LANGUAGE InstanceSigs #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | 14 | module Toody.Neighborhood 15 | ( Neighborhood(..) 16 | , gridNeighborhood 17 | ) where 18 | 19 | import Control.Comonad (Comonad(..)) 20 | import Toody.Grid (Grid) 21 | import qualified Toody.Grid as Grid 22 | 23 | -- | An 8-way neighborhood extracted from a grid. 24 | data Neighborhood a = Neighborhood 25 | { neighNorthwest, neighNorth, neighNortheast 26 | , neighWest, neighSelf, neighEast 27 | , neighSouthwest, neighSouth, neighSoutheast 28 | :: a 29 | } deriving (Eq, Functor, Show) 30 | 31 | instance Applicative Neighborhood where 32 | pure x = Neighborhood 33 | x x x 34 | x x x 35 | x x x 36 | 37 | (<*>) :: forall a b. Neighborhood (a -> b) -> Neighborhood a -> Neighborhood b 38 | fs <*> xs = let 39 | 40 | apply :: (forall x. Neighborhood x -> x) -> b 41 | apply direction = direction fs (direction xs) 42 | 43 | in Neighborhood 44 | { neighNorthwest = apply neighNorthwest 45 | , neighNorth = apply neighNorth 46 | , neighNortheast = apply neighNortheast 47 | , neighWest = apply neighWest 48 | , neighSelf = apply neighSelf 49 | , neighEast = apply neighEast 50 | , neighSouthwest = apply neighSouthwest 51 | , neighSouth = apply neighSouth 52 | , neighSoutheast = apply neighSoutheast 53 | } 54 | 55 | -- | The neighborhood of the currently focused item in a grid. 56 | -- 57 | -- Technically, @'Maybe' ('Neighborhood' a)@ would also work here, but 58 | -- @'Neighborhood' ('Maybe' a)@ is more useful since it tells you which items 59 | -- were successfully extracted. 60 | gridNeighborhood :: Grid a -> Neighborhood (Maybe a) 61 | gridNeighborhood grid = (fmap extract .) <$> Neighborhood 62 | { neighNorthwest = Grid.northwestward 63 | , neighNorth = Grid.northward 64 | , neighNortheast = Grid.northeastward 65 | , neighWest = Grid.westward 66 | , neighSelf = pure 67 | , neighEast = Grid.eastward 68 | , neighSouthwest = Grid.southwestward 69 | , neighSouth = Grid.southward 70 | , neighSoutheast = Grid.southeastward 71 | } <*> pure grid 72 | -------------------------------------------------------------------------------- /lib/Toody/Parser.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Parser 3 | Description : General 2D parsing primitives. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | {-# LANGUAGE InstanceSigs #-} 10 | 11 | module Toody.Parser 12 | ( ParseError 13 | , Parser(..) 14 | , between 15 | , boundary 16 | , equal 17 | , failure 18 | , getGrid 19 | , getLocation 20 | , lookahead 21 | , moving 22 | , negative 23 | , satisfy 24 | , setGrid 25 | , step 26 | ) where 27 | 28 | import Control.Applicative (Alternative(..)) 29 | import Control.Arrow ((&&&)) 30 | import Control.Comonad (Comonad(..)) 31 | import Control.Monad (MonadPlus(..), void) 32 | import Data.Monoid ((<>)) 33 | import Toody.Grid 34 | import Toody.Point 35 | 36 | -- | A parser is a function that accepts the current state of a 'Grid', and 37 | -- either fails with a 'ParseError', or returns a parsed value and an updated 38 | -- 'Grid', or 'Nothing' if the grid couldn't be updated. 39 | newtype Parser c a = Parser 40 | { runParser :: Move c -> Maybe (Grid c) -> Either ParseError (a, Maybe (Grid c)) } 41 | 42 | -- | A parse error message. 43 | type ParseError = String 44 | 45 | -- | Locally override the direction of a parser. 46 | moving :: Move c -> Parser c a -> Parser c a 47 | moving move (Parser p) = Parser $ \ _move grid -> p move grid 48 | 49 | -- | Accept a cell matching a predicate and advance in the current direction. 50 | satisfy :: (Show c) => (c -> Bool) -> Parser c c 51 | satisfy predicate = Parser $ \ move mGrid -> do 52 | let mCell = extract <$> mGrid 53 | case mCell of 54 | Nothing -> Left "Toody.satisfy: unexpected grid boundary" 55 | Just cell 56 | | predicate cell -> Right (cell, move =<< mGrid) 57 | | otherwise -> Left ("Toody.satisfy: failed to satisfy: " ++ show mGrid) 58 | 59 | -- | Step one cell in a direction. 60 | step :: (Show c) => Move c -> Parser c () 61 | step move = void (moving move anything) 62 | 63 | -- | Accept a single cell equal to a given cell. 64 | equal :: (Eq c, Show c) => c -> Parser c c 65 | equal = satisfy . (==) 66 | 67 | -- | Accept anything and advance in the current direction. 68 | anything :: (Show c) => Parser c c 69 | anything = satisfy (const True) 70 | 71 | -- | Accepts only a grid boundary. 72 | boundary :: Parser c () 73 | boundary = Parser $ \ _move mGrid -> case mGrid of 74 | Nothing -> Right ((), mGrid) 75 | Just{} -> Left "Toody.boundary: expected grid boundary" 76 | 77 | -- | Wraps a parser in beginning and ending delimiters. 78 | between :: Parser c b -> Parser c e -> Parser c i -> Parser c i 79 | between begin end item = begin *> item <* end 80 | 81 | -- | Runs a parser, ignoring any motion it makes. 82 | lookahead :: Parser c a -> Parser c a 83 | lookahead (Parser p) = Parser $ \ move mGrid -> do 84 | (c, _mGrid') <- p move mGrid 85 | pure (c, mGrid) 86 | 87 | -- TODO: Add 'try'? Would require distinguishing "failed but consumed no input" 88 | -- from "failed and consumed input" as Parsec does. 89 | 90 | -- | Succeeds when the supplied parser fails, and fails if it succeeds. 91 | negative :: Parser c a -> Parser c () 92 | negative (Parser p) = Parser $ \ move mGrid -> case p move mGrid of 93 | Left{} -> Right ((), mGrid) 94 | Right{} -> Left "Toody.negative: expected parser failure" 95 | 96 | instance Functor (Parser c) where 97 | fmap f (Parser p) = Parser $ \ move grid -> case p move grid of 98 | Left e -> Left e 99 | Right (c, mGrid') -> Right (f c, mGrid') 100 | 101 | instance Applicative (Parser c) where 102 | 103 | pure :: a -> Parser c a 104 | pure c = Parser $ \ _move mGrid -> Right (c, mGrid) 105 | 106 | (<*>) :: Parser c (a -> b) -> Parser c a -> Parser c b 107 | Parser f <*> Parser x = Parser $ \ move mGrid -> do 108 | (f', mGrid') <- f move mGrid 109 | (x', mGrid'') <- x move mGrid' 110 | pure (f' x', mGrid'') 111 | 112 | instance Monad (Parser c) where 113 | return = pure 114 | Parser p1 >>= f = Parser $ \ move mGrid -> do 115 | (c, mGrid') <- p1 move mGrid 116 | runParser (f c) move mGrid' 117 | fail message = Parser $ \ _move mGrid -> Left 118 | (maybe "out of bounds" (humanLocation . gridLocation) mGrid 119 | <> ": " <> message) 120 | 121 | instance Alternative (Parser c) where 122 | empty = fail "empty" 123 | Parser p1 <|> Parser p2 = Parser $ \ move grid -> case p1 move grid of 124 | Left{} -> p2 move grid 125 | success -> success 126 | 127 | instance MonadPlus (Parser c) where 128 | mzero = empty 129 | mplus = (<|>) 130 | 131 | -- | A parser that always fails. 132 | failure :: Parser c a 133 | failure = Parser $ \ _move mGrid -> Left 134 | (maybe "out of bounds" (humanLocation . gridLocation) mGrid 135 | <> ": generic parser failure") 136 | 137 | -- | Gets the current grid location. 138 | getLocation :: Parser c (Maybe Point) 139 | getLocation = Parser $ \ _move mGrid -> Right ((fmap gridLocation &&& id) mGrid) 140 | 141 | -- | Parser that returns the whole state of the grid. 142 | getGrid :: Parser c (Maybe (Grid c)) 143 | getGrid = Parser $ \ _move mGrid -> Right (mGrid, mGrid) 144 | 145 | -- | Teleports a parser to a new grid, typically (but not necessarily) one that 146 | -- was previously saved with 'getGrid'. 147 | setGrid :: Grid c -> Parser c () 148 | setGrid grid = Parser $ \ _move _grid -> Right ((), Just grid) 149 | -------------------------------------------------------------------------------- /lib/Toody/Point.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Box 3 | Description : A point in a grid. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | module Toody.Point 10 | ( Column 11 | , Point(..) 12 | , Row 13 | , humanLocation 14 | ) where 15 | 16 | import Data.Monoid ((<>)) 17 | 18 | -- | A point in a grid. 19 | data Point = Point !Row !Column 20 | deriving (Eq, Show) 21 | 22 | -- | Horizontal offset in cells. 23 | type Row = Int 24 | 25 | -- | Vertical offset in cells. 26 | type Column = Int 27 | 28 | -- | Converts a 'Point' to a human-readable prefix. 29 | humanLocation :: Point -> String 30 | humanLocation (Point row column) = show row <> ":" <> show column 31 | -------------------------------------------------------------------------------- /lib/Toody/Search.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Search 3 | Description : Parser combinators for searching in a grid. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | module Toody.Search 10 | ( everywhere 11 | , nearest 12 | ) where 13 | 14 | import Control.Comonad (Comonad(..)) 15 | import Toody.Parser (Parser(Parser)) 16 | 17 | -- | Runs a parser at every location on a grid and returns the list of 18 | -- successful results in north-to-south, west-to-east order. 19 | everywhere :: Parser c a -> Parser c [a] 20 | everywhere (Parser parse) = Parser $ \ move mGrid -> case mGrid of 21 | Nothing -> pure ([], Nothing) 22 | Just grid -> let 23 | possibilities = duplicate grid 24 | collectSuccess mc acc = case mc of 25 | Left{} -> acc 26 | Right (c, _) -> c : acc 27 | results = foldr collectSuccess [] (fmap (parse move . Just) possibilities) 28 | in Right (results, mGrid) 29 | 30 | -- | Runs a parser at each step in the current direction until it succeeds. 31 | -- Fails if the grid boundary is reached without a successful parse. 32 | nearest :: Parser c a -> Parser c a 33 | nearest (Parser parse) = Parser seek 34 | where 35 | seek move = go 36 | where 37 | go mGrid = case parse move mGrid of 38 | Right (result, mGrid') -> Right (result, mGrid') 39 | Left{} -> case mGrid of 40 | Nothing -> Left "cannot find nearest outside grid" 41 | Just grid -> case move grid of 42 | mGrid'@Just{} -> go mGrid' 43 | Nothing -> Left "got to edge of grid without finding nearest" 44 | -------------------------------------------------------------------------------- /lib/Toody/Size.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Size 3 | Description : The extents of a region in a grid. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | module Toody.Size 10 | ( Height 11 | , Size(..) 12 | , Width 13 | ) where 14 | 15 | -- | The extents of a region in a grid. 16 | data Size = Size !Width !Height 17 | deriving (Eq, Show) 18 | 19 | -- | Width in cells. Should be non-negative. 20 | type Width = Int 21 | 22 | -- | Height in cells. Should be non-negative. 23 | type Height = Int 24 | -------------------------------------------------------------------------------- /lib/Toody/Utils.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Utils 3 | Description : Internal utilities. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | module Toody.Utils 10 | ( iterateMaybe 11 | , iterateMaybeN 12 | ) where 13 | 14 | -- | Accumulates the results of repeatedly applying a function until it returns 15 | -- 'Nothing'. Returns @[]@ if the initial input is 'Nothing'. 16 | iterateMaybe :: (a -> Maybe a) -> Maybe a -> [a] 17 | iterateMaybe f = go 18 | where 19 | go (Just x) = x : go (f x) 20 | go Nothing = [] 21 | 22 | -- | 'iterateMaybeN n f' is 'iterateMaybe' limited to @n@ results. 23 | iterateMaybeN :: Int -> (a -> Maybe a) -> Maybe a -> [a] 24 | iterateMaybeN n f = take n . iterateMaybe f 25 | -------------------------------------------------------------------------------- /lib/Toody/Zipper.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Toody.Zipper 3 | Description : A 1D zipper representing a row of cells with a focus. 4 | Copyright : (c) Jon Purdy, 2017 5 | License : MIT 6 | Maintainer : evincarofautumn@gmail.com 7 | -} 8 | 9 | {-# LANGUAGE DeriveFoldable #-} 10 | {-# LANGUAGE DeriveFunctor #-} 11 | {-# LANGUAGE DeriveTraversable #-} 12 | 13 | module Toody.Zipper 14 | ( Zipper(..) 15 | , leftward 16 | , rightward 17 | , zipperFrom 18 | , zipperIndex 19 | , zipperLength 20 | ) where 21 | 22 | import Control.Comonad (Comonad(..)) 23 | import Data.Foldable (Foldable(..)) 24 | import Toody.Utils (iterateMaybeN) 25 | 26 | -- | A 1D zipper, representing a sequence of values with a focus. 27 | data Zipper a = Zipper 28 | { zipperBefore :: [a] 29 | , zipperCurrent :: a 30 | , zipperAfter :: [a] 31 | } deriving (Eq, Foldable, Functor, Traversable) 32 | 33 | -- | Motion within a zipper. 34 | leftward, rightward :: Zipper a -> Maybe (Zipper a) 35 | 36 | leftward (Zipper (p : b) c a) = Just (Zipper b p (c : a)) 37 | leftward _ = Nothing 38 | 39 | rightward (Zipper b c (n : a)) = Just (Zipper (c : b) n a) 40 | rightward _ = Nothing 41 | 42 | -- | Create a zipper from a list, using a default element as the focus if the 43 | -- list is empty. 44 | zipperFrom :: a -> [a] -> Zipper a 45 | zipperFrom _ (x : xs) = Zipper [] x xs 46 | zipperFrom p [] = Zipper [] p [] 47 | 48 | -- | Get the number of elements in a zipper. 49 | zipperLength :: Zipper a -> Int 50 | zipperLength z = length (zipperBefore z) + 1 + length (zipperAfter z) 51 | 52 | -- | Get the current cursor offset within a zipper, starting from 0. 53 | zipperIndex :: Zipper a -> Int 54 | zipperIndex = length . zipperBefore 55 | 56 | instance Comonad Zipper where 57 | extract = zipperCurrent 58 | duplicate z = let 59 | offset = zipperIndex z 60 | offset' = zipperLength z - offset - 1 61 | in Zipper 62 | { zipperBefore = reverse (iterateMaybeN offset leftward (leftward z)) 63 | , zipperCurrent = z 64 | , zipperAfter = iterateMaybeN offset' rightward (rightward z) 65 | } 66 | 67 | -- Debugging utilities. 68 | 69 | instance (Show a) => Show (Zipper a) where 70 | show z = concat 71 | [ unwords (map show (reverse (zipperBefore z))) 72 | , "(", show (zipperCurrent z), ")" 73 | , unwords (map show (zipperAfter z)) 74 | ] 75 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-8.13 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Control.Monad 3 | import Data.Char (isDigit, isLetter, isSpace) 4 | import Data.Foldable (asum) 5 | import Data.List (foldl') 6 | import Test.HUnit 7 | import Test.Hspec 8 | import Toody 9 | 10 | main :: IO () 11 | main = hspec spec 12 | 13 | spec :: Spec 14 | spec = do 15 | 16 | describe "parsing boxes" $ do 17 | 18 | it "parses a single ASCII box" $ do 19 | 20 | testParser asciiBox eastward 21 | [ "+----+" 22 | , "| |" 23 | , "| |" 24 | , "+----+" 25 | ] 26 | (Right (Box (Point 0 0) (Size 4 2))) 27 | 28 | it "parses a single Unicode box" $ do 29 | 30 | testParser lightBox eastward 31 | [ "┌───┐" 32 | , "│ │" 33 | , "└───┘" 34 | ] 35 | (Right (Box (Point 0 0) (Size 3 1))) 36 | 37 | it "finds and parses multiple boxes" $ do 38 | 39 | testParser (everywhere asciiBox) eastward 40 | [ " +----+" 41 | , " +---+ | |" 42 | , " | | +----+" 43 | , " +---+ " 44 | ] 45 | (Right [Box (Point 0 11) (Size 4 1), Box (Point 1 4) (Size 3 1)]) 46 | 47 | it "finds and parses multiple different Unicode boxes" $ do 48 | 49 | testParser (everywhere (lightBox <|> doubleBox)) eastward 50 | [ " ╔════╗" 51 | , " ┌───┐ ║ ║" 52 | , " │ │ ╚════╝" 53 | , " └───┘ " 54 | ] 55 | (Right [Box (Point 0 11) (Size 4 1), Box (Point 1 4) (Size 3 1)]) 56 | 57 | it "finds nearest box in a direction" $ do 58 | 59 | let 60 | grid = 61 | [ " ┌───┐" 62 | , " │ │" 63 | , "┌───┐└───┘" 64 | , "│ │ " 65 | , "└───┘ " 66 | ] 67 | 68 | testParser (nearest lightBox) southward grid 69 | (Right (Box (Point 2 0) (Size 3 1))) 70 | testParser (nearest lightBox) eastward grid 71 | (Right (Box (Point 0 5) (Size 3 1))) 72 | 73 | it "parses math expressions containing matrices" $ do 74 | 75 | let 76 | 77 | exp = eqExp 78 | 79 | eqExp = do 80 | a <- addExp 81 | lexeme (equal '=') 82 | b <- addExp 83 | pure (Equ1 a b) 84 | 85 | addExp = do 86 | a <- mulExp 87 | as <- many addSuffix 88 | pure (if null as then a else foldl' Add1 a as) 89 | 90 | addSuffix = lexeme (equal '+') *> mulExp 91 | 92 | mulExp = do 93 | a <- term 94 | as <- many mulSuffix 95 | pure (if null as then a else foldl' Mul1 a as) 96 | 97 | mulSuffix = lexeme (equal '*') *> term 98 | 99 | term = asum [par, lit, var, mat] 100 | 101 | lit = Lit1 . read <$> lexeme (some (satisfy isDigit)) 102 | 103 | var = Var1 <$> lexeme (some (satisfy isLetter)) 104 | 105 | -- Equations aren't allowed within expressions, so we use addExp, not exp. 106 | par = between (lexeme (equal '(')) (lexeme (equal ')')) addExp 107 | 108 | -- Parse a matrix at the current location by finding the height of its 109 | -- left bracket, collecting the corresponding number of rows of terms, 110 | -- then finding its right bracket and ensuring it matches the left. 111 | mat = lexeme $ do 112 | loc1 <- getLocation 113 | leftHeight <- length <$> lookahead (moving southward (some (equal '['))) 114 | step eastward <* spaces 115 | loc2 <- getLocation 116 | rows <- lookahead (replicateM leftHeight 117 | (lookahead ((,) <$> many term <*> getGrid) <* step southward)) 118 | let mEnd = snd (head rows) 119 | case mEnd of 120 | Nothing -> fail "expected end of matrix but got out of bounds" 121 | -- TODO: This pattern of saving & restoring location could have a 122 | -- cleaner API. 123 | Just grid -> setGrid grid 124 | spaces 125 | rightHeight <- length <$> lookahead (moving southward (some (equal ']'))) 126 | guard (leftHeight == rightHeight) 127 | step eastward 128 | pure (Mat1 (map fst rows)) 129 | 130 | lexeme = (<* spaces) 131 | spaces = many (satisfy isSpace) 132 | 133 | [va, vb, vc, vd, ve, vf, vg, vh] = Var1 . (:[]) <$> "abcdefgh" 134 | 135 | testParser exp eastward 136 | [ "a = a" 137 | ] 138 | (Right (Equ1 va va {- voom -})) 139 | 140 | testParser exp eastward 141 | [ "a + b = b + a" 142 | ] 143 | (Right (Equ1 (Add1 va vb) (Add1 vb va))) 144 | 145 | testParser exp eastward 146 | [ "(a) = (a)" 147 | ] 148 | (Right (Equ1 va va)) 149 | 150 | testParser exp eastward 151 | [ "a * b + c * d = d * c + b * a" 152 | ] 153 | (Right 154 | (Equ1 155 | (Add1 (Mul1 va vb) (Mul1 vc vd)) 156 | (Add1 (Mul1 vd vc) (Mul1 vb va)))) 157 | 158 | testParser exp eastward 159 | [ "[ a b ] = [ 1 0 ] " 160 | , "[ c d ] [ 0 1 ] " 161 | ] 162 | (Right 163 | (Equ1 164 | (Mat1 [[va, vb], [vc, vd]]) 165 | (Mat1 [[Lit1 1, Lit1 0], [Lit1 0, Lit1 1]]))) 166 | 167 | testParser exp eastward 168 | [ "[ a b ] + [ e f ] = [ 0 0 ]" 169 | , "[ c d ] [ g h ] [ 0 0 ]" 170 | ] 171 | (Right 172 | (Equ1 173 | (Add1 174 | (Mat1 [[va, vb], [vc, vd]]) 175 | (Mat1 [[ve, vf], [vg, vh]])) 176 | (Mat1 [[Lit1 0, Lit1 0], [Lit1 0, Lit1 0]]))) 177 | 178 | testParser exp eastward 179 | [ "[ a b ] + [ e f ] = [ (a + e) (b + f) ]" 180 | , "[ c d ] [ g h ] [ (c + g) (d + h) ]" 181 | ] 182 | (Right 183 | (Equ1 184 | (Add1 185 | (Mat1 [[va, vb], [vc, vd]]) 186 | (Mat1 [[ve, vf], [vg, vh]])) 187 | (Mat1 188 | [ [Add1 va ve, Add1 vb vf] 189 | , [Add1 vc vg, Add1 vd vh] 190 | ]))) 191 | 192 | testParser exp eastward 193 | [ "[ a b ] * [ e f ] = [ (a * e + b * g) (a * f + b * h) ]" 194 | , "[ c d ] [ g h ] [ (c * e + d * g) (c * f + d * h) ]" 195 | ] 196 | (Right 197 | (Equ1 198 | (Mul1 199 | (Mat1 200 | [ [va, vb] 201 | , [vc, vd] 202 | ]) 203 | (Mat1 204 | [ [ve, vf] 205 | , [vg, vh] 206 | ])) 207 | (Mat1 208 | [ [Add1 (Mul1 va ve) (Mul1 vb vg), Add1 (Mul1 va vf) (Mul1 vb vh)] 209 | , [Add1 (Mul1 vc ve) (Mul1 vd vg), Add1 (Mul1 vc vf) (Mul1 vd vh)] 210 | ]))) 211 | 212 | data Exp1 213 | = Add1 Exp1 Exp1 214 | | Mul1 Exp1 Exp1 215 | | Equ1 Exp1 Exp1 216 | | Lit1 Int 217 | | Var1 String 218 | | Mat1 [[Exp1]] 219 | deriving (Eq, Show) 220 | 221 | testParser 222 | :: (Eq a, Show a) 223 | => Parser Char a 224 | -> Move Char 225 | -> [[Char]] 226 | -> Either ParseError a 227 | -> Expectation 228 | testParser parser direction cells expected 229 | = (fst <$> runParser parser direction (Just (gridFrom ' ' cells))) 230 | `shouldBe` expected 231 | --------------------------------------------------------------------------------