fix-parser-simple 15318.2 → 15319.1

raw patch · 3 files changed

+55/−25 lines, 3 filesdep +mmtl

Dependencies added: mmtl

Files

• Parser/Fix/Simple.hs +16/−23
• Util.hs +36/−0
• fix-parser-simple.cabal +3/−2

@@ -5,10 +5,13 @@  module Parser.Fix.Simple (TokenType (..), Fixity (..), parsefix, foldfix, shunt) where +import Control.Arrow; import Control.Monad;+import Control.Monad.State;+import Control.Monad.Writer.Lazy; import Control.Monad.Instances; import Data.List;-import Data.Maybe;+import Util;  -- | Fixity/Associativity data Fixity = Prefix | InfixLeft | InfixRight | InfixNull | Postfix deriving Eq;@@ -54,27 +57,17 @@ -} -- Dijkstra's algorithm shunt :: (t -> TokenType) -> [t] -> [t];-shunt lookup_t = join . snd . mapAccumR-  (\ stack t ->+shunt lookup_t = (.) (execWriter . flip runStateT []) $ (.) (>> (get >>= tell)) $+  (mapM_ $ \ t ->    case lookup_t t of {-     TokenPlain -> (stack, [t]);+     TokenPlain -> tell [t];      TokenOper fix1 p1 | or $ map (== fix1) [InfixLeft, InfixRight, InfixNull] ->-       case map lookup_t stack of {-         (TokenOper fix2 p2 : _) | fix1 == InfixLeft  && p1 <= p2 ||-                                   fix1 == InfixRight && p1 <  p2 ->-               (t : tail stack, [head stack]);-         _ ->  (t : id stack,   []);-       }-                       | Postfix == fix1 -> (  stack, [t])-                       | Prefix  == fix1 -> (t:stack, [])-                       ;-     TokenLParenth -> (t:stack, []);-     TokenRParenth -> case break ((== TokenLParenth) . lookup_t) stack of {-                        (ts, _:stack') -> (stack', ts);-                        (ts, _)        -> (error "Mismatched Parentheses", ts);-                      };-   }) [];--list :: (a -> [a] -> b) -> b -> [a] -> b;-list f y []     = y;-list f y (x:xs) = f x xs;+       get >>* span (lookup_t >>>+                     \ (TokenOper fix2 p2) ->+                     fix1 == InfixLeft  && p1 <= p2 ||+                     fix1 == InfixRight && p1 <  p2) >>= tell *=* put . (t:) >>* uncurry mappend+                       | Postfix == fix1 -> tell [t]+                       | Prefix  == fix1 -> modify (t:);+     TokenLParenth -> modify (t:);+     TokenRParenth -> get >>* break ((== TokenLParenth) . lookup_t) >>= tell *=* list (const put) (put $ error "Mismatched Parentheses") >>* uncurry mappend;+   });

@@ -0,0 +1,36 @@+module Util where++import Control.Arrow;+import Control.Monad;++list :: (a -> [a] -> b) -> b -> [a] -> b;+list f y []     = y;+list f y (x:xs) = f x xs;++swap :: (a,b) -> (b,a);+swap (x,y) = (y,x);++infixr 3 &=&;+(&=&) :: Monad m => (a -> m b) -> (a -> m c) -> a -> m (b, c);+(&=&) = curry $ uncurry (&&&) >>> (uncurry (liftM2 (,)) .);++infixr 3 *=*;+(*=*) :: Monad m => (a -> m b) -> (c -> m d) -> (a, c) -> m (b, d);+(*=*) = curry $ uncurry (***) >>> (uncurry (liftM2 (,)) .);++applyA :: ArrowApply a => a b (a b c) -> a b c;+applyA = (&&& (arr id)) >>> (>>> app);++apM :: Monad m => m (a -> m b) -> a -> m b;+apM = fmap join . (. return) . ap;++infixr 1 >*>;+(>*>) :: Monad m => (a -> m b) -> (b -> c) -> a -> m c;+f >*> g = f >=> return . g;++infixl 1 >>*;+(>>*) :: Monad m => m a -> (a -> b) -> m b;+(>>*) = flip liftM;++(<<) :: Monad m => m a -> m b -> m a;+(<<) = flip (>>);

@@ -1,5 +1,5 @@ Name:fix-parser-simple-Version:15318.2+Version:15319.1 Description:Simple fix-expression parser License:LGPL License-File:license.txt@@ -11,7 +11,8 @@ Cabal-Version: >= 1.2  Library {-  Build-Depends: base >= 4 && < 5+  Build-Depends: base >= 4 && < 5, mmtl   Extensions: PatternGuards   Exposed-Modules: Parser.Fix.Simple+  Other-Modules: Util }