diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/PArrows.cabal b/PArrows.cabal new file mode 100644 --- /dev/null +++ b/PArrows.cabal @@ -0,0 +1,28 @@ +Name: PArrows +Version: 0.1 +License: BSD3 +License-File: LICENSE +Author: Einar Karttunen +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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runghc + +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain diff --git a/src/Text/ParserCombinators/PArrow.hs b/src/Text/ParserCombinators/PArrow.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/PArrow.hs @@ -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 diff --git a/src/Text/ParserCombinators/PArrow/Char.hs b/src/Text/ParserCombinators/PArrow/Char.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/PArrow/Char.hs @@ -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) diff --git a/src/Text/ParserCombinators/PArrow/CharSet.hs b/src/Text/ParserCombinators/PArrow/CharSet.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/PArrow/CharSet.hs @@ -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 + diff --git a/src/Text/ParserCombinators/PArrow/Combinator.hs b/src/Text/ParserCombinators/PArrow/Combinator.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/PArrow/Combinator.hs @@ -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 diff --git a/src/Text/ParserCombinators/PArrow/MD.hs b/src/Text/ParserCombinators/PArrow/MD.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/PArrow/MD.hs @@ -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 diff --git a/src/Text/ParserCombinators/PArrow/Prim.hs b/src/Text/ParserCombinators/PArrow/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/PArrow/Prim.hs @@ -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 diff --git a/src/Text/ParserCombinators/PArrow/ToJavaScript.hs b/src/Text/ParserCombinators/PArrow/ToJavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/PArrow/ToJavaScript.hs @@ -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=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))