packages feed

definitive-parser (empty) → 1.0

raw patch · 6 files changed

+510/−0 lines, 6 filesdep +arraydep +basedep +bytestring

Dependencies added: array, base, bytestring, containers, cpu, deepseq, definitive-base, primitive, utf8-string, vector

Files

+ Algebra/Parser.hs view
@@ -0,0 +1,183 @@+-- |A module providing simple Parser combinator functionality. Useful+-- for small parsing tasks such as identifier parsing or command-line+-- argument parsing+module Algebra.Parser (+  module Algebra,+  -- * The ParserT Type+  ParserT(..),Parser,ParserA(..),_ParserA,++  -- ** The Stream class+  Stream(..),emptyStream,++  -- ** Converting to/from Parsers+  parserT,parser,ioParser,++  -- * Basic combinators+  (<+>),(>*>),(<*<),+  token,satisfy,+  oneOf,noneOf,single,+  several,+  remaining,eoi,++  -- ** Specialized utilities+  readable,number,digit,letter,alNum,quotedString,space,spaces,eol,+  +  -- * Basic combinators+  many,many1,sepBy,sepBy1,skipMany,skipMany1,+  chainl,chainr,option                   +  ) where++import Algebra++import Data.Char+import Data.Containers.Sequence++newtype ParserT s m a = ParserT (StateT s (ListT m) a)+                        deriving (Unit,Functor,Applicative,Monoid,Semigroup,+                                  Monad,MonadFix,MonadList,MonadState s,MonadWriter w)+type Parser c a = ParserT c Id a+deriving instance Monad m => MonadError Void (ParserT c m)+instance MonadTrans (ParserT s) where+  lift = ParserT . lift . lift+instance ConcreteMonad (ParserT s) where+  generalize = parserT %%~ map (pure.yb _Id)+_ParserT :: Iso (ParserT s m a) (ParserT t n b) (StateT s (ListT m) a) (StateT t (ListT n) b)+_ParserT = iso ParserT (\(ParserT p) -> p)+parserT :: (Functor n,Functor m) => Iso (ParserT s m a) (ParserT t n b) (s -> m [(s,a)]) (t -> n [(t,b)])+parserT = mapping listT.stateT._ParserT+parser :: Iso (Parser s a) (Parser t b) (s -> [(s,a)]) (t -> [(t,b)])+parser = mapping _Id.parserT++ioParser :: Parser a b -> (a -> IO b)+ioParser p s = case (p^..parser) s of+  [] -> error "Error in parsing"+  (_,a):_ -> return a++-- |The @(+)@ operator with lower priority+(<+>) :: Semigroup m => m -> m -> m+(<+>) = (+)+(>*>) :: Monad m => ParserT a m b -> ParserT b m c -> ParserT a m c+(>*>) = (>>>)^..(_ParserA<.>_ParserA<.>_ParserA)+(<*<) :: Monad m => ParserT b m c -> ParserT a m b -> ParserT a m c+(<*<) = flip (>*>)++newtype ParserA m s a = ParserA (ParserT s m a)+_ParserA :: Iso (ParserA m s a) (ParserA m' s' a') (ParserT s m a) (ParserT s' m' a')+_ParserA = iso ParserA (\(ParserA p) -> p)+parserA :: Iso (ParserA m s a) (ParserA m' s' a') (StateA (ListT m) s a) (StateA (ListT m') s' a') +parserA = from stateA._ParserT._ParserA+instance Monad m => Category (ParserA m) where+  id = ParserA get+  (.) = (.)^.(parserA<.>parserA<.>parserA)+instance Monad m => Split (ParserA m) where+  (<#>) = (<#>)^.(parserA<.>parserA<.>parserA)+instance Monad m => Choice (ParserA m) where+  (<|>) = (<|>)^.(parserA<.>parserA<.>parserA)+instance Monad m => Arrow (ParserA m) where+  arr f = arr f^.parserA++-- |The remaining Stream to parse+remaining :: Monad m => ParserT s m s+remaining = get+-- |Consume a token from the Stream+token :: (Monad m,Stream c s) => ParserT s m c+{-# SPECIALIZE token :: Monad m => ParserT [c] m c #-}+token = get >>= \s -> case uncons s of+  Nothing -> zero+  Just (c,t) -> put t >> pure c++-- |Parse zero, one or more successive occurences of a parser.+many :: Monad m => ParserT c m a -> ParserT c m [a]+many p = many1 p <+> pure []+-- |Parse one or more successiveé occurences of a parser.+many1 :: Monad m => ParserT c m a -> ParserT c m [a]+many1 p = (:)<$>p<*>many p+-- |Skip many occurences of a parser+skipMany :: Monad m => ParserT c m a -> ParserT c m ()+skipMany p = skipMany1 p <+> pure () +-- |Skip multiple occurences of a parser+skipMany1 :: Monad m => ParserT c m a -> ParserT c m ()+skipMany1 p = p >> skipMany p++-- |Consume a token and succeed if it verifies a predicate+satisfy :: (Monad m, Stream c s) => (c -> Bool) -> ParserT s m c+{-# SPECIALIZE satisfy :: Monad m => (c -> Bool) -> ParserT [c] m c #-}+satisfy p = token <*= guard . p+-- |Consume a single fixed token or fail.+single :: (Eq c, Monad m, Stream c s) => c -> ParserT s m ()+single = void . satisfy . (==)++-- |Consume a structure of characters or fail+several :: (Eq c, Monad m, Foldable t, Stream c s) => t c -> ParserT s m ()+{-# SPECIALIZE several :: (Eq c, Monad m) => [c] -> ParserT [c] m () #-}+several l = traverse_ single l++-- |Try to consume a parser. Return a default value when it fails.+option :: Monad m => a -> ParserT s m a -> ParserT s m a+option a p = p+pure a++-- |Succeed only if we are by the End Of Input.+eoi :: (Monad m,Stream c s) => ParserT s m ()+eoi = remaining >>= guard.emptyStream+-- |The end of line+eol :: (Monad m,Stream Char s) => ParserT s m ()+eol = single '\n'++-- |Parse one or more successive occurences of a parser separated by+-- occurences of a second parser.+sepBy1 ::Monad m => ParserT c m a -> ParserT c m b -> ParserT c m [a]+sepBy1 p sep = (:)<$>p<*>many (sep >> p)+-- |Parse zero or more successive occurences of a parser separated by+-- occurences of a second parser.+sepBy ::Monad m => ParserT c m a -> ParserT c m b -> ParserT c m [a]+sepBy p sep = option [] (sepBy1 p sep)++-- |Parse a member of a set of values+oneOf :: (Eq c, Monad m, Foldable t, Stream c s) => t c -> ParserT s m c+oneOf = satisfy . flip elem+-- |Parse anything but a member of a set+noneOf :: (Eq c, Monad m, Foldable t, Stream c s) => t c -> ParserT s m c+noneOf = satisfy . map not . flip elem++-- |Parse a litteral decimal number+number :: (Monad m,Stream Char s,Num n) => ParserT s m n+number = fromInteger.read <$> many1 digit+-- |Parse a single decimal digit+digit :: (Monad m,Stream Char s) => ParserT s m Char+digit = satisfy isDigit+alNum :: (Monad m,Stream Char s) => ParserT s m Char+alNum = satisfy isAlphaNum+letter :: (Monad m,Stream Char s) => ParserT s m Char+letter = satisfy isAlpha+-- |Parse a delimited string, unsing '\\' as the quoting character+quotedString :: (Monad m,Stream Char s) => Char -> ParserT s m String+quotedString d = between (single d) (single d) (many ch)+  where ch = single '\\' >> unquote<$>token+             <+> noneOf (d:"\\")+        unquote 'n' = '\n'+        unquote 't' = '\t'+        unquote c = c+-- |A single space+space :: (Monad m,Stream Char s) => ParserT s m Char+space = satisfy isSpace+-- |Many spaces+spaces :: (Monad m,Stream Char s) => ParserT s m String+spaces = many1 space++infixl 1 `sepBy`,`sepBy1`+infixr 0 <+>++-- |Chain an operator with an initial value and several tail values.+chainr :: (Stream c s,Monad m) => ParserT s m a -> ParserT s m (b -> a -> a) -> ParserT s m b -> ParserT s m a+chainr expr op e = compose<$>many (op<**>e)<*>expr+-- |Chain an operator with an initial value+chainl :: (Stream c s,Monad m) => ParserT s m a -> ParserT s m (a -> b -> a) -> ParserT s m b -> ParserT s m a+chainl expr op e = compose<$>many (flip<$>op<*>e)<**>expr++-- |Test if a Stream is empty+emptyStream :: Stream c s => s -> Bool+emptyStream = maybe True (const False) . uncons++readable :: (Monad m,Read a) => ParserT String m a +readable = generalize $ map2 swap (readsPrec 0)^.parser+
+ Algebra/Parser/Regex.hs view
@@ -0,0 +1,29 @@+module Algebra.Parser.Regex (regex,runRegex) where++import Algebra.Parser++runRegex :: String -> String -> [([(String,String)],String)]+runRegex re = join (pure re >*> regex)^..parser <&> map snd++regex :: Parser String (Parser String ([(String,String)],String))+regex = _union+  where _union = (adjacent`sepBy`single '|') <&> sum+        adjacent = many postfixed <&> map concat.sequence+        atom = dot <+> range <+> otherChar <+> between (single '(') (single ')') _union+        postfixed = comp<$>atom<*>many postfun+          where postfun = satisfy (`elem`"*+?") <&> \c -> case c of+                  '*' -> map sum.many+                  '+' -> map sum.many1+                  '?' -> (+ pure ([],""))+                  _ -> undefined+                comp a fs = compose fs a+        dot = shallow token <$ single '.'+        otherChar = shallow.char<$>noneOf "()[*?|+"+        range = between (single '[') (single ']') ranges+          where ranges = sum <$> many subRange+                subRange = mkRange<$>subChar<*single '-' <*>subChar+                           <+> shallow.char<$>subChar+                mkRange a b = shallow $ satisfy (\c -> c>=a && c<=b)+                subChar = noneOf "]"+        shallow = (([],).pure<$>)+        char c = c<$single c
+ Data/Serialize.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}+module Data.Serialize (+  -- * You'll need this+  module Algebra.Parser,+  +  -- * Serialization+  Serializable(..),Builder,bytesBuilder,chunkBuilder,serialize,serial,+  -- ** Convenience functions+  word8,Word8,Word32,Word64,Either3(..),+  ) where++import Algebra.Parser hiding (uncons)+import Data.ByteString.Lazy.Builder+import qualified Data.ByteString as BSS+import qualified Data.ByteString.Lazy as BS+import Data.ByteString.Unsafe +import Data.Word+import Foreign.Ptr+import Foreign.Storable+import qualified Data.Monoid as M+import System.Endian+import Data.Bits (shiftR,shiftL)+import Data.Containers+import Data.ByteString.Lazy.UTF8 (uncons)++class Serializable t where+  encode :: t -> Builder+  serializable :: Parser Bytes t ++serialize :: Serializable t => t -> Bytes+serialize = toLazyByteString . encode++serial :: (Serializable t,Serializable t') => Traversal t t' Bytes Bytes+serial = prism (serializable^.from parser & \f a -> map snd (foldr (const . Right) (Left a) (f a))) (const serialize)++bytesBuilder :: Bytes:<->:Builder+bytesBuilder = iso lazyByteString toLazyByteString+chunkBuilder :: Chunk:<->:Builder+chunkBuilder = iso byteString (by chunk.toLazyByteString)++instance Semigroup Word8 ; instance Monoid Word8+instance Semigroup Word32 ; instance Monoid Word32+instance Semigroup Word64 ; instance Monoid Word64++instance Semigroup Builder where (+) = M.mappend+instance Monoid Builder where zero = M.mempty++withChunk :: Chunk -> (Ptr b -> IO a) -> a+withChunk b f = unsafeUseAsCString b (f . castPtr)^.thunk++storable :: forall a. Storable a => Parser Bytes a+storable = p^.parser+  where p s | BSS.length ch >= sz = pure (t,res)+            | otherwise = zero+          where res = withChunk ch peek :: a+                (h,t) = BS.splitAt (fromIntegral sz) s+                ch = h^.chunk+                sz = sizeOf res+  +instance Serializable Char where+  encode = charUtf8+  serializable = gets uncons >>= \case+    Just (c,t) -> c <$ put t+    Nothing -> zero+instance Serializable Word8 where+  encode = word8+  serializable = storable+instance Serializable Word32 where+  encode = word32BE+  serializable = fromBE32<$>storable+instance Serializable Word64 where+  encode = word64BE+  serializable = fromBE64<$>storable+instance Serializable Int where+  encode n = encode (size bytes :: Word8) + foldMap (encode . w8) bytes+    where bytes = takeWhile (>0) $ iterate (`shiftR`8) n+          w8 = fromIntegral :: Int -> Word8+  serializable = serializable >>= \n -> do+    bytes <- sequence (serializable <$ [1..n :: Word8])+    return $ sum (zipWith shiftL (map (fromIntegral :: Word8 -> Int) bytes) [0,8..])+instance Serializable Integer where+  encode n = encode s + foldMap (word8 . fromIntegral) (take s l)+    where l = iterate (`shiftR`8) (if n>=0 then n else (-n))+          s = length (takeWhile (/=0) l)+  serializable = do+    n <- serializable+    doTimes n serializable <&> sum . zipWith (\sh b -> fromIntegral (b :: Word8)`shiftL`sh) [0,8..]+instance Serializable a => Serializable (Maybe a) where+  encode (Just a) = word8 1 + encode a+  encode Nothing = word8 0+  serializable = serializable >>= \w -> case w :: Word8 of+    0 -> return Nothing+    1 -> Just<$>serializable+    _ -> error "Invalid encoding for Maybe serialized value"+instance Serializable a => Serializable [a] where+  encode l = encode (length l) + foldMap encode l+  serializable = serializable >>= \n -> doTimes n serializable+instance (Ord k,Serializable k,Serializable a) => Serializable (Map k a) where+  encode m = encode (m^.keyed & toList)+  serializable = serializable <&> fromList+instance (Ord k,Ord a,Serializable k,Serializable a) => Serializable (Bimap k a) where+  encode m = encode (toMap m^.keyed & toList)+  serializable = serializable <&> fromList+instance (Ord a,Serializable a) => Serializable (Set a) where+  encode = encode . toList+  serializable = serializable <&> fromList . map (,zero)+instance (Serializable a,Serializable b) => Serializable (a:*:b) where+  encode (a,b) = encode a+encode b+  serializable = (,)<$>serializable<*>serializable+instance (Serializable a,Serializable b,Serializable c) => Serializable (a,b,c) where+  encode (a,b,c) = encode a+encode b+encode c+  serializable = (,,)<$>serializable<*>serializable<*>serializable+instance (Serializable a,Serializable b,Serializable c,Serializable d) => Serializable (a,b,c,d) where+  encode (a,b,c,d) = encode a+encode b+encode c+encode d+  serializable = (,,,)<$>serializable<*>serializable<*>serializable<*>serializable+instance (Serializable a,Serializable b,Serializable c,Serializable d,Serializable e) => Serializable (a,b,c,d,e) where+  encode (a,b,c,d,e) = encode a+encode b+encode c+encode d+encode e+  serializable = (,,,,)<$>serializable<*>serializable<*>serializable<*>serializable<*>serializable+instance (Serializable a,Serializable b) => Serializable (a:+:b) where+  encode (Left a) = word8 0+encode a+  encode (Right b) = word8 1+encode b+  serializable = storable >>= \x -> case x :: Word8 of+    0 -> Left<$>serializable+    1 -> Right<$>serializable+    _ -> zero++data Either3 a b c = Alt3_1 a | Alt3_2 b | Alt3_3 c+instance (Serializable a,Serializable b,Serializable c) => Serializable (Either3 a b c) where+  encode (Alt3_1 a) = word8 0+encode a+  encode (Alt3_2 b) = word8 1+encode b+  encode (Alt3_3 c) = word8 2+encode c+  serializable = storable >>= \x -> case x :: Word8 of+    0 -> Alt3_1<$>serializable+    1 -> Alt3_2<$>serializable+    2 -> Alt3_3<$>serializable+    _ -> zero
+ Data/Syntax.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE UndecidableInstances, LambdaCase, ParallelListComp, ViewPatterns #-}+module Data.Syntax where++import Algebra+import Data.Containers+import qualified Prelude as P+import Algebra.Parser.Regex++type Env f = Map String (ThunkT f)+type Eval f = Env f -> ThunkT f+type ThunkT f = f (SyntaxT f)+data SyntaxT f = ValList [ThunkT f]+              | Dictionary (Env f)+              | Text String+              | Function (ThunkT f -> ThunkT f)+instance Show (ThunkT f) => Show (SyntaxT f) where+  show (ValList l) = show l+  show (Dictionary d) = "{"+show (toList (map show d^.keyed))+"}"+  show (Text t) = show t+  show (Function _) = "<fun>"++dict :: Traversal' (SyntaxT f) (Env f)+dict = prism f g+  where f (Dictionary d) = Right d+        f c = Left c+        g (Dictionary _) d = Dictionary d+        g x _ = x++nil :: SyntaxT f+nil = ValList zero+variable :: Unit f => String -> SyntaxT f -> SyntaxT f+variable n v = Dictionary (fromList [("name",pure $ Text n),("value",pure v)])+funcall :: ThunkT f -> ThunkT f -> SyntaxT f+funcall f x = ValList [f,x]++reduce :: MonadReader (Env m) m => SyntaxT m -> ThunkT m+reduce (ValList (map (>>= reduce) -> (fun:args))) = fun >>= \f -> foldlM call f args+  where call (Function f) x = f x+        call _ _ = error "Invalid function call"+reduce (Dictionary d) = pure $ Dictionary $ fix (\d' -> map (local (d'+) . (>>= reduce)) d)+reduce a = pure a++list_ :: [a] -> [a]+list_ = id+lambda :: MonadReader (Env m) m => SyntaxT Id -> SyntaxT m -> (ThunkT m -> ThunkT m)+lambda pat e = tryAlt+  where tryAlt x = x >>= match >>= maybe (pure nil) bind+          where bind vars = local (compose (_insert<$>list_ vars)) (reduce e)+                  where _insert (s,v) = insert s (pure v)+                match = matchPat pat+matchPat :: Monad f => SyntaxT Id -> (SyntaxT f -> f (Maybe [(String,SyntaxT f)]))+matchPat (Text re) = pure.matchText+  where matchText (Text t) | ((a,wh):_) <- match t = pure $ map2 Text (("&",wh):a)+        matchText _ = zero+        match = runRegex re+matchPat (Dictionary d) = matchDict+  where matchDict (Dictionary d') = +          traverse (matches d') (toList pats) <&> map concat.sequence+        matchDict _ = pure zero+        pats = (matchPat.yb _Id<$>d)^.keyed+        matches d' (k,m) = maybe (pure zero) (>>= m) (d'^.at k)+matchPat (ValList l) = matchList+  where n = length l+        matchList (ValList l') | length (take n l') == n =+          sequence [matchPat p =<< e | p <- yb _Id<$>l | e <- l'] <&> map concat.sequence+        matchList _ = pure zero+matchPat _ = pure (pure zero)++lambdaSum :: Monad m => [ThunkT m -> ThunkT m] -> ThunkT m -> ThunkT m+lambdaSum = foldr combine (const (pure nil))+  where combine f g = \v -> f v >>= \case+          ValList [] -> g v+          x -> pure x+
+ LICENSE view
@@ -0,0 +1,69 @@+Bill and Ted's Public License+=============================++Everyone is permitted to copy and distribute verbatim or modified+copies of this license document, and changing it is allowed as long as+the name of the license is changed.++PREAMBLE+--------++The “Greater Lunduke License” is inspired, in part, by the wisdom of+the Two Great Ones, Bill S. Preston, Esq. and Ted “Theodore” Logan.+Namely that we should all “be excellent to each other”, that being+“bogus” is “most non-triumphant” and that all dudes should “party on”.++This license applies those concepts in such a way that it is+applicable to all forms of content, including, but not limited to:+software, books, music, movies and various works of art.++TERMS AND CONDITIONS+--------------------++### 1. Be Excellent To Each Other.++The consumer of this work is granted the right to utilize this work in+conjunction with any mechanism that is capable of utilizing it, in the+form supplied by the content creator, without limitation as to+specific hardware or software.++The consumer of this work may make copies of this work (physical or+otherwise) for backup purposes.++The consumer of this work may lend this work to another individual+provided that the following two conditions are met :+  +  1. the lender no longer utilizes or possesses the work+  2. the work is not presently lent to another individual++The consumer of this work may sell this work to another individual+provided that the following two conditions are met :++  1. the seller no longer utilizes or possesses the work +  2. once the work is sold, the seller relinquishes all rights and+      copies of the work to the buyer.++### 2. Don’t Be Bogus.++The consumer of this work shall not redistribute modified, or+unmodified, copies of this work without explicit written permission+from the creator of this work.  The only exceptions allowed to this+rule are the provisions outlined in section 1 of this license++The consumer of this work shall not hold the creator of this work+liable for anything the consumer does, or does not, do, or the results+of utilizing this work.++### 3. Party On, Dudes!++The creator of this work provides the work in a form that contains no+mechanism to disable the utilization of the work after a specific+date, period of time or number of uses.++If additional works, which are created and wholly owned by the work’s+creator, are required to utilize this work, those additional works+must also be made available to the consumer so long as the following+conditions are met :+  +  1. doing so is possible+  2. doing so does not cause harm to the creator of the work.
+ definitive-parser.cabal view
@@ -0,0 +1,19 @@+name:          definitive-parser+version:       1.0++synopsis:      A parser combinator library for the Definitive framework+description:   +author:        Marc Coiffier+maintainer:    marc.coiffier@gmail.com+license:       OtherLicense+license-file:  LICENSE++build-type:    Simple+cabal-version: >=1.10++library+  exposed-modules: Algebra.Parser Data.Syntax Algebra.Parser.Regex Data.Serialize+  build-depends: base (== 4.6.*), definitive-base (== 1.0.*), containers (== 0.5.*), deepseq (== 1.3.*), array (== 0.5.*), bytestring (== 0.10.*), vector (== 0.10.*), primitive (== 0.5.*), cpu (== 0.1.*), utf8-string (== 0.3.*)+  default-extensions: TypeSynonymInstances NoMonomorphismRestriction StandaloneDeriving GeneralizedNewtypeDeriving TypeOperators RebindableSyntax FlexibleInstances FlexibleContexts FunctionalDependencies TupleSections MultiParamTypeClasses Rank2Types+  ghc-options: -Wall -fno-warn-orphans -threaded+  default-language: Haskell2010