packages feed

sexp-grammar 1.2.0.1 → 1.2.1

raw patch · 9 files changed

+108/−58 lines, 9 files

Files

sexp-grammar.cabal view
@@ -1,5 +1,5 @@ name:                sexp-grammar-version:             1.2.0.1+version:             1.2.1 license:             BSD3 license-file:        LICENSE author:              Eugene Smolanka, Sergey Vinokurov
src/Control/Monad/ContextError.hs view
@@ -14,7 +14,6 @@   , MonadContextError (..)   ) where - #if MIN_VERSION_mtl(2, 2, 0) import Control.Monad.Except #else
src/Data/InvertibleGrammar.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE GADTs                 #-} {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}@@ -20,6 +21,9 @@   , pushForget   , InvertibleGrammar(..)   , GrammarError (..)+  , Mismatch+  , expected+  , unexpected   ) where  import Prelude hiding ((.), id)@@ -98,7 +102,7 @@     f t = a :- t     g (a' :- t)       | a == a' = Right t-      | otherwise = Left $ Mismatch mempty (Just "unexpected element")+      | otherwise = Left $ unexpected "pushed element"  -- | Same as 'push' except it does not check the value on stack during backward -- run. Potentially unsafe as it \"forgets\" some data.
src/Data/InvertibleGrammar/Generic.hs view
@@ -23,16 +23,18 @@   ) where  import Prelude hiding ((.), id)-import Control.Category ((.))+ import Control.Applicative+import Control.Category ((.))++import Data.Functor.Identity import Data.InvertibleGrammar-import Data.InvertibleGrammar.Monad+import Data.Monoid (First(..)) import Data.Profunctor (Choice(..)) import Data.Profunctor.Unsafe-import Data.Functor.Identity-import Data.Monoid (First(..)) import Data.Tagged-import Data.Set (singleton)+import Data.Text (pack)+ import GHC.Generics  -- | Provide a data constructor/stack isomorphism to a grammar working on@@ -55,7 +57,7 @@   in g (PartialIso          name          (fwd prism)-         (maybe (Left $ Mismatch (singleton name) Nothing) Right . bkwd prism))+         (maybe (Left $ expected (pack name)) Right . bkwd prism))  -- | Combine all grammars provided in 'Coproduct' list into a single grammar. match@@ -120,13 +122,11 @@   match' (P prism) (With g rest) =     let name = conName (undefined :: m c f e)         p = fwd prism-        q = maybe (Left $ Mismatch (singleton name) Nothing) Right . bkwd prism+        q = maybe (Left $ expected (pack name)) Right . bkwd prism     in (g $ PartialIso name p q, rest) - -- NB. The following machinery is heavily based on -- https://github.com/MedeaMelana/stack-prism/blob/master/Data/StackPrism/Generic.hs-  -- | Derive a list of stack prisms. For more information on the shape of a -- 'PrismList', please see the documentation below.
src/Data/InvertibleGrammar/Monad.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns     #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}  module Data.InvertibleGrammar.Monad   ( module Control.Monad.ContextError@@ -10,16 +11,23 @@   , runGrammarMonad   , Propagation   , GrammarError (..)-  , Mismatch (..)+  , Mismatch+  , expected+  , unexpected   ) where  import Control.Applicative+import Control.Monad.ContextError++import Data.Semigroup import Data.Set (Set) import qualified Data.Set as S-import Data.List (intercalate)-import Data.Semigroup-import Control.Monad.ContextError+import Data.Text (Text)+import qualified Data.Text.Lazy as TL +import Text.PrettyPrint.Leijen.Text+  (Pretty, pretty, text, vsep, indent, fillSep, punctuate, comma, (<+>))+ initPropagation :: p -> Propagation p initPropagation = Propagation [0] @@ -30,17 +38,44 @@  instance Eq (Propagation p) where   Propagation xs _ == Propagation ys _ = xs == ys+  {-# INLINE (==) #-}  instance Ord (Propagation p) where   compare (Propagation as _) (Propagation bs _) =     reverse as `compare` reverse bs   {-# INLINE compare #-} +-- | Data type to encode mismatches during parsing or generation, kept abstract.+-- It is suggested to use 'expected' and 'unexpected' constructors to build a+-- mismatch report. data Mismatch = Mismatch-  { mismatchExpected :: Set String-  , mismatchGot :: Maybe String+  { mismatchExpected :: Set Text+  , mismatchGot :: Maybe Text   } deriving (Show, Eq) +-- | Construct a mismatch report with specified expectation. Can be appended+-- to other expectations and 'unexpected' reports to clarify a mismatch.+expected :: Text -> Mismatch+expected a = Mismatch (S.singleton a) Nothing++-- | Construct a mismatch report with information what has been occurred during+-- processing but is not expected.+unexpected :: Text -> Mismatch+unexpected a = Mismatch S.empty (Just a)++instance Semigroup Mismatch where+  m <> m' =+    Mismatch+      (mismatchExpected m <> mismatchExpected m')+      (mismatchGot m <|> mismatchGot m')+  {-# INLINE (<>) #-}++instance Monoid Mismatch where+  mempty = Mismatch mempty mempty+  {-# INLINE mempty #-}+  mappend = (<>)+  {-# INLINE mappend #-}+ runGrammarMonad :: p -> (p -> String) -> ContextError (Propagation p) (GrammarError p) a -> Either String a runGrammarMonad initPos showPos m =   case runContextError m (initPropagation initPos) of@@ -48,18 +83,25 @@       Left $ renderMismatch (showPos (pPos p)) mismatch     Right a -> Right a -renderMismatch :: String -> Mismatch -> String-renderMismatch pos (Mismatch (S.toList -> expected) got) =-  unlines $-    [ pos ++ ": mismatch:"-    ] ++ case (expected, got) of-           ([], Nothing)    -> [ "unknown error happened" ]-           ([], Just got')  -> [ "unexpected: " ++ got' ]-           (_:_, Nothing)   -> [ "expected: " ++ intercalate ", " expected ]-           (_:_, Just got') -> [ "expected: " ++ intercalate ", " expected-                               , "     got: " ++ got'-                               ]+instance Pretty Mismatch where+  pretty (Mismatch (S.toList -> []) Nothing) =+    text "unknown mismatch occurred"+  pretty (Mismatch (S.toList -> expected) got) =+    vsep [ ppExpected expected+         , ppGot got+         ]+    where+      ppExpected []  = mempty+      ppExpected xs  = text "expected:" <+> fillSep (punctuate comma $ map (text . TL.fromStrict) xs)+      ppGot Nothing  = mempty+      ppGot (Just a) = text "     got:" <+> text (TL.fromStrict a) +renderMismatch :: String -> Mismatch -> String+renderMismatch pos mismatch =+  show $ vsep+    [ pretty pos `mappend` ":" <+> "mismatch:"+    , indent 2 $ pretty mismatch+    ]  data GrammarError p = GrammarError (Propagation p) Mismatch   deriving (Show)@@ -68,10 +110,8 @@   GrammarError pos m <> GrammarError pos' m'     | pos > pos' = GrammarError pos m     | pos < pos' = GrammarError pos' m'-    | otherwise  = GrammarError pos $-      Mismatch-        (mismatchExpected m <> mismatchExpected m')-        (mismatchGot m <|> mismatchGot m')+    | otherwise  = GrammarError pos (m <> m')+  {-# INLINE (<>) #-}  dive :: MonadContextError (Propagation p) e m => m a -> m a dive =@@ -96,5 +136,7 @@ {-# INLINE locate #-}  grammarError :: MonadContextError (Propagation p) (GrammarError p) m => Mismatch -> m a-grammarError mismatch = throwInContext (\ctx -> GrammarError ctx mismatch)+grammarError mismatch =+  throwInContext $ \ctx ->+    GrammarError ctx mismatch {-# INLINE grammarError #-}
src/Data/InvertibleGrammar/TH.hs view
@@ -6,9 +6,8 @@ import Control.Applicative #endif import Data.InvertibleGrammar-import Data.InvertibleGrammar.Monad import Data.Maybe-import Data.Set (singleton)+import Data.Text (pack) import Language.Haskell.TH as TH  @@ -65,7 +64,7 @@         [ Just $ TH.match gPat (normalB [e| Right ($gBody) |]) []         , if single           then Nothing-          else Just $ TH.match wildP (normalB [e| Left $ Mismatch (singleton $(stringE (show constructorName))) Nothing |]) []+          else Just $ TH.match wildP (normalB [e| Left (expected . pack $ $(stringE (show constructorName))) |]) []         ]    [e| PartialIso $(stringE (show constructorName)) $fFunc $gFunc |]
src/Language/SexpGrammar.hs view
@@ -94,6 +94,9 @@   -- * Parsing and encoding to Sexp   , parseSexp   , genSexp+  , Mismatch+  , expected+  , unexpected   -- * Typeclass for Sexp grammars   , SexpIso (..)   ) where
src/Language/SexpGrammar/Base.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}@@ -30,7 +31,6 @@ import Data.Monoid #endif import Data.Scientific-import Data.Set (singleton) import Data.Text (Text) import qualified Data.Text.Lazy as Lazy @@ -46,20 +46,20 @@ -- consumes nothing but generates some Sexp. type SexpG_ = forall t. Grammar SexpGrammar (Sexp :- t) t -unexpected :: (MonadContextError (Propagation Position) (GrammarError Position) m) => String -> m a-unexpected msg = grammarError $ Mismatch mempty (Just msg)+unexpectedStr :: (MonadContextError (Propagation Position) (GrammarError Position) m) => Text -> m a+unexpectedStr msg = grammarError $ unexpected msg -unexpectedSexp :: (MonadContextError (Propagation Position) (GrammarError Position) m) => String -> Sexp -> m a-unexpectedSexp expected sexp =-  grammarError $ Mismatch (singleton expected) (Just $ Lazy.unpack $ prettySexp' sexp)+unexpectedSexp :: (MonadContextError (Propagation Position) (GrammarError Position) m) => Text -> Sexp -> m a+unexpectedSexp exp got =+  grammarError $ expected exp `mappend` unexpected (Lazy.toStrict $ prettySexp' got)  unexpectedAtom :: (MonadContextError (Propagation Position) (GrammarError Position) m) => Atom -> Atom -> m a unexpectedAtom expected atom = do-  unexpectedSexp (Lazy.unpack $ prettySexp' (Atom dummyPos expected)) (Atom dummyPos atom)+  unexpectedSexp (Lazy.toStrict $ prettySexp' (Atom dummyPos expected)) (Atom dummyPos atom) -unexpectedAtomType :: (MonadContextError (Propagation Position) (GrammarError Position) m) => String -> Atom -> m a+unexpectedAtomType :: (MonadContextError (Propagation Position) (GrammarError Position) m) => Text-> Atom -> m a unexpectedAtomType expected atom = do-  unexpectedSexp ("atom of type " ++ expected) (Atom dummyPos atom)+  unexpectedSexp ("atom of type " `mappend` expected) (Atom dummyPos atom)   ----------------------------------------------------------------------@@ -176,8 +176,8 @@ parseSequence xs g t = do   (a, SeqCtx rest) <- runStateT (forward g t) (SeqCtx xs)   unless (null rest) $-    unexpected $ "leftover elements: " ++-      (Lazy.unpack $ Lazy.unwords $ map prettySexp' rest)+    unexpectedStr $ "leftover elements: " `mappend`+      (Lazy.toStrict $ Lazy.unwords $ map prettySexp' rest)   return a  data SeqGrammar a b where@@ -201,7 +201,7 @@     step     xs <- gets getItems     case xs of-      []    -> unexpected "end of sequence"+      []    -> unexpectedStr "end of sequence"       x:xs' -> do         modify $ \s -> s { getItems = xs' }         forward g (x :- t)@@ -224,16 +224,16 @@     props <- go xs M.empty     (res, PropCtx ctx) <- runStateT (forward g t) (PropCtx props)     when (not $ M.null ctx) $-      unexpected $ "property-list keys: " ++-        (Lazy.unpack $ Lazy.unwords $+      unexpectedStr $ "property-list keys: " `mappend`+        (Lazy.toStrict $ Lazy.unwords $           map (prettySexp' . Atom dummyPos . AtomKeyword) (M.keys ctx))     return res     where       go [] props = return props       go (Atom _ (AtomKeyword kwd):x:xs) props = step >> go xs (M.insert kwd x props)       go other _ =-        unexpected $ "malformed property-list: " ++-          (Lazy.unpack $ Lazy.unwords $ map prettySexp' other)+        unexpectedStr $ "malformed property-list: " `mappend`+          (Lazy.toStrict $ Lazy.unwords $ map prettySexp' other)    backward (GElem g) t = do     step@@ -282,8 +282,11 @@   forward (GProp kwd g) t = do     ps <- gets getProps     case M.lookup kwd ps of-      Nothing -> unexpected $-        "key " ++ (Lazy.unpack . prettySexp' . Atom dummyPos . AtomKeyword $ kwd) ++ " not found"+      Nothing -> unexpectedStr $+        mconcat [ "key "+                , Lazy.toStrict . prettySexp' . Atom dummyPos . AtomKeyword $ kwd+                , " not found"+                ]       Just x  -> do         put (PropCtx $ M.delete kwd ps)         forward g $ x :- t
test/Main.hs view
@@ -200,7 +200,7 @@     Right (Bar True (42 :: Int))   , testCase "sum of products (Baz True False) tries to parse (baz #f 10)" $     G.parseSexp sexpIso (List' [Symbol' "baz", Bool' False, Int' 10]) @?=-    (Left ("<no location information>:1:0: mismatch:\nexpected: atom of type bool\n     got: 10\n") :: Either String (Foo Bool Bool))+    (Left ("<no location information>:1:0: mismatch:\n  expected: atom of type bool\n       got: 10") :: Either String (Foo Bool Bool))   ]  testArithExpr :: ArithExpr