packages feed

mello (empty) → 0.2.0

raw patch · 10 files changed

+1258/−0 lines, 10 filesdep +basedep +bowtiedep +containers

Dependencies added: base, bowtie, containers, daytripper, foldl, looksee, looksee-trip, mello, mtl, prettyprinter, prop-unit, recursion-schemes, scientific, text

Files

+ README.md view
@@ -0,0 +1,3 @@+# mello++No-fuss syntax with s-expressions
+ mello.cabal view
@@ -0,0 +1,136 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           mello+version:        0.2.0+synopsis:       No-fuss syntax with s-expressions+description:    Please see the README on GitHub at <https://github.com/ejconlon/mello#readme>+category:       Parsing+homepage:       https://github.com/ejconlon/mello#readme+bug-reports:    https://github.com/ejconlon/mello/issues+author:         Eric Conlon+maintainer:     ejconlon@gmail.com+copyright:      (c) 2024 Eric Conlon+license:        BSD3+build-type:     Simple+tested-with:+    GHC == 9.6.4+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/ejconlon/mello++library+  exposed-modules:+      Mello+      Mello.Match+      Mello.Parse+      Mello.Print+      Mello.Recognize+      Mello.Syntax+      Mello.Text+  other-modules:+      Paths_mello+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      ConstraintKinds+      DataKinds+      DeriveFunctor+      DeriveFoldable+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      LambdaCase+      KindSignatures+      MultiParamTypeClasses+      MultiWayIf+      PatternSynonyms+      Rank2Types+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  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.4.*+    , containers ==0.6.*+    , foldl ==1.4.*+    , looksee ==0.7.*+    , mtl >=2.3 && <2.5+    , prettyprinter ==1.7.*+    , recursion-schemes ==5.2.*+    , scientific ==0.3.*+    , text >=2.0 && <2.2+  default-language: GHC2021++test-suite mello-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_mello+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      ConstraintKinds+      DataKinds+      DeriveFunctor+      DeriveFoldable+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      LambdaCase+      KindSignatures+      MultiParamTypeClasses+      MultiWayIf+      PatternSynonyms+      Rank2Types+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  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.4.*+    , containers ==0.6.*+    , daytripper ==0.4.*+    , foldl ==1.4.*+    , looksee ==0.7.*+    , looksee-trip ==0.7.*+    , mello+    , mtl >=2.3 && <2.5+    , prettyprinter ==1.7.*+    , prop-unit ==0.2.*+    , recursion-schemes ==5.2.*+    , scientific ==0.3.*+    , text >=2.0 && <2.2+  default-language: GHC2021
+ src/Mello.hs view
@@ -0,0 +1,14 @@+module Mello+  ( module Mello.Match+  , module Mello.Parse+  , module Mello.Syntax+  , module Mello.Print+  , module Mello.Text+  )+where++import Mello.Match+import Mello.Parse+import Mello.Print+import Mello.Syntax+import Mello.Text (Brace (..))
+ src/Mello/Match.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE UndecidableInstances #-}++module Mello.Match+  ( MatchErr (..)+  , LocMatchErr (..)+  , MatchT+  , MatchM+  , runMatchT+  , runMatchM+  , SeqMatchT+  , SeqMatchM+  , annoM+  , memoM+  , embedM+  , matchM+  , listM+  , lookM+  , elemM+  , restM+  , repeatM+  , remainingM+  , altM+  , anySymM+  , symM+  , anyIntM+  , intM+  , anySciM+  , sciM+  , anyStrM+  , strM+  , anyCharM+  , charM+  , anyAtomM+  , MatchSexp (..)+  , fromSexpT+  , fromSexp+  , fromAnnoSexpT+  , fromAnnoSexp+  , proxyM+  )+where++import Bowtie (Anno (..), Memo (..), mkMemo, unMkMemo, pattern MemoP)+import Bowtie qualified as B+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.Proxy (Proxy)+import Data.Scientific (Scientific)+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.Text (Text)+import Data.Typeable (Typeable)+import Mello.Syntax (Atom (..), AtomType (..), Brace, Sexp (..), SexpF (..), SexpType (..), Sym (..))++data MatchErr e r+  = MatchErrType !SexpType+  | MatchErrTypeAtom+  | MatchErrNotEq !Atom+  | MatchErrListElem !Int+  | MatchErrListRem+  | MatchErrAlt !(Seq (Text, r))+  | MatchErrEmbed !e+  deriving stock (Eq, Ord, Show)++instance (Typeable e, Show e, Typeable r, Show r) => Exception (MatchErr e r)++newtype LocMatchErr e k = LocMatchErr+  { unLocMatchErr :: Anno k (MatchErr e (LocMatchErr e k))+  }+  deriving stock (Show)+  deriving newtype (Eq, Ord)++instance (Typeable e, Show e, Typeable k, Show k) => Exception (LocMatchErr e k)++newtype MatchT e k m a = MatchT {unMatchT :: ReaderT (Memo SexpF k) (ExceptT (LocMatchErr e k) m) a}+  deriving newtype (Functor, Applicative, Monad)++type MatchM e k = MatchT e k Identity++instance MonadTrans (MatchT e k) where+  lift = MatchT . lift . lift++unlift :: (Monad m) => (Memo SexpF k -> m (Either (LocMatchErr e k) a)) -> MatchT e k m a+unlift f = MatchT $ do+  s <- ask+  ea <- lift (lift (f s))+  either throwError pure ea++instance (MonadReader r m) => MonadReader r (MatchT e k m) where+  ask = lift ask+  local f m = unlift (local f . runMatchT m)++instance (MonadState s m) => MonadState s (MatchT e k m) where+  get = lift get+  put = lift . put+  state = lift . state++instance (MonadError x m) => MonadError x (MatchT e k m) where+  throwError = lift . throwError+  catchError m f = unlift (\s -> catchError (runMatchT m s) (flip runMatchT s . f))++runMatchT :: MatchT e k m a -> Memo SexpF k -> m (Either (LocMatchErr e k) a)+runMatchT m r = runExceptT (runReaderT (unMatchT m) r)++runMatchM :: MatchM e k a -> Memo SexpF k -> Either (LocMatchErr e k) a+runMatchM m r = runIdentity (runMatchT m r)++data SeqMatchT e k m a where+  SeqMatchPure :: a -> SeqMatchT e k m a+  SeqMatchEmbed :: MatchT e k m (SeqMatchT e k m a) -> SeqMatchT e k m a+  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++type SeqMatchM e k = SeqMatchT e k Identity++instance (Functor m) => Functor (SeqMatchT e k m) where+  fmap f = go+   where+    go = \case+      SeqMatchPure a -> SeqMatchPure (f a)+      SeqMatchEmbed mr -> SeqMatchEmbed (fmap go mr)+      SeqMatchElem mx k -> SeqMatchElem mx (go . k)+      SeqMatchRepeat mx k -> SeqMatchRepeat mx (go . k)+      SeqMatchRemaining k -> SeqMatchRemaining (go . k)++instance (Monad m) => Applicative (SeqMatchT e k m) where+  pure = SeqMatchPure+  (<*>) = ap++instance (Monad m) => Monad (SeqMatchT e k m) where+  return = pure+  r0 >>= f = go r0+   where+    go = \case+      SeqMatchPure a -> f a+      SeqMatchEmbed mr -> SeqMatchEmbed (fmap go mr)+      SeqMatchElem mx k -> SeqMatchElem mx (go . k)+      SeqMatchRepeat mx k -> SeqMatchRepeat mx (go . k)+      SeqMatchRemaining k -> SeqMatchRemaining (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++memoM :: (Monad m) => MatchT e k m (f (Memo f k)) -> MatchT e k m (Memo f k)+memoM m = MatchT (asks (MemoP . B.memoKey)) <*> m++errM :: (Monad m) => MatchErr e (LocMatchErr e k) -> MatchT e k m a+errM e = do+  s <- MatchT ask+  MatchT (throwError (LocMatchErr (Anno (B.memoKey s) e)))++embedM :: (Monad m) => e -> MatchT e k m a+embedM = errM . MatchErrEmbed++matchM :: (Monad m) => (SexpF (Memo SexpF k) -> Either (MatchErr e (LocMatchErr e k)) a) -> MatchT e k m a+matchM f = do+  s <- MatchT ask+  case f (B.memoVal s) of+    Left e -> MatchT (throwError (LocMatchErr (Anno (B.memoKey s) e)))+    Right a -> pure a++data S k = S !Int !(Seq (Memo SexpF k))+  deriving stock (Eq, Ord, Show)++listM :: (Monad m) => Brace -> SeqMatchT e k m a -> MatchT e k m a+listM = listFromM 0++-- heuper for listFromM, but needs type sig+goSeqX :: (Monad m) => SeqMatchT e k m a -> StateT (S k) (MatchT e k m) a+goSeqX = \case+  SeqMatchPure a -> pure a+  SeqMatchEmbed mr -> lift mr >>= goSeqX+  SeqMatchElem mx k -> do+    S i cs <- get+    let i' = i + 1+    case cs of+      Empty -> lift (errM (MatchErrListElem i'))+      c :<| cs' -> do+        put (S i' cs')+        x <- lift (MatchT (local (const c) (unMatchT mx)))+        goSeqX (k x)+  SeqMatchRepeat mx k -> goRepeatX mx k+  SeqMatchRemaining k -> do+    S _ cs <- get+    goSeqX (k (Seq.length cs))++-- TODO Better error for failure on repeat?+-- helper for listFromM, but needs type sig+goRepeatX :: (Monad m) => SeqMatchT e k m x -> (Seq x -> SeqMatchT e k m a) -> StateT (S k) (MatchT e k m) a+goRepeatX mx k = go Empty+ where+  go !acc = do+    S _ cs <- get+    case cs of+      Empty -> goSeqX (k acc)+      _ -> do+        x <- goSeqX mx+        go (acc :|> x)++listFromM :: (Monad m) => Int -> Brace -> SeqMatchT e k m a -> MatchT e k m a+listFromM i0 b0 r = goStart+ where+  goStart = do+    s <- MatchT ask+    case B.memoVal s of+      SexpListF b cs0 | b == b0 -> do+        let s0 = S i0 (Seq.drop i0 cs0)+        (a, S _ cs1) <- runStateT (goSeqX r) s0+        case cs1 of+          Empty -> pure a+          _ -> errM MatchErrListRem+      _ -> errM (MatchErrType (SexpTypeList b0))++elemM :: MatchT e k m a -> SeqMatchT e k m a+elemM = (`SeqMatchElem` SeqMatchPure)++restM :: MatchT e k m a -> SeqMatchT e k m (Seq a)+restM = repeatM . elemM++repeatM :: SeqMatchT e k m a -> SeqMatchT e k m (Seq a)+repeatM = (`SeqMatchRepeat` SeqMatchPure)++remainingM :: SeqMatchT e k m Int+remainingM = SeqMatchRemaining SeqMatchPure++altM :: (Monad m) => [(Text, MatchT e k m a)] -> MatchT e k m a+altM = go Empty+ where+  go !acc = \case+    [] -> errM (MatchErrAlt acc)+    (l, 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++lookM :: (Monad m) => Brace -> [(Text, MatchT e k m (), SeqMatchT e k m a)] -> MatchT e k m a+lookM b0 as0 = goRoot+ where+  goRoot = do+    s <- MatchT ask+    case B.memoVal s of+      SexpListF b cs0 | b == b0 ->+        case cs0 of+          Empty -> errM (MatchErrListElem 0)+          hd :<| _ -> goAlt hd Empty as0+      _ -> errM (MatchErrType (SexpTypeList b0))+  goAlt hd !acc = \case+    [] -> errM (MatchErrAlt acc)+    (l, m, r) : as -> do+      resHd <- lift (runMatchT m hd)+      case resHd of+        Right _ -> do+          s <- MatchT ask+          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++anySymM :: (Monad m) => MatchT e k m Sym+anySymM = matchM $ \case+  SexpAtomF (AtomSym y) -> Right y+  _ -> Left (MatchErrType (SexpTypeAtom AtomTypeSym))++symM :: (Monad m) => Sym -> MatchT e k m ()+symM x =+  anySymM >>= \y ->+    unless (y == x) (errM (MatchErrNotEq (AtomSym x)))++anyIntM :: (Monad m) => MatchT e k m Integer+anyIntM = matchM $ \case+  SexpAtomF (AtomInt y) -> Right y+  _ -> Left (MatchErrType (SexpTypeAtom AtomTypeInt))++intM :: (Monad m) => Integer -> MatchT e k m ()+intM x =+  anyIntM >>= \y ->+    unless (y == x) (errM (MatchErrNotEq (AtomInt x)))++anySciM :: (Monad m) => MatchT e k m Scientific+anySciM = matchM $ \case+  SexpAtomF (AtomSci y) -> Right y+  _ -> Left (MatchErrType (SexpTypeAtom AtomTypeSci))++sciM :: (Monad m) => Scientific -> MatchT e k m ()+sciM x =+  anySciM >>= \y ->+    unless (y == x) (errM (MatchErrNotEq (AtomSci x)))++anyStrM :: (Monad m) => MatchT e k m Text+anyStrM = matchM $ \case+  SexpAtomF (AtomStr y) -> Right y+  _ -> Left (MatchErrType (SexpTypeAtom AtomTypeStr))++strM :: (Monad m) => Text -> MatchT e k m ()+strM x =+  anyStrM >>= \y ->+    unless (y == x) (errM (MatchErrNotEq (AtomStr x)))++anyCharM :: (Monad m) => MatchT e k m Char+anyCharM = matchM $ \case+  SexpAtomF (AtomChar y) -> Right y+  _ -> Left (MatchErrType (SexpTypeAtom AtomTypeChar))++charM :: (Monad m) => Char -> MatchT e k m ()+charM x =+  anyCharM >>= \y ->+    unless (y == x) (errM (MatchErrNotEq (AtomChar x)))++anyAtomM :: (Monad m) => MatchT e k m Atom+anyAtomM = matchM $ \case+  SexpAtomF a -> Right a+  _ -> Left MatchErrTypeAtom++class (Monad m) => MatchSexp e k m a where+  matchSexp :: MatchT e k m a++instance (Monad m) => MatchSexp e k m Sexp where+  matchSexp = matchM (Right . Sexp . fmap unMkMemo)++instance (Monad m) => MatchSexp e k m (Memo SexpF k) where+  matchSexp = memoM (matchM Right)++instance (MatchSexp e k m s) => MatchSexp e k m (Anno k s) where+  matchSexp = annoM matchSexp++instance (Monad m) => MatchSexp e k m Atom where+  matchSexp = anyAtomM++instance (Monad m) => MatchSexp e k m Sym where+  matchSexp = anySymM++instance (Monad m) => MatchSexp e k m Integer where+  matchSexp = anyIntM++instance (Monad m) => MatchSexp e k m Scientific where+  matchSexp = anySciM++instance (Monad m) => MatchSexp e k m Text where+  matchSexp = anyStrM++instance (Monad m) => MatchSexp e k m Char where+  matchSexp = anyCharM++fromSexpT :: (MatchSexp e () m a) => Sexp -> m (Either (LocMatchErr e ()) a)+fromSexpT = runMatchT matchSexp . mkMemo (const ())++fromSexp :: (MatchSexp e () Identity a) => Sexp -> Either (LocMatchErr e ()) a+fromSexp = runIdentity . fromSexpT++fromAnnoSexpT :: (MatchSexp e k m a) => Memo SexpF k -> m (Either (LocMatchErr e k) a)+fromAnnoSexpT = runMatchT matchSexp++fromAnnoSexp :: (MatchSexp e k Identity a) => Memo SexpF k -> Either (LocMatchErr e k) a+fromAnnoSexp = runIdentity . fromAnnoSexpT++proxyM :: (MatchSexp e k m a) => Proxy a -> MatchT e k m a+proxyM = const matchSexp
+ src/Mello/Parse.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE OverloadedStrings #-}++module Mello.Parse+  ( OffsetSpan+  , OffsetSexp+  , Loc (..)+  , LocSpan+  , LocSexp+  , sexpParser+  , parseSexp+  , parseSexpI+  )+where++import Bowtie (Memo, pattern MemoP)+import Control.Monad (guard, unless, void)+import Data.Char (isSpace)+import Data.Sequence (Seq (..))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Void (Void)+import Looksee (Err, ParserT, Span (..))+import Looksee qualified as L+import Mello.Syntax (Atom (..), Doc (..), SexpF (..), Sym (..))+import Mello.Text+  ( Brace+  , closeBraceChar+  , isAtomStart+  , isCharStart+  , isListStart+  , isNumStart+  , isQuoteStart+  , isStringStart+  , isSymCont+  , isSymStart+  , isUnquoteStart+  , openBraceChar+  )++-- Generic parser combinators++guard1P :: (Monad m) => (Char -> Bool) -> ParserT e m ()+guard1P f = L.headP >>= guard . f++cons1P :: (Monad m) => (Char -> Bool) -> (Char -> Bool) -> ParserT e m Text+cons1P f g = liftA2 T.cons (L.headP >>= \c -> c <$ guard (f c)) (L.takeWhileP g)++commitSameP :: (Monad m) => [ParserT e m a] -> ParserT e m a+commitSameP = L.commitP . fmap (\p -> (void p, p))++explainEmptyP :: (Monad m) => Text -> ParserT e m a -> ParserT e m a+explainEmptyP msg = L.explainP $ \case+  L.ReasonEmpty -> Just (msg, True)+  _ -> Nothing++-- The final recursive types++type OffsetSpan = Span Int++type OffsetSexp = Memo SexpF OffsetSpan++data Loc = Loc+  { locLine :: !Int+  , locCol :: !Int+  , locOffset :: !Int+  }+  deriving stock (Eq, Ord, Show)++type LocSpan = Span Loc++type LocSexp = Memo SexpF LocSpan++-- Specific parsers++docStartP :: (Monad m) => ParserT e m ()+docStartP = L.textP_ ";|"++commentStartP :: (Monad m) => ParserT e m ()+commentStartP = L.charP_ ';'++spaceNP :: (Monad m) => Int -> ParserT e m Int+spaceNP !acc = do+  mc <- L.lookP L.unconsP+  case mc of+    Just ';' -> do+      mds <- L.lookP (L.optP docStartP)+      case mds of+        Just _ -> pure acc+        Nothing -> L.dropWhileP (/= '\n') >>= spaceNP . (acc +)+    Just c | isSpace c -> L.dropWhileP isSpace >>= spaceNP . (acc +)+    _ -> pure acc++spaceP, space1P :: (Monad m) => ParserT e m ()+spaceP = void (spaceNP 0)+space1P = do+  acc <- spaceNP 0+  unless (acc > 0) L.space1P -- Use this to fail++stripP, stripEndP :: (Monad m) => ParserT e m a -> ParserT e m a+stripP p = spaceP *> p <* spaceP+stripEndP p = p <* spaceP++symP :: (Monad m) => ParserT e m Sym+symP = fmap Sym (cons1P isSymStart isSymCont)++charLitP :: (Monad m) => ParserT e m Char+charLitP = L.charP_ '\'' *> L.headP <* L.charP_ '\''++stringLitP :: (Monad m) => ParserT e m Text+stringLitP = L.strP '"'++openBraceP :: (Monad m) => ParserT e m Brace+openBraceP = commitSameP (fmap (\b -> b <$ L.charP_ (openBraceChar b)) [minBound .. maxBound])++closeBraceP :: (Monad m) => Brace -> ParserT e m ()+closeBraceP = L.charP_ . closeBraceChar++docLinesP :: (Monad m) => ParserT e m Doc+docLinesP = go True Empty+ where+  lineStartP isFirst = if isFirst then docStartP else commentStartP+  lineP isFirst = do+    lineStartP isFirst+    lin <- L.takeWhileP (/= '\n')+    L.charP_ '\n'+    pure lin+  go !isFirst !acc = do+    mx <- L.lookP (L.optP (lineStartP isFirst))+    case mx of+      Nothing -> pure (Doc acc)+      Just _ -> do+        lin <- lineP isFirst+        go False (acc :|> lin)++-- | A parser for S-expressions+sexpParser :: (Monad m) => ParserT e m OffsetSexp+sexpParser = stripP rootP+ where+  rootP =+    explainEmptyP "Not a recognizable Sexp" $+      L.spanAroundP MemoP $+        L.commitP+          [ (guard1P isListStart, L.labelP "list" listP)+          , (guard1P isQuoteStart, L.labelP "quote" quoteP)+          , (guard1P isUnquoteStart, L.labelP "unquote" unquoteP)+          , (guard1P isAtomStart, L.labelP "atom" atomP)+          , (docStartP, L.labelP "doc" docP)+          ]+  listP = do+    b <- stripEndP openBraceP+    ss <- stripEndP (L.sepByP space1P rootP)+    closeBraceP b+    pure (SexpListF b ss)+  quoteP = L.charP_ '`' *> fmap SexpQuoteF rootP+  unquoteP = L.charP_ ',' *> fmap SexpUnquoteF rootP+  atomP =+    SexpAtomF+      <$> L.commitP+        [ (guard1P isSymStart, L.labelP "sym" (fmap AtomSym symP))+        , (guard1P isNumStart, L.labelP "num" (fmap (either AtomInt AtomSci) L.numP))+        , (guard1P isStringStart, L.labelP "str" (fmap AtomStr stringLitP))+        , (guard1P isCharStart, L.labelP "char" (fmap AtomChar charLitP))+        ]+  docP = do+    doc <- docLinesP+    fmap (SexpDocF doc) rootP++parseSexp :: Text -> Either (Err Void) LocSexp+parseSexp txt = do+  sexp <- L.parse sexpParser txt+  let v = L.calculateLineCol txt+      mkLoc o = let (l, c) = L.lookupLineCol o v in Loc l c o+  pure (fmap (fmap mkLoc) sexp)++parseSexpI :: Text -> IO (Either (Err Void) LocSexp)+parseSexpI txt = do+  let ea = parseSexp txt+  case ea of+    Left e -> L.printE "<interactive>" txt e+    Right _ -> pure ()+  pure ea
+ src/Mello/Print.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE UndecidableInstances #-}++module Mello.Print+  ( ToSexp (..)+  , toSexpDoc+  , toSexpText+  )+where++import Bowtie.Anno (Anno (..))+import Bowtie.Fix (Fix (..))+import Bowtie.Memo (Memo, memoVal)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text qualified as T+import Mello.Syntax (Atom (..), Sexp (..), Sym, pattern SexpAtom)+import Prettyprinter (Doc, defaultLayoutOptions, layoutSmart, pretty)+import Prettyprinter.Render.Text (renderStrict)++class ToSexp a where+  toSexp :: a -> Sexp++instance ToSexp Sexp where+  toSexp = id++instance (Functor f, ToSexp (f Sexp)) => ToSexp (Fix f) where+  toSexp = toSexp . fmap toSexp . unFix++instance (ToSexp s) => ToSexp (Anno k s) where+  toSexp = toSexp . annoVal++instance (Functor f, ToSexp (f Sexp)) => ToSexp (Memo f k) where+  toSexp = toSexp . fmap toSexp . memoVal++instance ToSexp Atom where+  toSexp = SexpAtom++instance ToSexp Sym where+  toSexp = SexpAtom . AtomSym++instance ToSexp Integer where+  toSexp = SexpAtom . AtomInt++instance ToSexp Int where+  toSexp = toSexp . fromIntegral @Int @Integer++instance ToSexp Scientific where+  toSexp = SexpAtom . AtomSci++instance ToSexp Text where+  toSexp = SexpAtom . AtomStr++instance ToSexp String where+  toSexp = toSexp . T.pack++instance ToSexp Char where+  toSexp = SexpAtom . AtomChar++toSexpDoc :: (ToSexp a) => a -> Doc ann+toSexpDoc = pretty . toSexp++toSexpText :: (ToSexp a) => a -> Text+toSexpText = renderStrict . layoutSmart defaultLayoutOptions . toSexpDoc
+ src/Mello/Recognize.hs view
@@ -0,0 +1,134 @@+-- TODO finish this+module Mello.Recognize+  (+  )+where++import Control.Foldl (Fold (..))+import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT)+import Control.Monad.State.Strict (State, gets, modify', runState)+import Mello.Text (Brace, readCloseBrace, readOpenBrace)++data X e s = X !(Maybe e) !s++foldUntilErr :: (a -> ExceptT e (State s) ()) -> s -> (Maybe e -> s -> b) -> Fold a b+foldUntilErr step initial extract = Fold step' initial' extract'+ where+  step' x@(X me s) a =+    case me of+      Just _ -> x+      Nothing ->+        let (ea, s') = runState (runExceptT (step a)) s+        in  case ea of+              Left e -> X (Just e) s'+              Right _ -> X Nothing s'+  initial' = X Nothing initial+  extract' (X me s) = extract me s++data RecogElem+  = RecogElemString+  | RecogElemChar+  | RecogElemComment+  | RecogElemSlashEsc+  | RecogElemQuote+  | RecogElemUnquote+  | RecogElemBrace !Brace+  deriving stock (Eq, Ord, Show)++newtype RecogErr+  = RecogErrMismatch Brace+  deriving stock (Eq, Ord, Show)++data RecogState = RecogState+  { rsOffset :: !Int+  , rsStack :: ![RecogElem]+  }+  deriving stock (Eq, Ord, Show)++initRecogState :: RecogState+initRecogState = RecogState 0 []++type RecogM = ExceptT RecogErr (State RecogState)++data CharCase+  = CharCaseNewline+  | CharCaseDoubleQuote+  | CharCaseSingleQuote+  | CharCaseOpenComment+  | CharCaseSlashEsc+  | CharCaseOpenBrace !Brace+  | CharCaseCloseBrace !Brace+  deriving stock (Eq, Ord, Show)++readCharCase :: Char -> Maybe CharCase+readCharCase c =+  if+    | c == '\n' -> Just CharCaseNewline+    | c == '"' -> Just CharCaseDoubleQuote+    | c == '\'' -> Just CharCaseSingleQuote+    | c == ';' -> Just CharCaseOpenComment+    | c == '\\' -> Just CharCaseSlashEsc+    | otherwise ->+        case readOpenBrace c of+          Just b -> Just (CharCaseOpenBrace b)+          Nothing -> case readCloseBrace c of+            Just b -> Just (CharCaseCloseBrace b)+            Nothing -> Nothing++stepR :: Char -> RecogM ()+stepR c = goRet+ where+  goRet = goStart <* incOffset+  goStart = do+    mh <- peekStack+    case mh of+      Just RecogElemString -> goString+      Just RecogElemChar -> goChar+      Just RecogElemComment -> goComment+      Just RecogElemSlashEsc -> goSlashEsc+      Just RecogElemQuote -> goQuote+      Just RecogElemUnquote -> goUnquote+      Just (RecogElemBrace b) -> goDefault (Just b)+      Nothing -> goDefault Nothing+  goString = case readCharCase c of+    Just CharCaseDoubleQuote -> popStack+    Just CharCaseSlashEsc -> pushStack RecogElemSlashEsc+    _ -> pure ()+  goChar = case readCharCase c of+    Just CharCaseSingleQuote -> popStack+    Just CharCaseSlashEsc -> pushStack RecogElemSlashEsc+    _ -> pure ()+  goComment = case readCharCase c of+    Just CharCaseNewline -> popStack+    _ -> pure ()+  goSlashEsc = popStack -- just ignore input and leave slash esc mode+  goQuote = error "TODO"+  goUnquote = error "TODO"+  goDefault mb = case readCharCase c of+    Just CharCaseDoubleQuote -> pushStack RecogElemString+    Just CharCaseSingleQuote -> pushStack RecogElemChar+    Just CharCaseOpenComment -> pushStack RecogElemComment+    Just (CharCaseOpenBrace b) -> pushStack (RecogElemBrace b)+    Just (CharCaseCloseBrace b) ->+      case mb of+        Just b0 | b == b0 -> popStack+        _ -> throwError (RecogErrMismatch b)+    _ -> pure ()+  incOffset = modify' (\s -> s {rsOffset = rsOffset s + 1})+  pushStack h = modify' (\s -> s {rsStack = h : rsStack s})+  popStack = modify' $ \s ->+    case rsStack s of+      [] -> s+      _ : t -> s {rsStack = t}+  peekStack = gets $ \s ->+    case rsStack s of+      [] -> Nothing+      h : _ -> Just h++extractR :: Maybe RecogErr -> RecogState -> Either RecogErr Bool+extractR me s = maybe (Right (null (rsStack s))) Left me++-- TODO expose this when quote/unquote recognition is implemented+-- and it's all tested+sexpRecognizer :: Fold Char (Either RecogErr Bool)+sexpRecognizer = foldUntilErr stepR initRecogState extractR
+ src/Mello/Syntax.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module Mello.Syntax+  ( Sym (..)+  , Atom (..)+  , AtomType (..)+  , Brace (..)+  , Doc (..)+  , SexpF (..)+  , Sexp (..)+  , SexpType (..)+  , pattern SexpAtom+  , pattern SexpList+  , pattern SexpQuote+  , pattern SexpUnquote+  , pattern SexpDoc+  )+where++import Data.Foldable (toList)+import Data.Functor.Foldable (Base, Corecursive (..), Recursive (..))+import Data.Scientific (Scientific)+import Data.Sequence (Seq (..))+import Data.String (IsString (..))+import Data.Text (Text)+import Mello.Text (Brace (..), closeBraceChar, openBraceChar)+import Prettyprinter (Pretty (..))+import Prettyprinter qualified as P++newtype Sym = Sym {unSym :: Text}+  deriving stock (Show)+  deriving newtype (Eq, Ord, IsString, Pretty)++-- | Leaves of S-expression trees+data Atom+  = AtomSym !Sym+  | AtomInt !Integer+  | AtomSci !Scientific+  | AtomStr !Text+  | AtomChar !Char+  deriving stock (Eq, Ord, Show)++atomNotNumErr :: a+atomNotNumErr = error "Atom not num"++-- It's a sin to define an instance this partial but it's really+-- useful to have literal syntax.+instance Num Atom where+  (+) = \case+    AtomInt x -> \case+      AtomInt y -> AtomInt (x + y)+      AtomSci y -> AtomSci (fromIntegral x + y)+      _ -> atomNotNumErr+    AtomSci x -> \case+      AtomInt y -> AtomSci (x + fromIntegral y)+      AtomSci y -> AtomSci (x + y)+      _ -> atomNotNumErr+    _ -> atomNotNumErr+  (*) = \case+    AtomInt x -> \case+      AtomInt y -> AtomInt (x * y)+      AtomSci y -> AtomSci (fromIntegral x * y)+      _ -> atomNotNumErr+    AtomSci x -> \case+      AtomInt y -> AtomSci (x * fromIntegral y)+      AtomSci y -> AtomSci (x * y)+      _ -> atomNotNumErr+    _ -> atomNotNumErr+  negate = \case+    AtomInt x -> AtomInt (negate x)+    AtomSci x -> AtomSci (negate x)+    _ -> atomNotNumErr+  abs = \case+    AtomInt x -> AtomInt (abs x)+    AtomSci x -> AtomSci (abs x)+    _ -> atomNotNumErr+  signum = \case+    AtomInt x -> AtomInt (signum x)+    AtomSci x -> AtomSci (signum x)+    _ -> atomNotNumErr+  fromInteger = AtomInt++instance IsString Atom where+  fromString = AtomSym . fromString++instance Pretty Atom where+  pretty = \case+    AtomSym x -> pretty x+    AtomInt x -> pretty x+    AtomSci x -> P.viaShow x+    AtomStr x -> "\"" <> pretty x <> "\""+    AtomChar x -> "'" <> pretty x <> "'"++data AtomType+  = AtomTypeSym+  | AtomTypeInt+  | AtomTypeSci+  | AtomTypeStr+  | AtomTypeChar+  deriving stock (Eq, Ord, Show, Enum, Bounded)++atomType :: Atom -> AtomType+atomType = \case+  AtomSym _ -> AtomTypeSym+  AtomInt _ -> AtomTypeInt+  AtomSci _ -> AtomTypeSci+  AtomStr _ -> AtomTypeStr+  AtomChar _ -> AtomTypeChar++newtype Doc = Doc {unDoc :: Seq Text}+  deriving stock (Show)+  deriving newtype (Eq, Ord)++-- | An S-expression+data SexpF r+  = SexpAtomF !Atom+  | SexpListF !Brace !(Seq r)+  | SexpQuoteF r+  | SexpUnquoteF r+  | SexpDocF !Doc r+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)++sexpNotNumErr :: a+sexpNotNumErr = error "Sexp not num"++-- Again, bad instance, but nice to have literal syntax+instance Num (SexpF a) where+  (+) = \case+    SexpAtomF x -> \case+      SexpAtomF y -> SexpAtomF (x + y)+      _ -> sexpNotNumErr+    _ -> sexpNotNumErr+  (*) = \case+    SexpAtomF x -> \case+      SexpAtomF y -> SexpAtomF (x * y)+      _ -> sexpNotNumErr+    _ -> sexpNotNumErr+  negate = \case+    SexpAtomF x -> SexpAtomF (negate x)+    _ -> sexpNotNumErr+  abs = \case+    SexpAtomF x -> SexpAtomF (abs x)+    _ -> sexpNotNumErr+  signum = \case+    SexpAtomF x -> SexpAtomF (signum x)+    _ -> sexpNotNumErr+  fromInteger = SexpAtomF . fromInteger++instance IsString (SexpF r) where+  fromString = SexpAtomF . fromString++instance (Pretty r) => Pretty (SexpF r) where+  pretty = \case+    SexpAtomF a -> pretty a+    SexpListF b rs -> pretty (openBraceChar b) <> P.hsep (fmap pretty (toList rs)) <> pretty (closeBraceChar b)+    SexpQuoteF r -> "`" <> pretty r+    SexpUnquoteF r -> "," <> pretty r+    SexpDocF (Doc d) r ->+      case d of+        Empty -> pretty r+        h :<| t ->+          let h' = (";|" <> pretty h <> "\n")+              t' = fmap (\x -> ";" <> pretty x <> "\n") t+          in  P.hcat (toList (h' :<| (t' :|> pretty r)))++newtype Sexp = Sexp {unSexp :: SexpF Sexp}+  deriving stock (Show)+  deriving newtype (Eq, Ord, Num, IsString, Pretty)++type instance Base Sexp = SexpF++instance Recursive Sexp where project = unSexp++instance Corecursive Sexp where embed = Sexp++data SexpType+  = SexpTypeAtom !AtomType+  | SexpTypeList !Brace+  | SexpTypeQuote+  | SexpTypeUnquote+  | SexpTypeDoc+  deriving stock (Eq, Ord, Show)++sexpType :: SexpF r -> SexpType+sexpType = \case+  SexpAtomF at -> SexpTypeAtom (atomType at)+  SexpListF b _ -> SexpTypeList b+  SexpQuoteF _ -> SexpTypeQuote+  SexpUnquoteF _ -> SexpTypeUnquote+  SexpDocF _ _ -> SexpTypeDoc++class IsSexp s where+  toSexp :: s -> Sexp++instance IsSexp Sexp where+  toSexp = id++pattern SexpAtom :: Atom -> Sexp+pattern SexpAtom x = Sexp (SexpAtomF x)++pattern SexpList :: Brace -> Seq Sexp -> Sexp+pattern SexpList x y = Sexp (SexpListF x y)++pattern SexpQuote :: Sexp -> Sexp+pattern SexpQuote x = Sexp (SexpQuoteF x)++pattern SexpUnquote :: Sexp -> Sexp+pattern SexpUnquote x = Sexp (SexpUnquoteF x)++pattern SexpDoc :: Doc -> Sexp -> Sexp+pattern SexpDoc x y = Sexp (SexpDocF x y)++{-# COMPLETE SexpAtom, SexpList, SexpQuote, SexpUnquote, SexpDoc #-}
+ src/Mello/Text.hs view
@@ -0,0 +1,92 @@+module Mello.Text+  ( Brace (..)+  , openBraceChar+  , closeBraceChar+  , readOpenBrace+  , readCloseBrace+  , isSymStart+  , isSymCont+  , isListStart+  , isListEnd+  , isCharStart+  , isStringStart+  , isQuoteStart+  , isUnquoteStart+  , isCommentStart+  , isDocCont+  , isNumStart+  , isAtomStart+  )+where++import Data.Char (isControl, isDigit, isSpace)++data Brace = BraceParen | BraceCurly | BraceSquare+  deriving stock (Eq, Ord, Show, Enum, Bounded)++openBraceChar :: Brace -> Char+openBraceChar = \case+  BraceParen -> '('+  BraceCurly -> '{'+  BraceSquare -> '['++closeBraceChar :: Brace -> Char+closeBraceChar = \case+  BraceParen -> ')'+  BraceCurly -> '}'+  BraceSquare -> ']'++readOpenBrace :: Char -> Maybe Brace+readOpenBrace = \case+  '(' -> Just BraceParen+  '{' -> Just BraceCurly+  '[' -> Just BraceSquare+  _ -> Nothing++readCloseBrace :: Char -> Maybe Brace+readCloseBrace = \case+  ')' -> Just BraceParen+  '}' -> Just BraceCurly+  ']' -> Just BraceSquare+  _ -> Nothing++isSymStart+  , isSymCont+  , isListStart+  , isListEnd+  , isCharStart+  , isStringStart+  , isQuoteStart+  , isUnquoteStart+  , isCommentStart+  , isDocCont+  , isNumStart+  , isAtomStart+    :: Char -> Bool+isSymStart c = not (isDigit c) && isSymCont c+isSymCont c =+  not $+    isControl c+      || isSpace c+      || isCommentStart c+      || isListStart c+      || isListEnd c+      || isStringStart c+      || isCharStart c+      || isQuoteStart c+      || isUnquoteStart c+      || isDigit c+isListStart c = c == '(' || c == '{' || c == '['+isListEnd c = c == ')' || c == '}' || c == ']'+isCharStart c = c == '\''+isStringStart c = c == '\"'+isQuoteStart c = c == '`'+isUnquoteStart c = c == ','+isCommentStart c = c == ';'+isDocCont c = c == '|'+isNumStart c = isDigit c || c == '-'+isAtomStart c =+  isSymStart c+    || isNumStart c+    || isStringStart c+    || isCharStart c
+ test/Main.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Bowtie (unMkMemo)+import Data.Text (Text)+import Data.Void (Void)+import Mello.Parse (sexpParser)+import Mello.Syntax+  ( Atom (..)+  , Brace (..)+  , Doc (..)+  , Sexp+  , pattern SexpAtom+  , pattern SexpDoc+  , pattern SexpList+  , pattern SexpQuote+  , pattern SexpUnquote+  )+import PropUnit (MonadTest, TestName, TestTree, testGroup)+import Test.Daytripper (daytripperMain, mkUnitRT, testRT)+import Test.Looksee.Trip (ExpectP, cmpEq, expectParsePretty, expectRendered)++expectParseSexp :: (MonadTest m) => ExpectP Void m Sexp+expectParseSexp = expectParsePretty (fmap unMkMemo sexpParser) cmpEq++parseCase :: TestName -> Sexp -> TestTree+parseCase n = testRT undefined . mkUnitRT n expectParseSexp++parseCaseAs :: TestName -> Text -> Sexp -> TestTree+parseCaseAs n t = testRT undefined . mkUnitRT n (expectRendered t expectParseSexp)++testParsing :: TestTree+testParsing =+  testGroup+    "parsing"+    [ parseCaseAs "atom int" "1" (SexpAtom (AtomInt 1))+    , parseCaseAs "atom str" "\"abc\"" (SexpAtom (AtomStr "abc"))+    , parseCaseAs "atom char" "'x'" (SexpAtom (AtomChar 'x'))+    , parseCaseAs "atom sym" "xyz" (SexpAtom (AtomSym "xyz"))+    , parseCaseAs "atom sci" "3.14" (SexpAtom (AtomSci 3.14))+    , parseCaseAs "quote" "`1" (SexpQuote 1)+    , parseCaseAs "unquote" ",1" (SexpUnquote 1)+    , parseCaseAs "list" "(1 2)" (SexpList BraceParen [1, 2])+    , parseCaseAs "doc" ";|X\n;Y\n1" (SexpDoc (Doc ["X", "Y"]) 1)+    ]++main :: IO ()+main =+  daytripperMain $ \_ ->+    testGroup+      "mello"+      [ testParsing+      ]