mirror of
https://github.com/ilyakooo0/syntax.git
synced 2024-09-11 16:26:27 +03:00
Generalize to arrows.
This commit is contained in:
parent
519227b4aa
commit
98259cc26f
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{- |
|
||||
Module : Data.Syntax
|
||||
Description : Abstract syntax description.
|
||||
@ -24,8 +23,8 @@ import Prelude hiding (take, takeWhile)
|
||||
|
||||
import Control.Lens.Iso
|
||||
import Control.Lens.SemiIso
|
||||
import Control.SIArrow
|
||||
import Data.MonoTraversable
|
||||
import Data.SemiIsoFunctor
|
||||
import Data.Sequences hiding (take, takeWhile)
|
||||
|
||||
-- | An isomorphism between a sequence and a list of its elements.
|
||||
@ -41,56 +40,57 @@ packed = iso otoList fromList
|
||||
-- package.
|
||||
--
|
||||
-- Methods of this class try to mimic "Data.Attoparsec.Text" interface.
|
||||
class ( SemiIsoAlternative syn
|
||||
, SemiIsoMonad syn
|
||||
, IsSequence seq
|
||||
, Eq seq
|
||||
, Eq (Element seq))
|
||||
=> Syntax syn seq | syn -> seq
|
||||
class ( SIArrow syn
|
||||
, IsSequence (Seq syn)
|
||||
, Eq (Seq syn)
|
||||
, Eq (Element (Seq syn)))
|
||||
=> Syntax syn
|
||||
where
|
||||
-- | The sequence type used by this syntax.
|
||||
type Seq syn :: *
|
||||
|
||||
-- | Any character.
|
||||
anyChar :: syn (Element seq)
|
||||
anyChar :: syn () (Element (Seq syn))
|
||||
|
||||
-- | A specific character.
|
||||
char :: Element seq -> syn ()
|
||||
char :: Element (Seq syn) -> syn () ()
|
||||
char c = rev (exact c) /$/ anyChar
|
||||
|
||||
-- | Any character except the given one.
|
||||
notChar :: Element seq -> syn (Element seq)
|
||||
notChar :: Element (Seq syn) -> syn () (Element (Seq syn))
|
||||
notChar c = bifiltered (/= c) /$/ anyChar
|
||||
|
||||
-- | Any character satisfying a predicate.
|
||||
satisfy :: (Element seq -> Bool) -> syn (Element seq)
|
||||
satisfy :: (Element (Seq syn) -> Bool) -> syn () (Element (Seq syn))
|
||||
satisfy p = bifiltered p /$/ anyChar
|
||||
|
||||
-- | Transforms a character using a SemiIso and filters out values
|
||||
-- not satisfying the predicate.
|
||||
satisfyWith :: ASemiIso' a (Element seq) -> (a -> Bool) -> syn a
|
||||
satisfyWith :: ASemiIso' a (Element (Seq syn)) -> (a -> Bool) -> syn () a
|
||||
satisfyWith ai p = bifiltered p . ai /$/ anyChar
|
||||
|
||||
-- | A specific string.
|
||||
string :: seq -> syn ()
|
||||
string :: (Seq syn) -> syn () ()
|
||||
string s = rev (exact s) /$/ take (olength s)
|
||||
|
||||
-- | A string of length @n@.
|
||||
take :: Int -> syn seq
|
||||
take :: Int -> syn () (Seq syn)
|
||||
take n = packed /$/ sireplicate n anyChar
|
||||
|
||||
-- | Maximal string which elements satisfy a predicate.
|
||||
takeWhile :: (Element seq -> Bool) -> syn seq
|
||||
takeWhile :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
|
||||
takeWhile p = packed /$/ simany (satisfy p)
|
||||
|
||||
-- | Maximal non-empty string which elements satisfy a predicate.
|
||||
takeWhile1 :: (Element seq -> Bool) -> syn seq
|
||||
takeWhile1 :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
|
||||
takeWhile1 p = packed /$/ sisome (satisfy p)
|
||||
|
||||
-- | Maximal string which elements do not satisfy a predicate.
|
||||
takeTill :: (Element seq -> Bool) -> syn seq
|
||||
takeTill :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
|
||||
takeTill p = takeWhile (not . p)
|
||||
|
||||
-- | Maximal non-empty string which elements do not satisfy a predicate.
|
||||
takeTill1 :: (Element seq -> Bool) -> syn seq
|
||||
takeTill1 :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
|
||||
takeTill1 p = takeWhile1 (not . p)
|
||||
|
||||
{-# MINIMAL anyChar #-}
|
||||
|
@ -1,6 +1,5 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{- |
|
||||
Module : Data.Syntax.Char
|
||||
Description : Char specific combinators.
|
||||
@ -27,11 +26,11 @@ module Data.Syntax.Char (
|
||||
) where
|
||||
|
||||
import Control.Lens.SemiIso
|
||||
import Control.SIArrow
|
||||
import Data.Bits
|
||||
import Data.Char
|
||||
import Data.MonoTraversable
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.SemiIsoFunctor
|
||||
import Data.Syntax
|
||||
import Data.Syntax.Combinator
|
||||
import Data.Text (Text)
|
||||
@ -40,47 +39,47 @@ import Data.Text (Text)
|
||||
--
|
||||
-- Note: methods of this class do not have default implementations (for now),
|
||||
-- because their code is quite ugly and already written in most parser libraries.
|
||||
class (Syntax syn seq, Element seq ~ Char) => SyntaxChar syn seq where
|
||||
class (Syntax syn, Element (Seq syn) ~ Char) => SyntaxChar syn where
|
||||
-- | An unsigned decimal number.
|
||||
decimal :: Integral a => syn a
|
||||
decimal :: Integral a => syn () a
|
||||
|
||||
-- | An unsigned hexadecimal number.
|
||||
hexadecimal :: (Integral a, Bits a) => syn a
|
||||
hexadecimal :: (Integral a, Bits a) => syn () a
|
||||
|
||||
-- | A signed real number.
|
||||
realFloat :: RealFloat a => syn a
|
||||
realFloat :: RealFloat a => syn () a
|
||||
|
||||
-- | A scientific number.
|
||||
scientific :: syn Scientific
|
||||
scientific :: syn () Scientific
|
||||
|
||||
{-# MINIMAL decimal, hexadecimal, realFloat, scientific #-}
|
||||
|
||||
-- | An useful synonym for SyntaxChars with Text sequences.
|
||||
type SyntaxText syn = SyntaxChar syn Text
|
||||
type SyntaxText syn = (SyntaxChar syn, Seq syn ~ Text)
|
||||
|
||||
-- | A number with an optional leading '+' or '-' sign character.
|
||||
signed :: (Real a, SyntaxChar syn seq) => syn a -> syn a
|
||||
signed :: (Real a, SyntaxChar syn) => syn () a -> syn () a
|
||||
signed n = _Negative /$/ char '-' */ n
|
||||
/|/ opt_ (char '+') */ n
|
||||
/+/ opt_ (char '+') */ n
|
||||
|
||||
-- | Accepts zero or more spaces. Generates a single space.
|
||||
spaces :: SyntaxChar syn seq => syn ()
|
||||
spaces :: SyntaxChar syn => syn () ()
|
||||
spaces = opt spaces1
|
||||
|
||||
-- | Accepts zero or more spaces. Generates no output.
|
||||
spaces_ :: SyntaxChar syn seq => syn ()
|
||||
spaces_ :: SyntaxChar syn => syn () ()
|
||||
spaces_ = opt_ spaces1
|
||||
|
||||
-- | Accepts one or more spaces. Generates a single space.
|
||||
spaces1 :: SyntaxChar syn seq => syn ()
|
||||
spaces1 :: SyntaxChar syn => syn () ()
|
||||
spaces1 = constant (opoint ' ') /$/ takeWhile1 isSpace
|
||||
|
||||
-- | Accepts a single newline. Generates a newline.
|
||||
endOfLine :: SyntaxChar syn seq => syn ()
|
||||
endOfLine :: SyntaxChar syn => syn () ()
|
||||
endOfLine = char '\n'
|
||||
|
||||
-- | A decimal digit.
|
||||
digitDec :: SyntaxChar syn seq => syn Int
|
||||
digitDec :: SyntaxChar syn => syn () Int
|
||||
digitDec = semiIso toChar toInt /$/ anyChar
|
||||
where toInt c | isDigit c = Right (digitToInt c)
|
||||
| otherwise = Left ("Expected a decimal digit, got " ++ [c])
|
||||
@ -88,7 +87,7 @@ digitDec = semiIso toChar toInt /$/ anyChar
|
||||
| otherwise = Left ("Expected a decimal digit, got number " ++ show i)
|
||||
|
||||
-- | An octal digit.
|
||||
digitOct :: SyntaxChar syn seq => syn Int
|
||||
digitOct :: SyntaxChar syn => syn () Int
|
||||
digitOct = semiIso toChar toInt /$/ anyChar
|
||||
where toInt c | isOctDigit c = Right (digitToInt c)
|
||||
| otherwise = Left ("Expected an octal digit, got " ++ [c])
|
||||
@ -96,7 +95,7 @@ digitOct = semiIso toChar toInt /$/ anyChar
|
||||
| otherwise = Left ("Expected an octal digit, got number " ++ show i)
|
||||
|
||||
-- | A hex digit.
|
||||
digitHex :: SyntaxChar syn seq => syn Int
|
||||
digitHex :: SyntaxChar syn => syn () Int
|
||||
digitHex = semiIso toChar toInt /$/ anyChar
|
||||
where toInt c | isHexDigit c = Right (digitToInt c)
|
||||
| otherwise = Left ("Expected a hex digit, got " ++ [c])
|
||||
|
@ -13,40 +13,40 @@ module Data.Syntax.Combinator where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Lens.SemiIso
|
||||
import Data.SemiIsoFunctor
|
||||
import Control.SIArrow
|
||||
|
||||
-- | One or zero occurences of @f@.
|
||||
optional :: SemiIsoAlternative f => f a -> f (Maybe a)
|
||||
optional f = _Just /$/ f /|/ sipure _Nothing
|
||||
optional :: SIArrow cat => cat () a -> cat () (Maybe a)
|
||||
optional f = _Just /$/ f /+/ sipure _Nothing
|
||||
|
||||
-- | Like 'optional', but specialized for @()@.
|
||||
opt :: SemiIsoAlternative f => f () -> f ()
|
||||
opt f = f /|/ sipure id
|
||||
opt :: SIArrow cat => cat () () -> cat () ()
|
||||
opt f = f /+/ sipure id
|
||||
|
||||
-- | Parser one or zero occurences of @f@, but prints nothing.
|
||||
opt_ :: SemiIsoAlternative f => f () -> f ()
|
||||
opt_ :: SIArrow cat => cat () () -> cat () ()
|
||||
opt_ f = semiIso (const (Left "opt_")) Right /$/ f
|
||||
/|/ sipure id
|
||||
/+/ sipure id
|
||||
|
||||
-- | @manyTill p end@ applies action p zero or more times until action
|
||||
-- end succeeds, and returns the list of values returned by p.
|
||||
manyTill :: SemiIsoAlternative f => f a -> f () -> f [a]
|
||||
manyTill :: SIArrow cat => cat () a -> cat () () -> cat () [a]
|
||||
manyTill p end = _Empty /$/ end
|
||||
/|/ _Cons /$/ p /*/ manyTill p end
|
||||
/+/ _Cons /$/ p /*/ manyTill p end
|
||||
|
||||
-- | Zero or more occurences of @v@ separated by @s@.
|
||||
sepBy :: SemiIsoAlternative f => f a -> f () -> f [a]
|
||||
sepBy v s = sepBy1 v s /|/ sipure _Empty
|
||||
sepBy :: SIArrow cat => cat () a -> cat () () -> cat () [a]
|
||||
sepBy v s = sepBy1 v s /+/ sipure _Empty
|
||||
|
||||
-- | One or more occurences of @v@ separated by @s@.
|
||||
sepBy1 :: SemiIsoAlternative f => f a -> f () -> f [a]
|
||||
sepBy1 v s = _Cons /$/ v /*/ (s */ sepBy1 v s /|/ sipure _Empty)
|
||||
sepBy1 :: SIArrow cat => cat () a -> cat () () -> cat () [a]
|
||||
sepBy1 v s = _Cons /$/ v /*/ (s */ sepBy1 v s /+/ sipure _Empty)
|
||||
|
||||
-- | Tries to apply the actions in the list in order, until one of
|
||||
-- them succeeds. Returns the value of the succeeding action.
|
||||
choice :: SemiIsoAlternative f => [f a] -> f a
|
||||
choice = foldr (/|/) (sifail "choice: all alternatives failed")
|
||||
choice :: SIArrow cat => [cat () a] -> cat () a
|
||||
choice = foldr (/+/) (sifail "choice: all alternatives failed")
|
||||
|
||||
-- | Combine two alternatives.
|
||||
eitherOf :: SemiIsoAlternative f => f a -> f b -> f (Either a b)
|
||||
eitherOf a b = _Left /$/ a /|/ _Right /$/ b
|
||||
eitherOf :: SIArrow cat => cat () a -> cat () b -> cat () (Either a b)
|
||||
eitherOf a b = _Left /$/ a /+/ _Right /$/ b
|
||||
|
@ -1,16 +1,16 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{- |
|
||||
Module : Data.Syntax.Indent
|
||||
Description : Indentation.
|
||||
Description : Simple indentation.
|
||||
Copyright : (c) Paweł Nowak
|
||||
License : MIT
|
||||
|
||||
Maintainer : Paweł Nowak <pawel834@gmail.com>
|
||||
Stability : experimental
|
||||
|
||||
Provides a very simple indentation as a \"monad\" transformer.
|
||||
Provides a very simple indentation as a category transformer (a functor from Cat to Cat).
|
||||
-}
|
||||
module Data.Syntax.Indent (
|
||||
Indent,
|
||||
@ -19,59 +19,52 @@ module Data.Syntax.Indent (
|
||||
indented
|
||||
) where
|
||||
|
||||
import Data.SemiIsoFunctor
|
||||
import Control.Category
|
||||
import Control.Category.Reader
|
||||
import Control.SIArrow
|
||||
import Data.Syntax
|
||||
import Data.Syntax.Char
|
||||
import Data.Syntax.Combinator
|
||||
import Prelude hiding (takeWhile, take)
|
||||
import Prelude hiding (takeWhile, take, id, (.))
|
||||
|
||||
-- | Adds indentation to a syntax description.
|
||||
newtype Indent m a = Indent { unIndent :: (Int, m ()) -> m a }
|
||||
newtype Indent cat a b = Indent { unIndent :: ReaderCT (Int, cat () ()) cat a b }
|
||||
deriving (Category, Products, Coproducts, CategoryPlus, SIArrow)
|
||||
|
||||
instance SemiIsoFunctor m => SemiIsoFunctor (Indent m) where
|
||||
simap f (Indent g) = Indent $ \i -> simap f (g i)
|
||||
instance CategoryTrans Indent where
|
||||
clift = Indent . clift
|
||||
|
||||
instance SemiIsoApply m => SemiIsoApply (Indent m) where
|
||||
sipure ai = Indent $ \_ -> sipure ai
|
||||
Indent f /*/ Indent g = Indent $ \i -> f i /*/ g i
|
||||
instance Syntax syn => Syntax (Indent syn) where
|
||||
type Seq (Indent syn) = Seq syn
|
||||
anyChar = clift anyChar
|
||||
char = clift . char
|
||||
notChar = clift . notChar
|
||||
satisfy = clift . satisfy
|
||||
satisfyWith ai = clift . satisfyWith ai
|
||||
string = clift . string
|
||||
take = clift . take
|
||||
takeWhile = clift . takeWhile
|
||||
takeWhile1 = clift . takeWhile1
|
||||
takeTill = clift . takeTill
|
||||
takeTill1 = clift . takeTill1
|
||||
|
||||
instance SemiIsoAlternative m => SemiIsoAlternative (Indent m) where
|
||||
siempty = Indent $ \_ -> siempty
|
||||
Indent f /|/ Indent g = Indent $ \i -> f i /|/ g i
|
||||
|
||||
instance SemiIsoMonad m => SemiIsoMonad (Indent m) where
|
||||
(Indent m) //= f = Indent $ \i -> m i //= (\x -> unIndent (f x) i)
|
||||
|
||||
instance SemiIsoFix m => SemiIsoFix (Indent m) where
|
||||
sifix f = Indent $ \i -> sifix $ \y -> unIndent (f y) i
|
||||
|
||||
instance Syntax syn seq => Syntax (Indent syn) seq where
|
||||
anyChar = Indent $ const anyChar
|
||||
char = Indent . const . char
|
||||
notChar = Indent . const . notChar
|
||||
satisfy = Indent . const . satisfy
|
||||
satisfyWith ai = Indent . const . satisfyWith ai
|
||||
string = Indent . const . string
|
||||
take = Indent . const . take
|
||||
takeWhile = Indent . const . takeWhile
|
||||
takeWhile1 = Indent . const . takeWhile1
|
||||
takeTill = Indent . const . takeTill
|
||||
takeTill1 = Indent . const . takeTill1
|
||||
|
||||
instance SyntaxChar syn seq => SyntaxChar (Indent syn) seq where
|
||||
decimal = Indent $ const decimal
|
||||
scientific = Indent $ const scientific
|
||||
instance SyntaxChar syn => SyntaxChar (Indent syn) where
|
||||
decimal = clift decimal
|
||||
hexadecimal = clift hexadecimal
|
||||
scientific = clift scientific
|
||||
realFloat = clift realFloat
|
||||
|
||||
-- | @runIndent m tab@ runs the 'Indent' transformer using @tab@ once for each
|
||||
-- level of indentation.
|
||||
runIndent :: Indent m a -> m () -> m a
|
||||
runIndent = ($ 0) . curry . unIndent
|
||||
runIndent :: Indent cat a b -> cat () () -> cat a b
|
||||
runIndent (Indent m) tab = runReaderCT m (0, tab)
|
||||
|
||||
-- | Inserts a new line and correct indentation, but does not
|
||||
-- require any formatting when parsing (it just skips all white space).
|
||||
breakLine :: SyntaxChar syn seq => Indent syn ()
|
||||
breakLine = Indent $ \(i, tab) -> opt (char '\n') /* opt (sireplicate_ i tab) /* spaces_
|
||||
breakLine :: SyntaxChar syn => Indent syn () ()
|
||||
breakLine = Indent . ReaderCT $ \(i, tab) ->
|
||||
opt (char '\n') /* opt (sireplicate_ i tab) /* spaces_
|
||||
|
||||
-- | Increases the indentation level of its argument by one.
|
||||
indented :: Indent m a -> Indent m a
|
||||
indented (Indent f) = Indent $ \(i, tab) -> f (i + 1, tab)
|
||||
indented :: Indent cat a b -> Indent cat a b
|
||||
indented (Indent f) = Indent . ReaderCT $ \(i, tab) -> runReaderCT f (i + 1, tab)
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: syntax
|
||||
version: 0.3.0.0
|
||||
version: 1.0.0.0
|
||||
synopsis: Syntax descriptions for unified parsing and pretty-printing.
|
||||
description:
|
||||
'syntax' allows you to write a single syntax description and instantiate is both as a parser and a pretty printer.
|
||||
@ -46,5 +46,5 @@ library
|
||||
Data.Syntax.Char
|
||||
Data.Syntax.Combinator
|
||||
Data.Syntax.Indent
|
||||
build-depends: base >= 4 && < 5, mono-traversable, lens >= 4, semi-iso >= 0.5.0, scientific >= 0.3, text
|
||||
build-depends: base >= 4 && < 5, mono-traversable, lens >= 4, semi-iso >= 1.0.0.0, scientific >= 0.3, text
|
||||
default-language: Haskell2010
|
||||
|
Loading…
Reference in New Issue
Block a user