parser-unbiased-choice-monad-embedding (empty) → 0.0.0.1

raw patch · 6 files changed

+219/−0 lines, 6 filesdep +Earleydep +basedep +containers

Dependencies added: Earley, base, containers, doctest, lexer-applicative, regex-applicative, srcloc

Files

ChangeLog +0/−0
LICENSE +8/−0
ParserUnbiasedChoiceMonadEmbedding.hs +157/−0
README.md +3/−0
doctests.hs +3/−0
parser-unbiased-choice-monad-embedding.cabal +48/−0

+ ChangeLog view

+ LICENSE view

@@ -0,0 +1,8 @@+Copyright (c) 2021 parser-unbiased-choice-monad-embedding authors. All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE

+ ParserUnbiasedChoiceMonadEmbedding.hs view

@@ -0,0 +1,157 @@+-- <ghc2021+->+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE EmptyCase, PostfixOperators, TupleSections, NamedFieldPuns, BangPatterns, BinaryLiterals, HexFloatLiterals, NumericUnderscores, GADTSyntax, RankNTypes, TypeApplications, PolyKinds, ExistentialQuantification, TypeOperators, ConstraintKinds, ExplicitForAll, KindSignatures, NamedWildCards, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ConstrainedClassMethods, InstanceSigs, TypeSynonymInstances, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveTraversable, StandaloneDeriving, EmptyDataDeriving, DeriveLift, DeriveGeneric #-}+-- Deleted GeneralisedNewtypeDeriving, because it is not compatible with Safe+-- Deleted ImportQualifiedPost, StandaloneKindSignatures, because they are not supported in ghc 8.8.1+{-# LANGUAGE MonoLocalBinds #-}+-- </ghc2021+->++{-# LANGUAGE ApplicativeDo #-}++module ParserUnbiasedChoiceMonadEmbedding ({- $Example -} ArrowProd(..), msym, sym, lift, loc, arrowRule, arrowParser, showLoc, positionToLoc) where++import Prelude hiding (id, (.))+import Control.Category(Category(..))+import Control.Arrow(Arrow(..))+import Control.Applicative(Alternative(..))+import Text.Earley(Prod, Grammar, Parser, terminal, rule, parser)+import Data.Loc(L(..), Loc(..), (<-->), Pos(..))+import Data.Traversable(for)++newtype ArrowProd r e t m b c = ArrowProd (Prod r e (L t) (L (b -> m c)))++instance Monad m => Category (ArrowProd r e t m) where+  id = ArrowProd $ pure $ L NoLoc pure+  ArrowProd x . ArrowProd y = ArrowProd $ do {+    ~(L yl ya) <- y;+    ~(L xl xa) <- x;+    pure $ L (yl <--> xl) $ \v1 -> do {+      v2 <- ya v1;+      xa v2;+    };+  }++instance Monad m => Arrow (ArrowProd r e t m) where+  arr f = ArrowProd $ pure $ L NoLoc (\b -> pure $ f b)+  first (ArrowProd x) = ArrowProd $ do {+    ~(L l arr1) <- x;+    pure $ L l $ \(b, d) -> do {+      c <- arr1 b;+      pure (c, d);+    };+  }++instance Functor m => Functor (ArrowProd r e t m b) where+  fmap f (ArrowProd x) = ArrowProd $ do {+    ~(L l arr1) <- x;+    pure $ L l $ \b -> f <$> arr1 b;+  }++instance Applicative m => Applicative (ArrowProd r e t m b) where+  pure c = ArrowProd $ pure $ L NoLoc $ \_ -> pure c+  ArrowProd x <*> ArrowProd y = ArrowProd $ do {+    ~(L xl xa) <- x;+    ~(L yl ya) <- y;+    pure $ L (xl <--> yl) $ \b -> do {+      xv <- xa b;+      yv <- ya b;+      pure $ xv yv;+    };+  }++instance Applicative m => Alternative (ArrowProd r e t m b) where+  empty = ArrowProd empty+  ArrowProd x <|> ArrowProd y = ArrowProd $ x <|> y++  -- We really need to define "many" and "some" here. Because they are special-cased in "Earley", see https://github.com/ollef/Earley/issues/55+  many (ArrowProd x) = ArrowProd $ do {+    list <- many x;+    pure $ L (foldl (<-->) NoLoc $ map (\(L l _) -> l) list) $ \b -> for list $ \(L _ arr1) -> arr1 b;+  }+  some x = (:) <$> x <*> many x++msym :: Applicative m => (t -> Maybe c) -> ArrowProd r e t m () c+msym f = ArrowProd $ terminal $ \(L l input) -> case f input of {+  Just result -> Just $ L l (\() -> pure result);+  Nothing -> Nothing;+}++sym :: (Applicative m, Eq t) => t -> ArrowProd r e t m () t+sym tok = msym (\input -> if input == tok then Just input else Nothing)++lift :: ArrowProd r e t m (m c) c+lift = ArrowProd $ pure $ L NoLoc id++loc :: Applicative m => ArrowProd r e t m b c -> ArrowProd r e t m b (L c)+loc (ArrowProd x) = ArrowProd $ do {+  ~(L l a) <- x;+  pure $ L l $ \b -> (L l) <$> a b;+}++arrowRule :: ArrowProd r e t m b c -> Grammar r (ArrowProd r e t m b c)+arrowRule (ArrowProd x) = ArrowProd <$> rule x++arrowParser :: (forall r. Grammar r (ArrowProd r e t m () c)) -> Parser e [L t] (m c)+arrowParser g = parser $ do {+  ArrowProd x <- g;+  pure $ do {+    ~(L _ a) <- x;+    pure $ a ();+  };+}++showLoc :: Loc -> String+showLoc NoLoc = "-:1:1-1:1"+showLoc (Loc (Pos file line1 col1 _) (Pos _ line2 col2 _)) = file ++ ":" ++ show line1 ++ ":" ++ show col1 ++ "-" ++ show line2 ++ ":" ++ show col2++positionToLoc :: [L a] -> Int -> Loc+positionToLoc list position = if position < length list then let L l _ = list !! position in l else if position == 0 then NoLoc else let L l _ = list !! (position - 1) in l++{- $Example+Example. Let's parse (and calculate) such expressions: "( 1 * 2 / 3 )". We will use tokenizer similar to "words", so we place spaces between all tokens. Parens () are not mandatory around every subterm, i. e. ( 1 * 2 ) is ok and 1 * 2 is ok, too.++>>> :set -XHaskell2010+>>> :set -XRecursiveDo+>>> :set -XArrows+>>> import Control.Arrow(returnA)+>>> import Text.Earley(fullParses, Report(..))+>>> import Control.Monad(when)+>>> import Language.Lexer.Applicative(Lexer, token, longest, whitespace, streamToEitherList, runLexer, LexicalError(..))+>>> import Text.Regex.Applicative(psym, string)+>>> import ParserUnbiasedChoiceMonadEmbedding+>>> :{+grammar :: Grammar r (ArrowProd r () String (Either String) () Int)+grammar = mdo { -- RecursiveDo+  num <- arrowRule $ msym $ \tok -> if all (`elem` ['0'..'9']) tok then Just $ read tok else Nothing;+  term <- arrowRule $ num <|> (sym "(" *> expr <* sym ")");+  expr <- arrowRule $ term <|> ((*) <$> (expr <* sym "*") <*> term) <|> (proc () -> do {+    L xl x <- loc expr -< ();+    sym "/" -< ();+    L yl y <- loc term -< ();+    lift -< when (y == 0) $ Left $ "Division by zero. Attempting to divide this expression: " ++ showLoc xl ++ " by this expression: " ++ showLoc yl;+    returnA -< div x y;+  });+  return expr;+}+lexer :: Lexer String -- Trivial lexer similar to "words"+lexer = mconcat [+    token $ longest $ many $ psym (/= ' '),+    whitespace $ longest $ string " "+  ]+:}++>>> :{+case streamToEitherList $ runLexer lexer "-" "6 / 3 * 21" of {+  Left (LexicalError (Pos _ line col _)) -> putStrLn $ "Lexer error at " ++ show line ++ " " ++ show col;+  Right tokens -> case fullParses (arrowParser grammar) tokens of {+    ([], Report pos _ _) -> putStrLn $ "Parser error: " ++ showLoc (positionToLoc tokens pos) ++ ": no parse";+    ([m], _) -> case m of {+      Left e -> putStrLn $ "Semantic error: " ++ e;+      Right x -> putStrLn $ "Result: " ++ show x;+    };+    (_, _) -> putStrLn "Ambiguity";+  };+}+:}+Result: 42+-}

+ README.md view

@@ -0,0 +1,3 @@+See https://hackage.haskell.org/package/parser-unbiased-choice-monad-embedding++You don't need to be registered on SourceHut to create bug report

+ doctests.hs view

@@ -0,0 +1,3 @@+{-# LANGUAGE Haskell2010 #-}+import Test.DocTest+main = doctest ["ParserUnbiasedChoiceMonadEmbedding.hs"]

+ parser-unbiased-choice-monad-embedding.cabal view

@@ -0,0 +1,48 @@+cabal-version:             3.0+name:                      parser-unbiased-choice-monad-embedding+version:                   0.0.0.1+synopsis:                  Parsing combinator library with unbiased choice and support for embedding arbitrary monad. You may use applicative or arrow style. Supports left recursion, location tracking, parsing and semantic error messages, heuristic ambiguity checking. Based on Earley+description:               Parsing combinator library with unbiased choice and support for embedding arbitrary monad. You may use applicative or arrow style. Supports left recursion, location tracking, parsing and semantic error messages, heuristic ambiguity checking. Based on Earley.++ Follow thread https://mail.haskell.org/pipermail/haskell-cafe/2021-June/134094.html for more info.++ You don't need to be registered on SourceHut to create bug report.++ If you think that this software is not needed or existing software already subsumes its functionality, please, tell me that, I will not be offended.+license:                   BSD-3-Clause+license-file:              LICENSE+maintainer:                Askar Safin <safinaskar@mail.ru>+category:                  Parsing+build-type:                Simple+extra-source-files:        README.md ChangeLog+source-repository head+  type: git+  location: https://git.sr.ht/~safinaskar/haskell-parser-unbiased-choice-monad-embedding+library+  exposed-modules: ParserUnbiasedChoiceMonadEmbedding+  -- base 4.13 removed Monad.fail, so "before base 4.13 there was nothing"+  build-depends:+    -- CI-BOUNDS-BEGIN+    base >= 4.13.0.0 && <= 4.15.0.0,+    containers >= 0.6.2.1 && <= 0.6.4.1,+    Earley >= 0.13.0.1 && <= 0.13.0.1,+    srcloc >= 0.6 && <= 0.6+    -- CI-BOUNDS-END+  default-language: Haskell2010+  ghc-options: -Wall -Wincomplete-patterns -Wincomplete-uni-patterns -Wmissing-export-lists -Wredundant-constraints -Wcompat -Wincomplete-record-updates -Wpartial-fields -Wunused-type-patterns -Wimplicit-lift++-- When following links below, keep in mind that "doctest" and "docspec" are two different words. Also keep in mind that "cabal-doctest" is not the only way to integrate cabal and doctest+-- I use simple way of cabal/doctest integration, described in https://github.com/sol/doctest/blob/d5b10128403663f7dc581477c7c7eb28a6f26f5a/README.markdown in section "Cabal integration"+-- Alternative way is to use "cabal-doctest" ( https://hackage.haskell.org/package/cabal-doctest-1.0.8 ), i. e. to write custom Setup.hs. But this requires boilerplate. Also, this can cause problems: https://github.com/ekmett/distributive/pull/53 , https://github.com/ekmett/distributive/issues/37+-- Another alternative way is not to integrate doctest and cabal at all and simply run "doctest" or "cabal-doctest" from continuous integration directly. But this will require us to specify all dependencies for tests in CI scripts. This is ugly+-- Note that author of cabal-doctest doesn't use this program anymore: https://github.com/ekmett/distributive/pull/53#issuecomment-744024619+-- So, we choose that way from doctest's README+-- To make it work "cabal v2-build" should write environment files. See https://stackoverflow.com/a/58027909 and https://github.com/ekmett/comonad/pull/58/commits/264f9057ea37cbffeb83744ff667ead4aa0f456a#diff-73f8a010e9b95aa9fe944c316576b12c2ec961272d428e38721112ecb1c1a98bR205 (note: this link shows how to run cabal-docspec, not cabal-doctest)+-- On docspec: the author doesn't think docspec is "useful for others": https://github.com/ekmett/distributive/pull/60#discussion_r549900441++test-suite doctests+  type: exitcode-stdio-1.0+  ghc-options: -threaded+  main-is: doctests.hs+  build-depends: base, doctest == 0.18.1, regex-applicative == 0.3.4, lexer-applicative == 2.1.0.2+  default-language: Haskell2010