summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE20
-rw-r--r--Setup.lhs6
-rw-r--r--pattern-arrows.cabal23
-rw-r--r--src/Control/PatternArrows.hs113
4 files changed, 162 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..87b8a3c
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+The MIT License (MIT)
+
+Copyright (c) 2013 Phil Freeman
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+the Software, and to permit persons to whom the Software is furnished to do so,
+subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..a630405
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,6 @@
+#!/usr/bin/runhaskell
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+
diff --git a/pattern-arrows.cabal b/pattern-arrows.cabal
new file mode 100644
index 0000000..13e9805
--- /dev/null
+++ b/pattern-arrows.cabal
@@ -0,0 +1,23 @@
+name: pattern-arrows
+version: 0.0.1
+cabal-version: >=1.4
+build-type: Simple
+license: MIT
+license-file: LICENSE
+synopsis: Arrows for Pretty Printing
+description: A library for generating concise pretty printers based on precedence rules.
+copyright: (c) Phil Freeman 2013
+maintainer: Phil Freeman <paf31@cantab.net>
+stability: experimental
+category: Text, Combinators, Pretty Printer
+author: Phil Freeman <paf31@cantab.net>
+data-dir: ""
+homepage: http://blog.functorial.com/posts/2013-10-27-Pretty-Printing-Arrows.html
+
+library
+ build-depends: base >=4 && <5, mtl -any
+ exposed-modules: Control.PatternArrows
+ exposed: True
+ buildable: True
+ hs-source-dirs: src
+ other-modules:
diff --git a/src/Control/PatternArrows.hs b/src/Control/PatternArrows.hs
new file mode 100644
index 0000000..c42d5d6
--- /dev/null
+++ b/src/Control/PatternArrows.hs
@@ -0,0 +1,113 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Control.PatternArrows
+-- Copyright : (c) Phil Freeman 2013
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- Arrows for Pretty Printing
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
+
+module Control.PatternArrows where
+
+import Data.Char
+import Control.Monad.State
+import qualified Control.Category as C
+import Control.Category ((>>>))
+import qualified Control.Arrow as A
+import Control.Arrow ((***), (<+>))
+
+-- |
+-- A first-order pattern match
+--
+-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
+--
+newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
+
+instance Functor (Pattern u a) where
+ fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
+
+-- |
+-- Run a pattern with an input and initial user state
+--
+-- Returns Nothing if the pattern fails to match
+--
+pattern :: Pattern u a b -> u -> a -> Maybe b
+pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
+
+-- |
+-- Construct a pattern from a function
+--
+mkPattern :: (a -> Maybe b) -> Pattern u a b
+mkPattern f = Pattern $ A.Kleisli (lift . f)
+
+-- |
+-- Construct a pattern from a stateful function
+--
+mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
+mkPattern' = Pattern . A.Kleisli
+
+-- |
+-- Construct a pattern which recursively matches on the left-hand-side
+--
+chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
+chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
+
+-- |
+-- Construct a pattern which recursively matches on the right-hand side
+--
+chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
+chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
+
+-- |
+-- Construct a pattern which recursively matches on one-side of a tuple
+--
+wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
+wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
+
+-- |
+-- Construct a pattern which matches a part of a tuple
+--
+split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
+split s f = s >>> A.arr (uncurry f)
+
+-- |
+-- A table of operators
+--
+data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
+
+-- |
+-- An operator:
+--
+-- [@AssocL@] A left-associative operator
+--
+-- [@AssocR@] A right-associative operator
+--
+-- [@Wrap@] A prefix-like or postfix-like operator
+--
+-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
+--
+data Operator u a r where
+ AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
+ AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
+ Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
+ Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
+
+-- |
+-- Build a pretty printer from an operator table and an indecomposable pattern
+--
+buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
+buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
+ case op of
+ AssocL pat g -> chainl pat g p'
+ AssocR pat g -> chainr pat g p'
+ Wrap pat g -> wrap pat g p'
+ Split pat g -> split pat g
+ ) <+> p') p $ runOperatorTable table