definitive-parser 1.2 → 2.1

raw patch · 7 files changed

+228/−106 lines, 7 filesdep +GLURawdep +OpenGLdep +OpenGLRawdep ~basedep ~definitive-basePVP ok

version bump matches the API change (PVP)

Dependencies added: GLURaw, OpenGL, OpenGLRaw, ghc-prim

Dependency ranges changed: base, definitive-base

API changes (from Hackage documentation)

Files

• Data/Serialize.hs +27/−4
• Data/Syntax.hs +43/−76
• Data/Syntax/Node.hs +125/−0
• Language/Parser.hs +19/−16
• Language/Syntax/CmdArgs.hs +4/−4
• Language/Syntax/Regex.hs +2/−2
• definitive-parser.cabal +8/−4

@@ -7,9 +7,13 @@   Serializable(..),Builder,bytesBuilder,chunkBuilder,serialize,serial,   -- ** Convenience functions   word8,Word8,Word32,Word64,Either3(..),++  -- * GND replacement for GHC 7.8+  coerceEncode,coerceSerializable   ) where  import Definitive+import qualified Prelude as P import Language.Parser hiding (uncons) import Data.ByteString.Lazy.Builder import qualified Data.ByteString as BSS@@ -22,11 +26,17 @@ import System.Endian import Data.Bits (shiftR,shiftL) import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import Unsafe.Coerce  class Serializable t where   encode :: t -> Builder   serializable :: Parser Bytes t  +coerceEncode :: forall t t'. Serializable t => (t -> t') -> (t' -> Builder)+coerceEncode _ = unsafeCoerce (encode :: t -> Builder)+coerceSerializable :: forall t t'. Serializable t => (t -> t') -> (Parser Bytes t')+coerceSerializable = unsafeCoerce (serializable :: Parser Bytes t)+ serialize :: Serializable t => t -> Bytes serialize = toLazyByteString . encode @@ -41,6 +51,18 @@ instance Semigroup Word8 ; instance Monoid Word8 instance Semigroup Word32 ; instance Monoid Word32 instance Semigroup Word64 ; instance Monoid Word64+instance Semiring Word8 where (*) = (P.*)+instance Ring Word8 where one = 1+instance Semiring Word32 where (*) = (P.*)+instance Ring Word32 where one = 1+instance Semiring Word64 where (*) = (P.*)+instance Ring Word64 where one = 1+instance Disjonctive Word8 where+  negate = P.negate ; (-) = (P.-)+instance Disjonctive Word32 where+  negate = P.negate ; (-) = (P.-)+instance Disjonctive Word64 where+  negate = P.negate ; (-) = (P.-)  instance Semigroup Builder where (+) = M.mappend instance Monoid Builder where zero = M.mempty@@ -97,14 +119,15 @@   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+  serializable = serializable <&> fromAList instance (Ord k,Ord a,Serializable k,Serializable a) => Serializable (Bimap k a) where   encode m = encode (toMap m^.keyed & toList)-  serializable = serializable <&> fromList+  serializable = serializable <&> fromAList instance (Ord a,Serializable a) => Serializable (Set a) where   encode = encode . toList-  serializable = serializable <&> fromList . map (,zero)-deriving instance Serializable a => Serializable (Range a)+  serializable = serializable <&> fromAList . map (,zero)+instance Serializable a => Serializable (Range a) where+  encode = coerceEncode Range ; serializable = coerceSerializable Range instance (Serializable a,Serializable b) => Serializable (a:*:b) where   encode (a,b) = encode a+encode b   serializable = (,)<$>serializable<*>serializable

@@ -1,87 +1,54 @@-{-# LANGUAGE UndecidableInstances, LambdaCase, ParallelListComp, ViewPatterns #-}+{-# LANGUAGE UndecidableInstances, LambdaCase, ParallelListComp, ViewPatterns, ImpredicativeTypes #-} module Data.Syntax where  import Definitive-import qualified Prelude as P-import Language.Syntax.Regex -type Env f = Map String (ThunkT f)-type ThunkT f = f (SyntaxT f)-data SyntaxT f = ValList [ThunkT f]-              | Dictionary (Env f)-              | Text String-              | Quote (SyntaxT f)-              | 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 (Quote s) = "'"+show s-  show (Function _) = "<fun>"+newtype Lambda n m = Lambda (Maybe String,ThunkT n m () -> ThunkT n m ())+instance Show (Lambda n m) where+  show (Lambda (b,_)) = show b+instance Semigroup (Lambda n m) where+  Lambda (_,f) + Lambda (_,g) = Lambda (Nothing,g.f) -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+class (Foldable (n (Lambda n m)),Traversable (n (Lambda n m))) => NodeFunctor n m  -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]-builtin :: Unit m => (ThunkT m -> ThunkT m) -> ThunkT m-builtin = pure . Function-builtin2 :: Unit m => (ThunkT m -> ThunkT m -> ThunkT m) -> ThunkT m-builtin2 = builtin . map builtin-builtin3 :: Unit m => (ThunkT m -> ThunkT m -> ThunkT m -> ThunkT m) -> ThunkT m-builtin3 = builtin . map builtin2+newtype SyntaxT n m a = SyntaxT (Free (n (Lambda n m)) a)+                      deriving Unit+deriving instance NodeFunctor n m => Functor (SyntaxT n m)+deriving instance NodeFunctor n m => Applicative (SyntaxT n m)+instance NodeFunctor n m => Monad (SyntaxT n m) where join = coerceJoin SyntaxT+deriving instance NodeFunctor n m => Foldable (SyntaxT n m)+instance NodeFunctor n m => Traversable (SyntaxT n m) where sequence = coerceSeq SyntaxT+instance MonadFree (n (Lambda n m)) (SyntaxT n m) where+  step = coerceStep SyntaxT ; perform = coercePerform SyntaxT ; liftF = coerceLiftF SyntaxT -shape :: SyntaxT f -> String-shape (ValList []) = "Nil"-shape (ValList _) = "ValList"-shape (Text _) = "Text"-shape (Dictionary _) = "Dictionary"-shape (Quote _) = "Quote"-shape (Function _) = "Function"+newtype ThunkT n m a = ThunkT (Free (m:.:SyntaxT n m) a)+                        deriving Unit -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 (Quote s) = pure s-reduce a = pure a+deriving instance (NodeFunctor n m,Functor m) => Functor (ThunkT n m)+deriving instance (NodeFunctor n m,Functor m) => Applicative (ThunkT n m)+deriving instance (NodeFunctor n m,Foldable m) => Foldable (ThunkT n m)+type Thunk n a = ThunkT n Id a+instance (NodeFunctor n m,Monad m) => Monad (ThunkT n m) where join = coerceJoin ThunkT+instance (NodeFunctor n m,Traversable m) => Traversable (ThunkT n m) where sequence = coerceSeq ThunkT+instance (NodeFunctor n m,Monad m) => MonadFree (m:.:SyntaxT n m) (ThunkT n m) where+  step = coerceStep ThunkT ; perform = coercePerform ThunkT ; liftF = coerceLiftF ThunkT+deriving instance (NodeFunctor n m,MonadReader r m) => MonadReader r (ThunkT n m)+deriving instance (NodeFunctor n m,MonadState s m) => MonadState s (ThunkT n m)+deriving instance (NodeFunctor n m,MonadWriter w m) => MonadWriter w (ThunkT n m) -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<$>c'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 i'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 i'Id<$>l | e <- l'] <&> map concat.sequence-        matchList _ = pure zero-matchPat _ = pure (pure zero)+type NodeT n m a = n (Lambda n m) (ThunkT n m a) -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+force :: (NodeFunctor n m,Monad m) => ThunkT n m a -> ThunkT n m (NodeT n m a)+force = liftF . force'+  where force' t = emerge (step t) >>= \(SyntaxT s) -> case s of+          Pure t' -> force' t'+          Join j -> pure (liftS . SyntaxT<$>j)+forcing :: (NodeFunctor n m,Monad m) => (NodeT n m a -> ThunkT n m a) -> ThunkT n m a -> ThunkT n m a+forcing f x = force x >>= f +liftN :: (NodeFunctor n m,Unit m) => NodeT n m a -> SyntaxT n m (ThunkT n m a)+liftN = SyntaxT . liftF+liftS :: (NodeFunctor n m,Unit m) => SyntaxT n m (ThunkT n m a) -> ThunkT n m a+liftS = ThunkT . Join . Compose . pure . map (\(ThunkT t) -> t)+liftNS :: (NodeFunctor n m,Unit m) => NodeT n m a -> ThunkT n m a+liftNS = liftS . liftN

@@ -0,0 +1,125 @@+{-# LANGUAGE LambdaCase #-}+module Data.Syntax.Node (+  module Data.Syntax,++  Node(..),ThunkN,Env,nil,shape,dict,++  funcall,builtin,builtin2,builtin3,lambda,lambdaSum,++  reduce+  ) where++import Definitive+import Data.Syntax+import Language.Syntax.Regex++data Node k b a = ValList [a]+                | Dictionary (Map k a)+                | Quote (Node k b a)+                | Text k+                | Function b+type Env k m = Map k (ThunkT (Node k) m ())++instance Functor (Node k b) where+  map f (ValList l) = ValList (map f l)+  map f (Dictionary d) = Dictionary (map f d)+  map f (Quote s) = Quote (map f s)+  map _ (Text k) = Text k+  map _ (Function f) = Function f+instance Foldable (Node k b) where+  fold (ValList l) = fold l+  fold (Dictionary d) = fold d+  fold (Quote a) = fold a+  fold _ = zero+instance Eq k => Traversable (Node k b) where+  sequence (ValList l) = ValList<$>sequence l+  sequence (Dictionary d) = Dictionary<$>sequence d+  sequence (Quote a) = Quote<$>sequence a+  sequence (Text k) = pure (Text k)+  sequence (Function f) = pure (Function f)+instance Eq k => NodeFunctor (Node k) m+instance (Show k,Show b,Show a) => Show (Node k b a) where+  show (ValList l) = show l+  show (Dictionary d) = "{"+show (toList (map show d^.keyed))+"}"+  show (Text t) = show t+  show (Quote s) = "'"+show s+  show (Function f) = show f++type ThunkN k m = ThunkT (Node k) m ()++nil :: SyntaxT (Node k) m a+nil = SyntaxT (Join (ValList zero))+funcall :: (Eq k,Unit m) => ThunkT (Node k) m a -> ThunkT (Node k) m a -> ThunkT (Node k) m a+funcall f x = liftNS (ValList [f,x])+builtin :: (Eq k,Unit m) => (ThunkN k m -> ThunkN k m) -> ThunkN k m+builtin f = liftNS (Function (Lambda (Nothing,f)))+builtin2 :: (Eq k,Unit m) => (ThunkN k m -> ThunkN k m -> ThunkN k m) -> ThunkN k m+builtin2 f = builtin (\a -> builtin (f a))+builtin3 :: (Eq k,Unit m) => (ThunkN k m -> ThunkN k m -> ThunkN k m -> ThunkN k m) -> ThunkN k m+builtin3 f = builtin (\a -> builtin2 (f a))++dict :: Traversal' (Node k b a) (Map k a)+dict = prism f g+  where f (Dictionary d) = Right d+        f c = Left c+        g (Dictionary _) d = Dictionary d+        g x _ = x+shape :: Node k b a -> String+shape (ValList []) = "Nil"+shape (ValList _) = "ValList"+shape (Text _) = "Text"+shape (Dictionary _) = "Dictionary"+shape (Quote _) = "Quote"+shape (Function _) = "Function"++reduce :: (Ord k,MonadReader (Env k m) m) => ThunkN k m -> ThunkN k m+reduce th = force th >>= \v -> case v of+  ValList (fun:args) -> foldl' (\f a -> force f >>= call a) fun args+  Dictionary d -> liftNS $ Dictionary $ fix (\d' -> map (local (d'+) . reduce) d)+  Quote n -> liftNS n+  a -> liftNS a+  where call x f = case f of+          Function (Lambda (_,f')) -> f' x+          _  -> error "Invalid function call"++class (Ord k,Monoid k) => Matching k where+  matchRe :: k -> k -> Maybe [(k,k)]+instance Matching String where+  matchRe re = \s -> case match s of+    ((x,_):_) -> Just x+    _ -> Nothing+    where match = runRegex re++lambda :: (Matching k,MonadReader (Env k m) m) => ThunkN k m -> ThunkN k m -> ThunkN k m+lambda pat e = liftF (emerge (perform pat)) >>= tryAlt+  where tryAlt p = builtin b+          where b x = match x >>= maybe (liftS nil) bind+                bind vars = local (compose (_insert<$>c'list vars)) (reduce e)+                  where _insert (s,v) = insert s v+                match = matchPat p++matchPat :: (Monad m,Matching k) => SyntaxT (Node k) m () -> ThunkN k m -> ThunkT (Node k) m (Maybe [(k,ThunkN k m)])+matchPat (SyntaxT (Join j)) = case j of+  Dictionary d -> \x -> force x >>= \n -> case n of+    Dictionary d' | keysSet d == keysSet d' -> do+      let f (k,s') v = map2 ((k,v):) (matchPat (SyntaxT s') v)+      map join . sequence <$> sequence (toList (zipWith f (d^.keyed) d'))+    _ -> pure Nothing+  ValList l -> \x -> force x >>= \n -> case n of+    ValList l' | length l' == length l -> +      map join . sequence <$> sequence (zipWith (matchPat . SyntaxT) l l')+    _ -> pure Nothing+  Text k -> \x -> force x >>= \n -> case n of+    Text k' | Just ks <- matchRe k k' ->+      pure (Just . map (second (liftNS . Text)) $ ks)+    _ -> pure Nothing+  _ -> \_ -> pure Nothing+matchPat _ = \_ -> pure Nothing+      +lambdaSum :: (Eq k,Monad m) => [ThunkN k m -> ThunkN k m] -> ThunkN k m -> ThunkN k m+lambdaSum = foldr combine (const (liftS nil))+  where combine f g = \v -> force (f v) >>= \case+          ValList [] -> g v+          x -> liftNS x++

@@ -4,7 +4,7 @@ module Language.Parser (   module Definitive,   -- * The ParserT Type-  ParserT(..),Parser,ParserA(..),_ParserA,+  ParserT(..),Parser,ParserA(..),i'ParserA,    -- ** The Stream class   Stream(..),emptyStream,@@ -32,19 +32,21 @@ import Data.Char import Data.Containers.Sequence -newtype ParserT s m a = ParserT (StateT s (ListT m) a)+newtype ParserT s m a = ParserT (StateT s (LogicT m) a)                         deriving (Unit,Functor,Semigroup,Monoid,Applicative,-                                  Monad,MonadFix,MonadList,MonadState s,MonadWriter w)+                                  MonadFix,MonadState s)+instance (Monad m,Stream Char s) => IsString (ParserT s m a) where+  fromString s = undefined <$ several s+instance Monad m => Monad (ParserT s m) where join = coerceJoin ParserT 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 i'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+i'ParserT :: Iso (ParserT s m a) (ParserT t n b) (StateT s (LogicT m) a) (StateT t (LogicT n) b)+i'ParserT = iso ParserT (\(ParserT p) -> p)+parserT :: (Monad n,Monad m) => Iso (ParserT s m a) (ParserT t n b) (s -> m [(s,a)]) (t -> n [(t,b)])+parserT = mapping listLogic.stateT.i'ParserT parser :: Iso (Parser s a) (Parser t b) (s -> [(s,a)]) (t -> [(t,b)]) parser = mapping i'Id.parserT @@ -57,20 +59,21 @@ (<+>) :: Semigroup m => m -> m -> m (<+>) = (+) (>*>) :: Monad m => ParserT a m b -> ParserT b m c -> ParserT a m c-(>*>) = (>>>)^..(_ParserA<.>_ParserA<.>_ParserA)+(>*>) = (>>>)^..(i'ParserA<.>i'ParserA<.>i'ParserA) (<*<) :: Monad m => ParserT b m c -> ParserT a m b -> ParserT a m c (<*<) = flip (>*>) cut :: Monad m => ParserT s m a -> ParserT s m a cut = parserT %%~ map2 (take 1)  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+i'ParserA :: Iso (ParserA m s a) (ParserA m' s' a') (ParserT s m a) (ParserT s' m' a')+i'ParserA = iso ParserA (\(ParserA p) -> p)+parserA :: Iso (ParserA m s a) (ParserA m' s' a') (StateA (LogicT m) s a) (StateA (LogicT m') s' a') +parserA = from stateA.i'ParserT.i'ParserA+instance Monad m => Deductive (ParserA m) where+  (.) = (.)^.(parserA<.>parserA<.>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@@ -86,7 +89,7 @@ {-# SPECIALIZE token :: Monad m => ParserT [c] m c #-} token = get >>= \s -> case uncons s of   Nothing -> zero-  Just (c,t) -> put t >> pure c+  Just (c,t) -> c <$ put t  -- |Parse zero, one or more successive occurences of a parser. many :: Monad m => ParserT c m a -> ParserT c m [a]@@ -151,7 +154,7 @@ 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+-- |Parse a delimited string, using '\\' 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

@@ -16,10 +16,10 @@ -- |Create a Parser that preprocesses the command-line arguments, -- splitting options and their arguments into a user-defined data -- type.-tokenize :: [OptDescr a] -> (String -> a) -> ParserT [String] (WriterT String Id) [a]-tokenize options wrap = p^.mapping writer.parserT-  where p a = (concat err,pure (a,bs))-          where (bs,_,err) = getOpt (ReturnInOrder wrap) options a+tokenize :: Monad m => [OptDescr a] -> (String -> a) -> ParserT [String] m [a]+tokenize options wrap = p^.parserT+  where p a = pure (pure (a,bs))+          where (bs,_,_) = getOpt (ReturnInOrder wrap) options a  {- $tutorial 

@@ -21,8 +21,8 @@                 comp a fs = compose fs a         dot = shallow token <$ single '.'         otherChar = shallow.char<$>noneOf "()[*?|+"-        range = between (single '[') (single ']') t'ranges-          where t'ranges = shallow . satisfy <$> (option id (map not <$ single '^')+        range = between (single '[') (single ']') t'i'ranges+          where t'i'ranges = shallow . satisfy <$> (option id (map not <$ single '^')                                                 <*> (many subRange <&> \rs c -> any ($c) rs))                 subRange = mkRange<$>subChar<*single '-' <*>subChar                            <+> (==)<$>subChar

@@ -2,22 +2,26 @@ name:          definitive-parser category:      Parsers synopsis:      A parser combinator library for the Definitive framework-description:   +homepage:      http://coiffier.net/projects/definitive-framework.html+description: + -- meta-information author:        Marc Coiffier maintainer:    marc.coiffier@gmail.com-version:       1.2+version:       2.1 license:       OtherLicense license-file:  LICENSE  -- build information build-type:    Simple cabal-version: >=1.10+tested-with:   GHC (== 7.8.3)  library-  exposed-modules: Data.Serialize Language.Parser Data.Syntax Language.Syntax.Regex Language.Syntax.CmdArgs-  build-depends: base (== 4.6.*), definitive-base (== 1.2.*), 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.*)+  exposed-modules: Data.Serialize Language.Parser Language.Syntax.CmdArgs Data.Syntax Data.Syntax.Node Language.Syntax.Regex+  build-depends: base (== 4.7.*), ghc-prim (== 0.3.*), GLURaw (== 1.4.*), OpenGL (== 2.9.*), OpenGLRaw (== 1.5.*), definitive-base (== 2.3.*), 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+  include-dirs: