pattern-arrows (empty) → 0.0.1

raw patch · 4 files changed

+162/−0 lines, 4 filesdep +basedep +mtlsetup-changed

Dependencies added: base, mtl

Files

• LICENSE +20/−0
• Setup.lhs +6/−0
• pattern-arrows.cabal +23/−0
• src/Control/PatternArrows.hs +113/−0

@@ -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.

@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+

@@ -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:

@@ -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