ilyakooo0/syntax
1
0
Fork 0
mirror of https://github.com/ilyakooo0/syntax.git synced 2024-09-11 16:26:27 +03:00
Code Issues Projects Releases Wiki Activity

Generalize to arrows.

Browse Source
This commit is contained in:
Paweł Nowak 2014-12-11 01:47:18 +01:00
parent 519227b4aa
commit 98259cc26f
5 changed files with 92 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
Data/Syntax.hs
View File

@ -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 #-}

33
Data/Syntax/Char.hs
View File

@ -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])

34
Data/Syntax/Combinator.hs
View File

@ -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

81
Data/Syntax/Indent.hs
View File

@ -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)

4
syntax.cabal
View File

@ -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