packages feed

PArrows (empty) → 0.1

raw patch · 10 files changed

+433/−0 lines, 10 filesdep +basedep +containersdep +mtlsetup-changed

Dependencies added: base, containers, mtl

Files

+ LICENSE view
@@ -0,0 +1,28 @@+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ PArrows.cabal view
@@ -0,0 +1,28 @@+Name:            PArrows+Version:         0.1+License:         BSD3+License-File:    LICENSE+Author:          Einar Karttunen <ekarttun@cs.helsinki.fi>+Stability:       Alpha+Category:        Parsing+Synopsis:        Arrow parser combinators similar to Parsec+Description:     PArrows is an arrows based parsing combinator library written in Haskell.+                 The library is similar to Parsec, but arrows allow for more future optimizations.+                 .+                 Currently PArrows is only tested with GHC, although making it work with Hugs should be easy.+Homepage:        http://www.cs.helsinki.fi/u/ekarttun/PArrows/+Build-Depends:   base>3, containers, mtl+Build-Type:      Simple+Tested-With:     GHC==6.8.2++Extensions:      FlexibleContexts, FunctionalDependencies, MagicHash, GADTs+Ghc-Options:     -O2 -Wall++Hs-Source-Dirs:  src+Exposed-Modules: Text.ParserCombinators.PArrow,+                 Text.ParserCombinators.PArrow.Char,+                 Text.ParserCombinators.PArrow.Combinator,+                 Text.ParserCombinators.PArrow.MD,+                 Text.ParserCombinators.PArrow.Prim,+                 Text.ParserCombinators.PArrow.ToJavaScript+Other-Modules:   Text.ParserCombinators.PArrow.CharSet
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runghc++> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain
+ src/Text/ParserCombinators/PArrow.hs view
@@ -0,0 +1,11 @@+module Text.ParserCombinators.PArrow +    (module Text.ParserCombinators.PArrow.Char,+     module Text.ParserCombinators.PArrow.Combinator,+     module Text.ParserCombinators.PArrow.MD,+     module Text.ParserCombinators.PArrow.Prim+    ) where++import Text.ParserCombinators.PArrow.Char+import Text.ParserCombinators.PArrow.Combinator+import Text.ParserCombinators.PArrow.MD(MD)+import Text.ParserCombinators.PArrow.Prim
+ src/Text/ParserCombinators/PArrow/Char.hs view
@@ -0,0 +1,51 @@+module Text.ParserCombinators.PArrow.Char where++import Control.Arrow+import Text.ParserCombinators.PArrow.CharSet+import Text.ParserCombinators.PArrow.MD+import Text.ParserCombinators.PArrow.Combinator++-- | Match a single given character and return it.+char :: Char -> MD i Char+char    = MEqual++-- | Match a character.+anyChar :: MD i Char+anyChar = MCSet CS_Any++-- | Match any character in the given list.+anyOf   :: [Char] -> MD i Char+anyOf   = MChoice . (map char)++-- | Match a digit (0..9)+digit   :: MD i Char+digit   = MCSet CS_Digit++-- | Match a letter.+letter  :: MD i Char+letter  = MCSet CS_Alpha++-- | Match a letter or a digit.+alnum  :: MD i Char+alnum   = MCSet CS_Alnum++-- | Match a 'word' character - (alnum or '_')+wordChar:: MD i Char+wordChar= MCSet CS_Word++-- | Match a word consisting of wordChars.+word   :: MD i String+word    = many1 wordChar++-- | Match a sequence of whitespace.+spaces :: MD i String+spaces  = many1 white++-- | Match a single whitespace character.+white  :: MD i Char+white   = MCSet (CS_Whitespace)++-- | Match a constant string.+string :: String -> MD i String+string []  = pure (\_ -> "")+string str = pure (\_ -> ' ') >>> foldr1 (>>>) (map char str) >>> pure (\_ -> str)
+ src/Text/ParserCombinators/PArrow/CharSet.hs view
@@ -0,0 +1,40 @@+module Text.ParserCombinators.PArrow.CharSet where++import Data.Char++-- | Character sets+data CharSet = CS_Any        -- ^ All characters+             | CS_Word       -- ^ alphanum and \'_\'+             | CS_Whitespace -- ^ whitespace+             | CS_Digit      -- ^ digits+             | CS_Alpha      -- ^ Alphabetical+             | CS_Alnum      -- ^ alpha or digit+             | CS_Ascii      -- ^ <=127+             | CS_Lower      -- ^ Lower+             | CS_Upper      -- ^ Upper+               deriving(Eq)++instance Show CharSet where+    show CS_Any        = "."+    show CS_Word       = "\\w"+    show CS_Whitespace = "\\s"+    show CS_Digit      = "\\d"+    show CS_Alpha      = "{alpha}"+    show CS_Alnum      = "{alnum}"+    show CS_Ascii      = "{ascii}"+    show CS_Lower      = "{lower}"+    show CS_Upper      = "{upper}"+++-- | List of the Chars contained in a CharSet.+csetValue :: CharSet -> [Char]+csetValue CS_Any = fmap chr [0..255]+csetValue CS_Word       = ('_':csetValue CS_Alnum)+csetValue CS_Whitespace = " \t\r\n"+csetValue CS_Digit      = "0123456789"+csetValue CS_Ascii      = fmap chr [0..127]+csetValue CS_Alpha      = filter isAlpha $ csetValue CS_Any+csetValue CS_Alnum      = csetValue CS_Digit ++ csetValue CS_Alpha+csetValue CS_Lower      = filter isLower $ csetValue CS_Alpha+csetValue CS_Upper      = filter isUpper $ csetValue CS_Alpha+
+ src/Text/ParserCombinators/PArrow/Combinator.hs view
@@ -0,0 +1,41 @@+module Text.ParserCombinators.PArrow.Combinator where++import Control.Arrow+import Text.ParserCombinators.PArrow.MD++-- | Match the empty string.+empty :: MD i o+empty = MEmpty++-- | Match zero or more occurences of the given parser.+many :: MD i o -> MD i [o]+many = MStar++-- | Match one or more occurences of the given parser.+many1 :: MD i o -> MD i [o]+many1 x = (x &&& MStar x) >>> pure (\(b,bs) -> (b:bs))++-- | Match if the given parser does not match.+notFollowedBy :: MD i o -> MD i o+notFollowedBy = MNot++-- | Match one or more occurences of the given parser separated by the sepator.+sepBy1 :: MD i o -> MD i o' -> MD i [o]+sepBy1 p s = (many (p &&& s >>^ fst) &&& p) >>^ (\(bs,b) -> bs++[b])++-- | Match the given parser n times.+count :: Int -> MD i o -> MD i [o]+count 1 prim  = prim >>^ (\x -> [x])+count k p = (p &&& count (k-1) p) >>^  (\(b,bs) -> (b:bs))++-- | Match the first, middle and last argument, returning the value from the middle one.+between :: MD i t -> MD t close -> MD t o -> MD i o+between open close real = open >>> (real &&& close) >>^ fst++-- | Match optionally.+optional :: MD i o -> MD i (Maybe o)+optional iarr = MChoice [iarr >>> MPure "Just" Just, MPure "const Nothing" (const Nothing)]++-- | Sequence two parsers and return the result of the first one.+(>>!) :: (Arrow a) => a b c -> a b c' -> a b c+a >>! b = (a &&& b) >>^ fst
+ src/Text/ParserCombinators/PArrow/MD.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE GADTs, MagicHash #-}++module Text.ParserCombinators.PArrow.MD (MD(..)) where++import Control.Arrow+import Data.List (intersperse)+import GHC.Prim (unsafeCoerce#)+import Text.ParserCombinators.PArrow.CharSet++data MD i o where+    MNot    :: MD i o -> MD i o+    MChoice :: [MD i o] -> MD i o+    MEqual  :: Char -> MD i Char+    MSeq    :: MD i t -> MD t o -> MD i o+    MStar   :: MD i o -> MD i [o]+    MEmpty  :: MD i o+    MPure   :: String -> (i->o) -> MD i o+    MCSet   :: CharSet -> MD i Char+    MParWire:: MD i1 o1 -> MD i2 o2 -> MD (i1,i2) (o1,o2)+    MJoin   :: MD i o1  -> MD i o2  -> MD i (o1,o2)++instance Eq (MD i o) where+    MNot a    == MNot b    = a == b+    MChoice a == MChoice b = a == b+    MEqual c  == MEqual d  = c == d+    MSeq a b  == MSeq c d  = a == force c && b == force d+    MStar a   == MStar b   = a == b+    MEmpty    == MEmpty    = True+    MPure s _ == MPure t _ = s == t+    MCSet s   == MCSet t   = s == t+    MParWire a b == MParWire c d = a == c && b == d+    MJoin a b == MJoin c d = a == c && b == d+    _         == _         = False++force :: MD a b -> MD c d+force = unsafeCoerce#++instance Arrow MD where+    arr f    = MPure "" f+    a >>> b  = a `MSeq` b+    a *** b  = a `MParWire` b+    a &&& b  = a `MJoin` b+    first a  = a `MParWire` ("id" `MPure` id)+    second b = ("id" `MPure` id) `MParWire` b++instance ArrowZero MD where+    zeroArrow = MEmpty++instance ArrowPlus MD where+    MChoice a <+> MChoice b = MChoice (a++b)+    a         <+> MChoice b = MChoice (a:b)+    a         <+> b         = MChoice [a,b]++++instance Show (MD i o) where+    show (MEqual c)    = if c `elem` ".[]{}|" then ['\\',c] else [c]+    show (MPure s _)   = show s+--    show (MPure s _)   = ""+    show (MCSet s)     = show s+    show (MNot p)      = "[^"++show p++"]"+    show (MChoice m)   = if all simple m+                           then "["++concatMap show m++"]"+                           else "(" ++ concat (intersperse "|" $ map show m) ++ ")"+    show (MSeq x (MStar y)) | x == force y = if simple x then show x ++ "+" else "("++show x++")+"+    show (MSeq a b)    = show a ++ show b+    show (MStar r)     = "("++show r++")*"+    show (MEmpty)      = ""+    show (MJoin a b)   = show a ++ " >> " ++ show b+    show (MParWire a b)= show a ++ " || " ++ show b++-- for formatting+simple :: MD i o -> Bool+simple (MPure _ _) = True+simple (MCSet _)   = True+simple (MEqual _)  = True+simple (MChoice m) = all simple m+simple _ = False
+ src/Text/ParserCombinators/PArrow/Prim.hs view
@@ -0,0 +1,53 @@+module Text.ParserCombinators.PArrow.Prim (runParser) where++import Text.ParserCombinators.PArrow.CharSet+import Text.ParserCombinators.PArrow.MD++type UserState= ()+type Location = ()+data PS char ustate = PS [char] ustate Location+data Res c u r = POk (PS c u) r | PErr [String]+type PSF c u r = PS c u -> Res c u r++optM :: MD i o -> PSF Char UserState o+optM = matcher++matcher :: MD i o -> PSF Char UserState o+matcher (MNot x)         i = case optM x i of+                              POk _ _  -> PErr ["not"]+                              PErr _   -> POk i undefined+matcher (MChoice l)      i = let mm []     = PErr ["no choice matches"]+                                 mm (c:cs) = case optM c i of+                                              POk s t -> POk s t+                                              _       -> mm cs+                             in mm l+matcher (MEqual c)      (PS (x:xs) u l) = if x == c then POk (PS xs u l) c else PErr ["expected "++[c]]+matcher (MSeq a b)       i = case optM a i of+                              POk s t -> case b of+                                          (MPure _ f) -> POk s (f t)+                                          _           -> optM b s+                              PErr e  -> PErr e+matcher (MStar x)        i = let p = optM x+                                 sm st acc = case p st of+                                              POk st' r -> sm st' (r:acc)+                                              PErr _    -> POk st (reverse acc)+                             in sm i []+matcher (MEmpty)        i = POk i (error "result for empty")+matcher (MPure _ _)     i = POk i (error "result for pure")+matcher (MCSet cs)     (PS (x:xs) u l) = if x `elem` csetValue cs then POk (PS xs u l) x else PErr ["Expected "++show cs]+matcher (MParWire _ _)  _ = error "matcher on ParWire"+matcher (MJoin a b)     i = case optM a i of+                              POk s t -> case optM b s of+                                          POk s' t' -> POk s' (t,t')+                                          PErr e'   -> PErr e'+                              PErr e  -> PErr e++matcher _              (PS [] _ _) = PErr ["eof"]+matcher _              _ = PErr ["unknown"]+++-- | Run a parser producing either a list of error messages or output.+runParser :: MD i o -> String -> Either [String] o+runParser md input = case optM md (PS input () ()) of+                      POk _ r -> Right r+                      PErr  e -> Left e
+ src/Text/ParserCombinators/PArrow/ToJavaScript.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE FlexibleContexts, MagicHash #-}++module Text.ParserCombinators.PArrow.ToJavaScript+    (JSCompiler, JSFun, newJSCompiler, compileJS, dumpBodies+    ) where++import Control.Monad.State+import Data.IORef+import Data.List (intersperse)+import GHC.Prim (unsafeCoerce#)+import qualified Data.IntMap as I+import System.Mem.StableName+import Text.ParserCombinators.PArrow.MD (MD(..))++-- | JSFun encapsulates a reference to a JavaScript function.+newtype JSFun = JSFun Int+-- | JSCompiler encapsulates the state of the JavaScript compiler.+newtype JSCompiler = JSC (IORef JSCompState)+type JSComp a = StateT JSCompState IO a+data INVALID = INVALID+type SN = StableName (MD INVALID INVALID)+data JSCompState = JSCompState { bodies :: I.IntMap String,+                                 defs :: I.IntMap [(SN,JSFun)],+                                 count :: Int,+                                 prefix :: String+                               }+-- | Create a new JavaScript compiler using the suplied string as prefix.+-- Returns the compiler and a function for showing function references.+newJSCompiler :: String -> IO (JSCompiler, JSFun -> String)+newJSCompiler pref = do c <- newIORef (JSCompState I.empty I.empty 1 pref)+                        return (JSC c, \(JSFun i) -> pref++show i)+-- | Compile a parser into JavaScript. Returns a reference to the top-level+-- Parsing function. The generated javascript function expects a String and+-- a starting index for parsing. The result will be either the index of the+-- rightmost character matched or -1 if the parser failed.+compileJS :: JSCompiler -> MD i o -> IO JSFun+compileJS (JSC jsc) p = do s <- readIORef jsc+                           (v,s') <- runStateT (toJavaScriptJSFun p) s+                           writeIORef jsc s'+                           return v++-- | Dump all bodies of generated JavaScript functions.+dumpBodies :: JSCompiler -> IO [(JSFun,String)]+dumpBodies (JSC jsc) = readIORef jsc >>= return . map (\(a,b) -> (JSFun a,b)) . I.toList . bodies++-- Implementation++toJavaScriptSingle :: JSFun -> MD i o -> JSComp String+toJavaScriptSingle n (MEqual ch) = cfun n ["{return (s.charAt(i)==",show ch,")?i+1:-1}"]+toJavaScriptSingle n (MEmpty)    = cfun n ["{return i}"]+toJavaScriptSingle n (MPure _ _) = toJavaScriptSingle n MEmpty+toJavaScriptSingle n (MSeq a b)  = do af <- toJavaScriptFunRef a+                                      bf <- toJavaScriptFunRef b+                                      cfun n ["{return ",bf,"(s,",af,"(s,i))}"]+toJavaScriptSingle n (MCSet cs)  = cfun n ["{return (s.charAt(i).search(/^",show cs,"/)!=-1?i+1:-1)}"]+toJavaScriptSingle n (MStar p)   = do pf <- toJavaScriptFunRef p+                                      cfun n ["{for(j=i;j>=0;){i=j;j=",pf,"(s,j)}return i}"]+toJavaScriptSingle n (MChoice cs)= do rfs <- mapM toJavaScriptFunRef cs+                                      cfun n ["{a=[",concat (intersperse "," rfs),"];",+                                              "for(j=0;j<a.length;j++){",+                                              "r=a[j](s,i);if(r>=0){return r}}",+                                              "return -1}"]+toJavaScriptSingle n (MJoin a b) = do af <- toJavaScriptFunRef a+                                      bf <- toJavaScriptFunRef b+                                      cfun n ["{return ",bf,"(s,",af,"(s,i))}"]+toJavaScriptSingle n (MNot p)    = do pf <- toJavaScriptFunRef p+                                      cfun n ["{return (",pf,"(s,i)>=0?-1:i)}"]+++cfun :: JSFun -> [String] -> JSComp String+cfun n lst = do cn <- jsFunName n+                return $ concat ("function ":cn:"(s,i) ":lst)++jsFunName :: (MonadState JSCompState m) => JSFun -> m String+jsFunName (JSFun v) = gets prefix >>= \e -> return (e ++ show v)++toJavaScriptFunRef :: MD i o -> JSComp String+toJavaScriptFunRef p = toJavaScriptJSFun p >>= jsFunName++toJavaScriptJSFun :: MD i o -> JSComp JSFun+toJavaScriptJSFun p = do+  cache <- gets defs+  psn <- makeSN p+  case I.lookup (hashStableName psn) cache >>= lookup psn of+   Nothing -> insertFunRef psn p+   Just x  -> return x++insertFunRef :: SN -> MD i o -> JSComp JSFun+insertFunRef psn p = do+  ci <- gets count+  modify (\s -> s { defs = I.insertWith (++) (hashStableName psn) [(psn,JSFun ci)] (defs s), count = ci+1 })+  pval <- toJavaScriptSingle (JSFun ci) p+  modify (\s -> s { bodies = I.insert ci pval (bodies s) })+  return (JSFun ci)++makeSN :: MD i o -> JSComp SN+makeSN md = liftIO (unsafeCoerce# (makeStableName md))