packages feed

mello 0.5.0 → 0.6.0

raw patch · 4 files changed

+246/−19 lines, 4 filesdep +hashabledep ~bowtie

Dependencies added: hashable

Dependency ranges changed: bowtie

Files

mello.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           mello-version:        0.5.0+version:        0.6.0 synopsis:       No-fuss syntax with s-expressions description:    Please see the README on GitHub at <https://github.com/ejconlon/mello#readme> category:       Parsing@@ -70,9 +70,10 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds   build-depends:       base >=4.12 && <5-    , bowtie ==0.7.*+    , bowtie ==0.8.*     , containers >=0.6 && <0.8     , foldl ==1.4.*+    , hashable >=1.4 && <1.6     , looksee ==0.8.*     , mtl >=2.3 && <2.5     , prettyprinter ==1.7.*@@ -120,10 +121,11 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N   build-depends:       base >=4.12 && <5-    , bowtie ==0.7.*+    , bowtie ==0.8.*     , containers >=0.6 && <0.8     , daytripper ==1.0.*     , foldl ==1.4.*+    , hashable >=1.4 && <1.6     , looksee ==0.8.*     , looksee-trip ==0.8.*     , mello
src/Mello/Match.hs view
@@ -1,7 +1,22 @@ {-# LANGUAGE UndecidableInstances #-}  module Mello.Match-  ( MatchErr (..)+  ( ExpectElem (..)+  , Expect (..)+  , expectSym+  , expectAnySym+  , expectAnyInt+  , expectAnySci+  , expectAnyStr+  , expectAnyChar+  , expectAnyAtom+  , expectList+  , expectQuote+  , expectUnquote+  , expectDoc+  , expectDesc+  , displayExpect+  , MatchErr (..)   , LocMatchErr (..)   , MatchT   , MatchM@@ -19,6 +34,7 @@   , restM   , repeatM   , remainingM+  , peekM   , altM   , anySymM   , symM@@ -45,21 +61,129 @@  import Bowtie (Anno (..), Memo (..), mkMemo, unMkMemo, pattern MemoP) import Bowtie qualified as B-import Control.Exception (Exception)+import Control.Exception (Exception (..)) import Control.Monad (ap, unless) import Control.Monad.Except (ExceptT, MonadError (..), runExceptT) import Control.Monad.Identity (Identity (..)) import Control.Monad.Reader (MonadReader (..), ReaderT (..), ask, asks, local) import Control.Monad.State (MonadState (..), StateT, runStateT) import Control.Monad.Trans (MonadTrans (..))+import Data.Foldable (toList)+import Data.List (intercalate) import Data.Proxy (Proxy) import Data.Scientific (Scientific) import Data.Sequence (Seq (..)) import Data.Sequence qualified as Seq-import Data.Text (Text)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text, unpack) import Data.Typeable (Typeable) import Mello.Syntax (Atom (..), AtomType (..), Brace, Doc, Sexp (..), SexpF (..), SexpType (..), Sym (..)) +-- | Defunctionalized expectation element describing what a matcher branch expects.+data ExpectElem+  = ExpectSym !Sym+  | ExpectAnySym+  | ExpectAnyInt+  | ExpectAnySci+  | ExpectAnyStr+  | ExpectAnyChar+  | ExpectAnyAtom+  | ExpectList !Brace+  | ExpectQuote+  | ExpectUnquote+  | ExpectDoc+  | ExpectDesc !Text+  deriving stock (Eq, Ord, Show)++newtype Expect = Expect {unExpect :: Set ExpectElem}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Semigroup, Monoid)++expectSym :: Sym -> Expect+expectSym = Expect . Set.singleton . ExpectSym++expectAnySym :: Expect+expectAnySym = Expect (Set.singleton ExpectAnySym)++expectAnyInt :: Expect+expectAnyInt = Expect (Set.singleton ExpectAnyInt)++expectAnySci :: Expect+expectAnySci = Expect (Set.singleton ExpectAnySci)++expectAnyStr :: Expect+expectAnyStr = Expect (Set.singleton ExpectAnyStr)++expectAnyChar :: Expect+expectAnyChar = Expect (Set.singleton ExpectAnyChar)++expectAnyAtom :: Expect+expectAnyAtom = Expect (Set.singleton ExpectAnyAtom)++expectList :: Brace -> Expect+expectList = Expect . Set.singleton . ExpectList++expectQuote :: Expect+expectQuote = Expect (Set.singleton ExpectQuote)++expectUnquote :: Expect+expectUnquote = Expect (Set.singleton ExpectUnquote)++expectDoc :: Expect+expectDoc = Expect (Set.singleton ExpectDoc)++expectDesc :: Text -> Expect+expectDesc = Expect . Set.singleton . ExpectDesc++displayExpect :: Expect -> String+displayExpect (Expect elems) =+  let groups = coalesce (Set.toAscList elems)+  in  intercalate ", " groups++coalesce :: [ExpectElem] -> [String]+coalesce [] = []+coalesce (ExpectSym s : rest) =+  let (moreSyms, rest') = collectSyms rest+      allSyms = s : moreSyms+  in  case rest' of+        (ExpectAnySym : rest'') -> "symbol" : coalesce rest''+        _ -> renderSyms allSyms : coalesce rest'+coalesce (ExpectAnySym : rest) = "symbol" : coalesce rest+coalesce (ExpectAnyInt : rest) = "integer" : coalesce rest+coalesce (ExpectAnySci : rest) = "number" : coalesce rest+coalesce (ExpectAnyStr : rest) = "string" : coalesce rest+coalesce (ExpectAnyChar : rest) = "character" : coalesce rest+coalesce (ExpectAnyAtom : rest) = "atom" : coalesce rest+coalesce (ExpectList _ : rest) = "list" : coalesce (dropWhile isExpectList rest)+coalesce (ExpectQuote : rest) = "quoted form" : coalesce rest+coalesce (ExpectUnquote : rest) = "unquoted form" : coalesce rest+coalesce (ExpectDoc : rest) = "doc form" : coalesce rest+coalesce (ExpectDesc t : rest) =+  let (moreDescs, rest') = collectDescs rest+      allDescs = t : moreDescs+  in  renderDescs allDescs : coalesce rest'++isExpectList :: ExpectElem -> Bool+isExpectList (ExpectList _) = True+isExpectList _ = False++collectSyms :: [ExpectElem] -> ([Sym], [ExpectElem])+collectSyms (ExpectSym s : rest) = let (ss, rest') = collectSyms rest in (s : ss, rest')+collectSyms rest = ([], rest)++collectDescs :: [ExpectElem] -> ([Text], [ExpectElem])+collectDescs (ExpectDesc t : rest) = let (ts, rest') = collectDescs rest in (t : ts, rest')+collectDescs rest = ([], rest)++renderSyms :: [Sym] -> String+renderSyms [Sym s] = "symbol '" <> unpack s <> "'"+renderSyms ss = "symbol " <> intercalate " or " ["'" <> unpack s <> "'" | Sym s <- ss]++renderDescs :: [Text] -> String+renderDescs [t] = unpack t+renderDescs ts = intercalate " or " (map unpack ts)+ data MatchErr e r   = MatchErrType !SexpType   | MatchErrTypeAtom@@ -69,11 +193,24 @@   | MatchErrNotEq !Atom   | MatchErrListElem !Int   | MatchErrListRem-  | MatchErrAlt !(Seq (Text, r))+  | MatchErrAlt !(Seq (Text, Expect, r))   | MatchErrEmbed !e   deriving stock (Eq, Ord, Show) -instance (Typeable e, Show e, Typeable r, Show r) => Exception (MatchErr e r)+instance (Typeable e, Show e, Typeable r, Exception r) => Exception (MatchErr e r) where+  displayException = \case+    MatchErrType st -> "expected " <> displaySexpType st+    MatchErrTypeAtom -> "expected atom"+    MatchErrTypeQuote -> "expected quote"+    MatchErrTypeUnquote -> "expected unquote"+    MatchErrTypeDoc -> "expected doc"+    MatchErrNotEq a -> "expected " <> displayAtom a+    MatchErrListElem i -> "list too short: need element at position " <> show i+    MatchErrListRem -> "unexpected remaining list elements"+    MatchErrAlt alts ->+      let merged = mconcat [ex | (_, ex, _) <- toList alts]+      in  "expected one of: " <> displayExpect merged+    MatchErrEmbed e -> show e  newtype LocMatchErr e k = LocMatchErr   { unLocMatchErr :: Anno k (MatchErr e (LocMatchErr e k))@@ -81,8 +218,29 @@   deriving stock (Show)   deriving newtype (Eq, Ord) -instance (Typeable e, Show e, Typeable k, Show k) => Exception (LocMatchErr e k)+instance (Typeable e, Show e, Typeable k, Show k) => Exception (LocMatchErr e k) where+  displayException (LocMatchErr (Anno _ err)) = displayException err +displaySexpType :: SexpType -> String+displaySexpType = \case+  SexpTypeAtom AtomTypeSym -> "symbol"+  SexpTypeAtom AtomTypeInt -> "integer"+  SexpTypeAtom AtomTypeSci -> "number"+  SexpTypeAtom AtomTypeStr -> "string"+  SexpTypeAtom AtomTypeChar -> "char"+  SexpTypeList _ -> "list"+  SexpTypeQuote -> "quote"+  SexpTypeUnquote -> "unquote"+  SexpTypeDoc -> "doc"++displayAtom :: Atom -> String+displayAtom = \case+  AtomSym s -> unpack (unSym s)+  AtomInt i -> show i+  AtomSci s -> show s+  AtomStr s -> show s+  AtomChar c -> show c+ newtype MatchT e k m a = MatchT {unMatchT :: ReaderT (Memo SexpF k) (ExceptT (LocMatchErr e k) m) a}   deriving newtype (Functor, Applicative, Monad) @@ -122,6 +280,7 @@   SeqMatchElem :: MatchT e k m x -> (x -> SeqMatchT e k m a) -> SeqMatchT e k m a   SeqMatchRepeat :: SeqMatchT e k m x -> (Seq x -> SeqMatchT e k m a) -> SeqMatchT e k m a   SeqMatchRemaining :: (Int -> SeqMatchT e k m a) -> SeqMatchT e k m a+  SeqMatchPeek :: MatchT e k m x -> (Maybe x -> SeqMatchT e k m a) -> SeqMatchT e k m a  type SeqMatchM e k = SeqMatchT e k Identity @@ -134,6 +293,7 @@       SeqMatchElem mx k -> SeqMatchElem mx (go . k)       SeqMatchRepeat mx k -> SeqMatchRepeat mx (go . k)       SeqMatchRemaining k -> SeqMatchRemaining (go . k)+      SeqMatchPeek mx k -> SeqMatchPeek mx (go . k)  instance (Monad m) => Applicative (SeqMatchT e k m) where   pure = SeqMatchPure@@ -149,6 +309,7 @@       SeqMatchElem mx k -> SeqMatchElem mx (go . k)       SeqMatchRepeat mx k -> SeqMatchRepeat mx (go . k)       SeqMatchRemaining k -> SeqMatchRemaining (go . k)+      SeqMatchPeek mx k -> SeqMatchPeek mx (go . k)  annoM :: (Monad m) => MatchT e k m a -> MatchT e k m (Anno k a) annoM m = MatchT (asks (Anno . B.memoKey)) <*> m@@ -195,6 +356,15 @@   SeqMatchRemaining k -> do     S _ cs <- get     goSeqX (k (Seq.length cs))+  SeqMatchPeek mx k -> do+    S _ cs <- get+    case cs of+      Empty -> goSeqX (k Nothing)+      c :<| _ -> do+        res <- lift (lift (runMatchT mx c))+        case res of+          Right x -> goSeqX (k (Just x))+          Left _ -> goSeqX (k Nothing)  -- TODO Better error for failure on repeat? -- helper for listFromM, but needs type sig@@ -235,19 +405,24 @@ remainingM :: SeqMatchT e k m Int remainingM = SeqMatchRemaining SeqMatchPure -altM :: (Monad m) => [(Text, MatchT e k m a)] -> MatchT e k m a+-- | Peek at the next element without consuming it. Returns @Just x@ if+-- the element matches, @Nothing@ if the sequence is empty or the match fails.+peekM :: MatchT e k m a -> SeqMatchT e k m (Maybe a)+peekM mx = SeqMatchPeek mx SeqMatchPure++altM :: (Monad m) => [(Text, Expect, MatchT e k m a)] -> MatchT e k m a altM = go Empty  where   go !acc = \case     [] -> errM (MatchErrAlt acc)-    (l, m) : ms -> do+    (l, ex, m) : ms -> do       s <- MatchT ask       res <- lift (runMatchT m s)       case res of         Right a -> pure a-        Left e -> go (acc :|> (l, e)) ms+        Left e -> go (acc :|> (l, ex, e)) ms -lookM :: (Monad m) => Brace -> [(Text, MatchT e k m (), SeqMatchT e k m a)] -> MatchT e k m a+lookM :: (Monad m) => Brace -> [(Text, Expect, MatchT e k m (), SeqMatchT e k m a)] -> MatchT e k m a lookM b0 as0 = goRoot  where   goRoot = do@@ -260,7 +435,7 @@       _ -> errM (MatchErrType (SexpTypeList b0))   goAlt hd !acc = \case     [] -> errM (MatchErrAlt acc)-    (l, m, r) : as -> do+    (l, ex, m, r) : as -> do       resHd <- lift (runMatchT m hd)       case resHd of         Right _ -> do@@ -268,8 +443,8 @@           resTl <- lift (runMatchT (listFromM 1 b0 r) s)           case resTl of             Right a -> pure a-            Left e -> goAlt hd (acc :|> (l, e)) as-        Left e -> goAlt hd (acc :|> (l, e)) as+            Left e -> goAlt hd (acc :|> (l, ex, e)) as+        Left e -> goAlt hd (acc :|> (l, ex, e)) as  anySymM :: (Monad m) => MatchT e k m Sym anySymM = matchM $ \case
src/Mello/Parse.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-}  module Mello.Parse@@ -15,10 +16,12 @@ import Bowtie (Memo, pattern MemoP) import Control.Monad (guard, unless, void) import Data.Char (isDigit, isSpace)+import Data.Hashable (Hashable) import Data.Sequence (Seq (..)) import Data.Text (Text) import Data.Text qualified as T import Data.Void (Void)+import GHC.Generics (Generic) import Looksee (Err, ParserT, Span (..)) import Looksee qualified as L import Mello.Syntax (Atom (..), Doc (..), SexpF (..), Sym (..))@@ -63,7 +66,8 @@   , locCol :: !Int   , locOffset :: !Int   }-  deriving stock (Eq, Ord, Show)+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (Hashable)  type LocSpan = Span Loc
test/Main.hs view
@@ -4,9 +4,13 @@ module Main (main) where  import Bowtie (unMkMemo)+import Control.Exception (displayException)+import Control.Monad (void)+import Data.List (isInfixOf) import Data.Text (Text) import Data.Void (Void)-import Mello.Parse (sexpParser)+import Mello.Match (MatchM, altM, anyIntM, anySymM, elemM, expectAnyInt, expectAnySym, listM, runMatchM, symM)+import Mello.Parse (LocSpan, parseSexp, sexpParser) import Mello.Syntax   ( Atom (..)   , Brace (..)@@ -18,7 +22,7 @@   , pattern SexpQuote   , pattern SexpUnquote   )-import PropUnit (MonadTest, TestName, TestTree, testGroup)+import PropUnit (MonadTest, TestName, TestTree, testGroup, testUnit) import Test.Daytripper (daytripperMain, mkUnitRT, testRT) import Test.Looksee.Trip (ExpectP, cmpEq, expectParsePretty, expectRendered) @@ -53,10 +57,52 @@     , parseCaseAs "atom sym special 6" ":x" (SexpAtom (AtomSym ":x"))     ] +-- Match error display tests++trySexp :: MatchM Void LocSpan a -> Text -> Either String a+trySexp m t = do+  sexp <- either (Left . show) Right (parseSexp t)+  either (Left . displayException) Right (runMatchM @Void m sexp)++-- | Assert that matching fails and the error message contains the expected substring.+assertErrContains :: (MonadFail m) => String -> Either String a -> m ()+assertErrContains expected = \case+  Right _ -> fail "expected match to fail"+  Left err+    | expected `isInfixOf` err -> pure ()+    | otherwise -> fail ("error did not contain " <> show expected <> "\ngot: " <> err)++testDisplayException :: TestTree+testDisplayException =+  testGroup+    "displayException"+    [ testUnit "type mismatch: expected symbol" $+        assertErrContains "expected symbol" (trySexp anySymM "42")+    , testUnit "type mismatch: expected integer" $+        assertErrContains "expected integer" (trySexp anyIntM "foo")+    , testUnit "type mismatch: expected list" $+        assertErrContains "expected list" (trySexp (listM BraceParen (pure ())) "foo")+    , testUnit "list too short" $+        assertErrContains "list too short" (trySexp (listM BraceParen (elemM anySymM >> elemM anySymM)) "(x)")+    , testUnit "list too short: position" $+        assertErrContains "position 2" (trySexp (listM BraceParen (elemM anySymM >> elemM anySymM)) "(x)")+    , testUnit "unexpected remaining" $+        assertErrContains "unexpected remaining" (trySexp (listM BraceParen (elemM anySymM)) "(x y)")+    , testUnit "not equal: expected atom" $+        assertErrContains "expected foo" (trySexp (symM "foo") "bar")+    , testUnit "alt with labels" $ do+        let m = altM [("sym", expectAnySym, void anySymM), ("int", expectAnyInt, void anyIntM)]+        assertErrContains "symbol" (trySexp m "(x)")+        assertErrContains "integer" (trySexp m "(x)")+    , testUnit "alt: expected one of" $+        assertErrContains "expected one of" (trySexp (altM [("sym", expectAnySym, void anySymM)]) "(x)")+    ]+ main :: IO () main =   daytripperMain $ \_ ->     testGroup       "mello"       [ testParsing+      , testDisplayException       ]