git.iko.soy/syntax
on 3c01517 help sign in
64f67b7
swap
0 ahead, 42 behind
Data/Syntax.hsdeleted−188
since splitsnapshots
unifiedsplit
@@ -1,188 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE DefaultSignatures #-}
4−{- |
5−Module : Data.Syntax
6−Description : Abstract syntax description.
7−Copyright : (c) Paweł Nowak
8−License : MIT
9−
10−Maintainer : Paweł Nowak <pawel834@gmail.com>
11−Stability : experimental
12−
13−Reversible parsing and pretty-printing.
14−-}
15−module Data.Syntax (
16− -- * Syntax.
17− Syntax(..),
18− Isolable(..),
19− -- * Common isomorphisms.
20− packed
21− ) where
22−
23−import Prelude hiding (take, takeWhile, id, (.))
24−
25−import Control.Category
26−import Control.Category.Reader
27−import Control.Category.Structures
28−import Control.Lens.Iso
29−import Control.Lens.SemiIso
30−import Control.SIArrow
31−import Data.MonoTraversable
32−import Data.Sequences hiding (take, takeWhile, replicate)
33−import qualified Data.Vector as V
34−import qualified Data.Vector.Unboxed as VU
35−
36−-- | An isomorphism between a sequence and a list of its elements.
37−packed :: IsSequence seq => Iso' seq [Element seq]
38−packed = iso otoList fromList
39−
40−-- | An abstract syntax description based on semi-isomorphisms.
41−--
42−-- This class can be implemented by both parsers and printers.
43−--
44−-- The usual use is to write a polymorphic syntax description and instantiate it
45−-- both as a parser and a printer. Examples are available in 'syntax-example' and
46−-- 'syntax-example-json' packages.
47−--
48−-- Methods of this class try to mimic "Data.Attoparsec.Text" interface.
49−class ( SIArrow syn
50− , IsSequence (Seq syn)
51− , Eq (Seq syn)
52− , Eq (Element (Seq syn)))
53− => Syntax syn
54− where
55− -- | The sequence type used by this syntax.
56− type Seq syn :: *
57−
58− -- | Any character.
59− anyChar :: syn () (Element (Seq syn))
60−
61− -- | A specific character.
62− char :: Element (Seq syn) -> syn () ()
63− char c = rev (exact c) /$/ anyChar
64−
65− -- | Any character except the given one.
66− notChar :: Element (Seq syn) -> syn () (Element (Seq syn))
67− notChar c = bifiltered (/= c) /$/ anyChar
68−
69− -- | Any character satisfying a predicate.
70− satisfy :: (Element (Seq syn) -> Bool) -> syn () (Element (Seq syn))
71− satisfy p = bifiltered p /$/ anyChar
72−
73− -- | Transforms a character using a SemiIso and filters out values
74− -- not satisfying the predicate.
75− satisfyWith :: ASemiIso' a (Element (Seq syn)) -> (a -> Bool) -> syn () a
76− satisfyWith ai p = bifiltered p . ai /$/ anyChar
77−
78− -- | A specific string.
79− string :: Seq syn -> syn () ()
80− string s = rev (exact s) /$/ take (olength s)
81−
82− -- | A string of length @n@.
83− take :: Int -> syn () (Seq syn)
84− take n = packed /$/ sireplicate n anyChar
85−
86− -- | Maximal string which elements satisfy a predicate.
87− takeWhile :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
88− takeWhile p = packed /$/ simany (satisfy p)
89−
90− -- | Maximal non-empty string which elements satisfy a predicate.
91− takeWhile1 :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
92− takeWhile1 p = packed /$/ sisome (satisfy p)
93−
94− -- | Maximal string which elements do not satisfy a predicate.
95− takeTill :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
96− takeTill p = takeWhile (not . p)
97−
98− -- | Maximal non-empty string which elements do not satisfy a predicate.
99− takeTill1 :: (Element (Seq syn) -> Bool) -> syn () (Seq syn)
100− takeTill1 p = takeWhile1 (not . p)
101−
102− -- | Constant size vector. The default implementation uses lists, but
103− -- "syntax-attoparsec" and "syntax-printer" override it with an efficient
104− -- implementation that works on a vector directly.
105− --
106− -- @vecN n e@ describes a size @n@ vector with elements @e@.
107− --
108− -- Also see 'Data.Syntax.Combinator.vec'.
109− vecN :: Int -> syn () a -> syn () (V.Vector a)
110− vecN n e = packed /$/ sireplicate n e
111−
112− -- | Constant size vector with index-aware element. The default implementation
113− -- uses lists, but "syntax-attoparsec" and "syntax-printer" override it with an
114− -- efficient implementation that works on a vector directly.
115− --
116− -- @ivecN n e@ describes a size @n@ vector with elements @e@. Each element
117− -- gets its index and should output a value and the index unchanged.
118− --
119− -- Also see 'Data.Syntax.Combinator.ivec'.
120− ivecN :: Int -> syn Int (Int, a) -> syn () (V.Vector a)
121− ivecN n e = (packed /$/)
122− $ sisequence
123− $ map (\(i, e') -> constant i ^>> e'
124− >>> first (sipure (constant i))
125− >># unit . swapped)
126− $ zip [0 .. n-1] (replicate n e)
127−
128− -- | Constant size unboxed vector. The default implementation uses lists, but
129− -- "syntax-attoparsec" and "syntax-printer" override it with an efficient
130− -- implementation that works on a vector directly.
131− --
132− -- @vecN n e@ describes a size @n@ vector with elements @e@.
133− --
134− -- Also see 'Data.Syntax.Combinator.vec'.
135− uvecN :: VU.Unbox a => Int -> syn () a -> syn () (VU.Vector a)
136− uvecN n e = packed /$/ sireplicate n e
137−
138− -- | Constant size unboxed vector with index-aware element. The default implementation
139− -- uses lists, but "syntax-attoparsec" and "syntax-printer" override it with an
140− -- efficient implementation that works on a vector directly.
141− --
142− -- @ivecN n e@ describes a size @n@ vector with elements @e@. Each element
143− -- gets its index and should output a value and the index unchanged.
144− --
145− -- Also see 'Data.Syntax.Combinator.ivec'.
146− uivecN :: VU.Unbox a => Int -> syn Int (Int, a) -> syn () (VU.Vector a)
147− uivecN n e = (packed /$/)
148− $ sisequence
149− $ map (\(i, e') -> constant i ^>> e'
150− >>> first (sipure (constant i))
151− >># unit . swapped)
152− $ zip [0 .. n-1] (replicate n e)
153−
154− {-# MINIMAL anyChar #-}
155−
156−instance Syntax syn => Syntax (ReaderCT env syn) where
157− type Seq (ReaderCT env syn) = Seq syn
158− anyChar = clift anyChar
159− char = clift . char
160− notChar = clift . notChar
161− satisfy = clift . satisfy
162− satisfyWith ai = clift . satisfyWith ai
163− string = clift . string
164− take = clift . take
165− takeWhile = clift . takeWhile
166− takeWhile1 = clift . takeWhile1
167− takeTill = clift . takeTill
168− takeTill1 = clift . takeTill1
169− vecN n e = ReaderCT $ vecN n . runReaderCT e
170− ivecN n e = ReaderCT $ ivecN n . runReaderCT e
171− uvecN n e = ReaderCT $ uvecN n . runReaderCT e
172− uivecN n e = ReaderCT $ uivecN n . runReaderCT e
173−
174−-- | Execute a computation in an isolated context.
175−--
176−-- The motivating example: you want to write a function
177−--
178−-- > serializeList :: Syntax syn => syn () a -> syn () [a]
179−--
180−-- Notice that we cannot just use simany, because the first @syn () a@
181−-- could eat the entire sequence (even though we printed more than 1 value!), so
182−-- we have to insert some kind of separators between the element. But how can we
183−-- be sure that @syn () a@ will not eat our separators? We can't! Thats why we
184−-- have to do the parsing in two stages: first extract the sequence between separators,
185−-- then run the @syn () a@ on this sequence.
186−class Syntax syn => Isolable syn where
187− -- | Turns a computation into one executed in an isolated context.
188− isolate :: syn () b -> syn (Seq syn) b
Data/Syntax/Char.hsdeleted−111
@@ -1,111 +0,0 @@
1−{-# LANGUAGE TypeFamilies #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{- |
4−Module : Data.Syntax.Char
5−Description : Char specific combinators.
6−Copyright : (c) Paweł Nowak
7−License : MIT
8−
9−Maintainer : Paweł Nowak <pawel834@gmail.com>
10−Stability : experimental
11−
12−Common combinators that work with sequences of chars.
13−
14−-}
15−module Data.Syntax.Char (
16− SyntaxChar(..),
17− SyntaxText,
18− signed,
19− spaces,
20− spaces_,
21− spaces1,
22− endOfLine,
23− digitDec,
24− digitOct,
25− digitHex
26− ) where
27−
28−import Control.Category.Reader
29−import Control.Category.Structures
30−import Control.Lens.SemiIso
31−import Control.SIArrow
32−import Data.Bits
33−import Data.Char
34−import Data.MonoTraversable
35−import Data.Scientific (Scientific)
36−import Data.Syntax
37−import Data.Syntax.Combinator
38−import Data.Text (Text)
39−
40−-- | Syntax constrainted to sequences of chars.
41−--
42−-- Note: methods of this class do not have default implementations (for now),
43−-- because their code is quite ugly and already written in most parser libraries.
44−class (Syntax syn, Element (Seq syn) ~ Char) => SyntaxChar syn where
45− -- | An unsigned decimal number.
46− decimal :: Integral a => syn () a
47−
48− -- | An unsigned hexadecimal number.
49− hexadecimal :: (Integral a, Bits a) => syn () a
50−
51− -- | A signed real number.
52− realFloat :: RealFloat a => syn () a
53−
54− -- | A scientific number.
55− scientific :: syn () Scientific
56−
57− {-# MINIMAL decimal, hexadecimal, realFloat, scientific #-}
58−
59−instance SyntaxChar syn => SyntaxChar (ReaderCT env syn) where
60− decimal = clift decimal
61− hexadecimal = clift hexadecimal
62− scientific = clift scientific
63− realFloat = clift realFloat
64−
65−-- | An useful synonym for SyntaxChars with Text sequences.
66−type SyntaxText syn = (SyntaxChar syn, Seq syn ~ Text)
67−
68−-- | A number with an optional leading '+' or '-' sign character.
69−signed :: (Real a, SyntaxChar syn) => syn () a -> syn () a
70−signed n = _Negative /$/ char '-' */ n
71− /+/ opt_ (char '+') */ n
72−
73−-- | Accepts zero or more spaces. Generates a single space.
74−spaces :: SyntaxChar syn => syn () ()
75−spaces = opt spaces1
76−
77−-- | Accepts zero or more spaces. Generates no output.
78−spaces_ :: SyntaxChar syn => syn () ()
79−spaces_ = opt_ spaces1
80−
81−-- | Accepts one or more spaces. Generates a single space.
82−spaces1 :: SyntaxChar syn => syn () ()
83−spaces1 = constant (opoint ' ') /$/ takeWhile1 isSpace
84−
85−-- | Accepts a single newline. Generates a newline.
86−endOfLine :: SyntaxChar syn => syn () ()
87−endOfLine = char '\n'
88−
89−-- | A decimal digit.
90−digitDec :: SyntaxChar syn => syn () Int
91−digitDec = semiIso toChar toInt /$/ anyChar
92− where toInt c | isDigit c = Right (digitToInt c)
93− | otherwise = Left ("Expected a decimal digit, got " ++ [c])
94− toChar i | i >= 0 && i <= 9 = Right (intToDigit i)
95− | otherwise = Left ("Expected a decimal digit, got number " ++ show i)
96−
97−-- | An octal digit.
98−digitOct :: SyntaxChar syn => syn () Int
99−digitOct = semiIso toChar toInt /$/ anyChar
100− where toInt c | isOctDigit c = Right (digitToInt c)
101− | otherwise = Left ("Expected an octal digit, got " ++ [c])
102− toChar i | i >= 0 && i <= 7 = Right (intToDigit i)
103− | otherwise = Left ("Expected an octal digit, got number " ++ show i)
104−
105−-- | A hex digit.
106−digitHex :: SyntaxChar syn => syn () Int
107−digitHex = semiIso toChar toInt /$/ anyChar
108− where toInt c | isHexDigit c = Right (digitToInt c)
109− | otherwise = Left ("Expected a hex digit, got " ++ [c])
110− toChar i | i >= 0 && i <= 15 = Right (intToDigit i)
111− | otherwise = Left ("Expected a hex digit, got number " ++ show i)
Data/Syntax/Combinator.hsdeleted−190
@@ -1,190 +0,0 @@
1−{-# LANGUAGE RankNTypes #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{- |
5−Module : Data.Syntax.Combinator
6−Description : Combinators that work with any sequence type.
7−Copyright : (c) Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2014, Paweł Nowak 2014
8−License : MIT
9−
10−Maintainer : Paweł Nowak <pawel834@gmail.com>
11−Stability : experimental
12−
13−Combinators that work with any sequence type.
14−-}
15−module Data.Syntax.Combinator
16− (
17− -- * Combinators.
18− optional,
19− opt,
20− opt_,
21− choice,
22− eitherOf,
23−
24− -- * Lists.
25− manyTill,
26− sepBy,
27− sepBy1,
28−
29− -- * Arrowized combinators.
30− takeArr,
31−
32− -- * Vectors.
33− vecNSepBy,
34− ivecNSepBy,
35− vec,
36− vecSepBy,
37− ivec,
38− ivecSepBy,
39−
40− -- * Unboxed vectors.
41− uvecNSepBy,
42− uivecNSepBy,
43− uvec,
44− uvecSepBy,
45− uivec,
46− uivecSepBy
47− ) where
48−
49−import Control.Category
50−import Control.Category.Structures
51−import Control.Lens
52−import Control.Lens.SemiIso
53−import Control.SIArrow
54−import qualified Data.MonoTraversable as Seq
55−import Data.Syntax
56−import qualified Data.Vector as V
57−import qualified Data.Vector.Unboxed as VU
58−import Prelude hiding (id, (.), take)
59−
60−-- | One or zero occurences of @f@.
61−optional :: SIArrow cat => cat () a -> cat () (Maybe a)
62−optional f = _Just /$/ f /+/ sipure _Nothing
63−
64−-- | Like 'optional', but specialized for @()@.
65−opt :: SIArrow cat => cat () () -> cat () ()
66−opt f = f /+/ sipure id
67−
68−-- | Parser one or zero occurences of @f@, but prints nothing.
69−opt_ :: SIArrow cat => cat () () -> cat () ()
70−opt_ f = semiIso (const (Left "opt_")) Right /$/ f
71− /+/ sipure id
72−
73−-- | Tries to apply the actions in the list in order, until one of
74−-- them succeeds. Returns the value of the succeeding action.
75−choice :: SIArrow cat => [cat () a] -> cat () a
76−choice = foldr (/+/) (sifail "choice: all alternatives failed")
77−
78−-- | Combine two alternatives.
79−eitherOf :: SIArrow cat => cat () a -> cat () b -> cat () (Either a b)
80−eitherOf a b = _Left /$/ a /+/ _Right /$/ b
81−
82−-- | @manyTill p end@ applies action p zero or more times until action
83−-- end succeeds, and returns the list of values returned by p.
84−manyTill :: SIArrow cat => cat () a -> cat () () -> cat () [a]
85−manyTill p end = _Empty /$/ end
86− /+/ _Cons /$/ p /*/ manyTill p end
87−
88−-- | Zero or more occurences of @v@ separated by @s@.
89−sepBy :: SIArrow cat => cat () a -> cat () () -> cat () [a]
90−sepBy v s = sepBy1 v s /+/ sipure _Empty
91−
92−-- | One or more occurences of @v@ separated by @s@.
93−sepBy1 :: SIArrow cat => cat () a -> cat () () -> cat () [a]
94−sepBy1 v s = _Cons /$/ v /*/ (s */ sepBy1 v s /+/ sipure _Empty)
95−
96−-- | A string of given length.
97−takeArr :: Syntax syn => syn Int (Seq syn)
98−takeArr = sibind $ iso (\n -> constant n #>> take n)
99− (\s -> constant (Seq.olength s) #>> take (Seq.olength s))
100−
101−-- | Constant size vector with separators.
102−--
103−-- @vecNSepBy n e sep@ describes a size @n@ vector with elements @e@ separated by @sep@.
104−vecNSepBy :: Syntax syn => Int -> syn () a -> syn () () -> syn () (V.Vector a)
105−vecNSepBy n e sep = ivecNSepBy n (unit ^>> second e) sep
106−
107−-- | Constant size vector with separators and index-aware elements.
108−--
109−-- @ivecNSepBy n e sep@ describes a size @n@ vector with elements @e@ separated by @sep@.
110−-- Each element gets its index and should output a value and the index unchanged.
111−ivecNSepBy :: Syntax syn => Int -> syn Int (Int, a) -> syn () () -> syn () (V.Vector a)
112−ivecNSepBy n e sep = ivecN n $ sibind $ iso el (el . fst)
113− where
114− el k | k < n - 1 = unit ^>> e *** sep >># unit
115− | otherwise = e
116−
117−-- | Runtime sized vector. The size can depend on the result of some computation.
118−--
119−-- @vec e@ describes a vector with elements @e@.
120−vec :: Syntax syn => syn () a -> syn Int (V.Vector a)
121−vec e = vecSepBy e (siarr id)
122−
123−-- | Runtime sized vector with separators. The size can depend on the result of some
124−-- computation.
125−--
126−-- @vecSepBy e sep@ describes a vector with elements @e@ separated by @sep@.
127−vecSepBy :: Syntax syn => syn () a -> syn () () -> syn Int (V.Vector a)
128−vecSepBy e sep = ivecSepBy (unit ^>> second e) sep
129−
130−-- | Runtime sized vector with index-aware elements. The size can depend on the result
131−-- of some computation.
132−--
133−-- @ivec e@ describes a vector with elements @e@.
134−ivec :: Syntax syn => syn Int (Int, a) -> syn Int (V.Vector a)
135−ivec e = ivecSepBy e (siarr id)
136−
137−-- | Runtime sized vector with index-aware elements and separators. The size can depend
138−-- on the result of some computation.
139−--
140−-- @ivecSepBy e sep@ describes a vector with elements @e@ separated by @sep@.
141−ivecSepBy :: Syntax syn => syn Int (Int, a) -> syn () () -> syn Int (V.Vector a)
142−ivecSepBy e sep = sibind $ iso (\n -> constant n #>> ivecNSepBy n e sep)
143− (\v -> constant (V.length v) #>> ivecNSepBy (V.length v) e sep)
144−
145−-- | Constant size unboxed vector with separators.
146−--
147−-- @uvecNSepBy n e sep@ describes a size @n@ vector with elements @e@ separated by @sep@.
148−uvecNSepBy :: (Syntax syn, VU.Unbox a) => Int -> syn () a -> syn () () -> syn () (VU.Vector a)
149−uvecNSepBy n e sep = uivecNSepBy n (unit ^>> second e) sep
150−
151−-- | Constant size unboxed vector with separators and index-aware elements.
152−--
153−-- @uivecNSepBy n e sep@ describes a size @n@ vector with elements @e@ separated by @sep@.
154−-- Each element gets its index and should output a value and the index unchanged.
155−uivecNSepBy :: (Syntax syn, VU.Unbox a) => Int -> syn Int (Int, a)
156− -> syn () () -> syn () (VU.Vector a)
157−uivecNSepBy n e sep = uivecN n $ sibind $ iso el (el . fst)
158− where
159− el k | k < n - 1 = unit ^>> e *** sep >># unit
160− | otherwise = e
161−
162−-- | Runtime sized unboxed vector. The size can depend on the result of some computation.
163−--
164−-- @uvec e@ describes a vector with elements @e@.
165−uvec :: (Syntax syn, VU.Unbox a) => syn () a -> syn Int (VU.Vector a)
166−uvec e = uvecSepBy e (siarr id)
167−
168−-- | Runtime sized unboxed vector with separators. The size can depend on the result of some
169−-- computation.
170−--
171−-- @uvecSepBy e sep@ describes a vector with elements @e@ separated by @sep@.
172−uvecSepBy :: (Syntax syn, VU.Unbox a) => syn () a -> syn () () -> syn Int (VU.Vector a)
173−uvecSepBy e sep = uivecSepBy (unit ^>> second e) sep
174−
175−-- | Runtime sized unboxed vector with index-aware elements. The size can depend on the result
176−-- of some computation.
177−--
178−-- @uivec e@ describes a vector with elements @e@.
179−uivec :: (Syntax syn, VU.Unbox a) => syn Int (Int, a) -> syn Int (VU.Vector a)
180−uivec e = uivecSepBy e (siarr id)
181−
182−-- | Runtime sized unboxed vector with index-aware elements and separators. The size can depend
183−-- on the result of some computation.
184−--
185−-- @uivecSepBy e sep@ describes a vector with elements @e@ separated by @sep@.
186−uivecSepBy :: (Syntax syn, VU.Unbox a) => syn Int (Int, a)
187− -> syn () () -> syn Int (VU.Vector a)
188−uivecSepBy e sep = sibind $ iso (\n -> constant n #>> uivecNSepBy n e sep)
189− (\v -> constant (VU.length v)
190− #>> uivecNSepBy (VU.length v) e sep)
Data/Syntax/Indent.hsdeleted−73
@@ -1,73 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE TypeFamilies #-}
4−{- |
5−Module : Data.Syntax.Indent
6−Description : Simple indentation.
7−Copyright : (c) Paweł Nowak
8−License : MIT
9−
10−Maintainer : Paweł Nowak <pawel834@gmail.com>
11−Stability : experimental
12−
13−Provides a very simple indentation as a category transformer.
14−-}
15−module Data.Syntax.Indent (
16− Indent,
17− runIndent,
18− breakLine,
19− indented
20− ) where
21−
22−import Control.Category
23−import Control.Category.Reader
24−import Control.Category.Structures
25−import Control.SIArrow
26−import Data.Syntax
27−import Data.Syntax.Char
28−import Data.Syntax.Combinator
29−import Prelude hiding (takeWhile, take, id, (.))
30−
31−-- | Adds indentation to a syntax description.
32−newtype Indent cat a b = Indent { getIndent :: ReaderCT (Int, cat () ()) cat a b }
33− deriving (Category, Products, Coproducts, CatPlus, SIArrow)
34−
35−instance CatTrans Indent where
36− clift = Indent . clift
37−
38−-- Generalized newtype deriving cannot derive this :(
39−
40−instance Syntax syn => Syntax (Indent syn) where
41− type Seq (Indent syn) = Seq syn
42− anyChar = Indent anyChar
43− char = Indent . char
44− notChar = Indent . notChar
45− satisfy = Indent . satisfy
46− satisfyWith ai = Indent . satisfyWith ai
47− string = Indent . string
48− take = Indent . take
49− takeWhile = Indent . takeWhile
50− takeWhile1 = Indent . takeWhile1
51− takeTill = Indent . takeTill
52− takeTill1 = Indent . takeTill1
53−
54−instance SyntaxChar syn => SyntaxChar (Indent syn) where
55− decimal = Indent decimal
56− hexadecimal = Indent hexadecimal
57− scientific = Indent scientific
58− realFloat = Indent realFloat
59−
60−-- | @runIndent m tab@ runs the 'Indent' transformer using @tab@ once for each
61−-- level of indentation.
62−runIndent :: Indent cat a b -> cat () () -> cat a b
63−runIndent (Indent m) tab = runReaderCT m (0, tab)
64−
65−-- | Inserts a new line and correct indentation, but does not
66−-- require any formatting when parsing (it just skips all white space).
67−breakLine :: SyntaxChar syn => Indent syn () ()
68−breakLine = Indent . ReaderCT $ \(i, tab) ->
69− opt (char '\n') /* opt (sireplicate_ i tab) /* spaces_
70−
71−-- | Increases the indentation level of its argument by one.
72−indented :: Indent cat a b -> Indent cat a b
73−indented (Indent f) = Indent . ReaderCT $ \(i, tab) -> runReaderCT f (i + 1, tab)
Test.hsnew file+263
@@ -0,0 +1,263 @@
1+{-# LANGUAGE TypeFamilies #-}
2+{-# LANGUAGE TupleSections #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE DefaultSignatures #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE FunctionalDependencies #-}
9+module Test where
10+
11+import Prelude hiding (id, (.), take, takeWhile)
12+
13+import Control.Applicative
14+import Control.Arrow
15+import Control.Category
16+import Control.Lens hiding (imap, _Cons)
17+import Control.Monad
18+import qualified Data.Attoparsec.Text as Text
19+import Data.Attoparsec.Types
20+import Data.Char
21+import Data.Functor.Identity
22+import Data.MonoTraversable
23+import Data.Sequences hiding (take, takeWhile)
24+import Data.Text (Text)
25+
26+infixl 3 /|/
27+infixl 4 /$/
28+infixl 5 /*/, /*, */
29+
30+-- | Isomorphism in the kleisli category of some monad.
31+data KleisliIso m a b = KleisliIso (Kleisli m a b) (Kleisli m b a)
32+
33+instance Monad m => Category (KleisliIso m) where
34+ id = KleisliIso id id
35+ (KleisliIso f g) . (KleisliIso f' g') = KleisliIso (f . f') (g' . g)
36+
37+isoK :: (a -> m b) -> (b -> m a) -> KleisliIso m a b
38+isoK f g = KleisliIso (Kleisli f) (Kleisli g)
39+
40+apply :: KleisliIso m a b -> a -> m b
41+apply (KleisliIso (Kleisli f) _) = f
42+
43+unapply :: KleisliIso m a b -> b -> m a
44+unapply (KleisliIso _ (Kleisli g)) = g
45+
46+from :: KleisliIso m a b -> KleisliIso m b a
47+from (KleisliIso f g) = KleisliIso g f
48+
49+unit :: Monad m => KleisliIso m (a, ()) a
50+unit = isoK (return . fst) (return . (, ()))
51+
52+symmetry :: Monad m => KleisliIso m (a, b) (b, a)
53+symmetry = isoK f f
54+ where f (a, b) = return (b, a)
55+
56+equalTo :: (Eq a, Monad m) => a -> KleisliIso m a ()
57+equalTo x = isoK f g
58+ where
59+ f y | x == y = return ()
60+ | otherwise = fail "equalTo: not equal"
61+ g _ = return x
62+
63+oneWayConst :: Monad m => a -> KleisliIso m a ()
64+oneWayConst x = isoK f g
65+ where
66+ f _ = return ()
67+ g _ = return x
68+
69+check :: Monad m => (a -> Bool) -> KleisliIso m a a
70+check p = isoK f f
71+ where f x | p x = return x
72+ | otherwise = fail "check: predicate failed"
73+
74+packed :: (Monad m, IsSequence seq) => KleisliIso m [Element seq] seq
75+packed = isoK (return . fromList) (return . otoList)
76+
77+-- | Isomorphism between unit and empty list.
78+_Nil :: Monad m => KleisliIso m () [a]
79+_Nil = isoK f g
80+ where
81+ f _ = return []
82+ g [] = return ()
83+ g _ = fail "expected empty list"
84+
85+-- | Isomorphism between (head, tail) and a non empty list.
86+_Cons :: Monad m => KleisliIso m (a, [a]) [a]
87+_Cons = isoK f g
88+ where
89+ f (x, xs) = return (x:xs)
90+ g (x:xs) = return (x, xs)
91+ g _ = fail "expected non-empty list"
92+
93+-- | A functor from the category of isomorphisms of the Kleisli category
94+-- of some monad to Hask.
95+class IsoFunctor f where
96+ imap :: KleisliIso Identity a b -> f a -> f b
97+ imapK :: KleisliIso m a b -> f a -> f (m b)
98+
99+(/$/) :: IsoFunctor f => KleisliIso Identity a b -> f a -> f b
100+(/$/) = imap
101+
102+class IsoFunctor f => IsoPointed f where
103+ iunit :: f ()
104+ iunit = ipure id
105+
106+ ipure :: KleisliIso Identity () a -> f a
107+ ipure = (/$/ iunit)
108+
109+ ipureK :: KleisliIso m () a -> f (m a)
110+ ipureK = (`imapK` iunit)
111+
112+ {-# MINIMAL iunit | ipure #-}
113+
114+class IsoFunctor f => IsoFail f where
115+ ifail :: String -> f a
116+
117+class IsoPointed f => IsoApply f where
118+ (/*/) :: f a -> f b -> f (a, b)
119+
120+ (/*) :: f a -> f () -> f a
121+ f /* g = unit /$/ f /*/ g
122+
123+ (*/) :: f () -> f b -> f b
124+ f */ g = unit . symmetry /$/ f /*/ g
125+
126+ {-# MINIMAL (/*/) #-}
127+
128+class IsoApply f => IsoAlternative f where
129+ iempty :: f a
130+ (/|/) :: f a -> f a -> f a
131+
132+ isome :: f a -> f [a]
133+ isome v = _Cons /$/ v /*/ imany v
134+
135+ imany :: f a -> f [a]
136+ imany v = isome v /|/ ipure _Nil
137+
138+ sepBy :: f a -> f () -> f [a]
139+ sepBy v s = sepBy1 v s /|/ ipure _Nil
140+
141+ sepBy1 :: f a -> f () -> f [a]
142+ sepBy1 v s = _Cons /$/ v /* s /*/ sepBy v s
143+
144+ {-# MINIMAL iempty, (/|/) #-}
145+
146+class (IsoAlternative syn, IsoFail syn) => Syntax syn seq | syn -> seq where
147+ joinErr :: syn (Either String a) -> syn a
148+
149+ anyChar :: syn (Element seq)
150+
151+ char :: Element seq -> syn ()
152+ default char :: Eq (Element seq) => Element seq -> syn ()
153+ char c = equalTo c /$/ anyChar
154+
155+ satisfy :: (Element seq -> Bool) -> syn (Element seq)
156+ satisfy p = joinErr (imapK (check p) anyChar)
157+
158+ string :: seq -> syn ()
159+ default string :: (IsSequence seq, Eq seq) => seq -> syn ()
160+ string s = equalTo s /$/ take (olength s)
161+
162+ take :: Int -> syn seq
163+ default take :: IsSequence seq => Int -> syn seq
164+ take n = packed /$/ ireplicate n anyChar
165+
166+ takeWhile :: (Element seq -> Bool) -> syn seq
167+ default takeWhile :: IsSequence seq => (Element seq -> Bool) -> syn seq
168+ takeWhile p = packed /$/ imany (satisfy p)
169+
170+ takeWhile1 :: (Element seq -> Bool) -> syn seq
171+ default takeWhile1 :: IsSequence seq => (Element seq -> Bool) -> syn seq
172+ takeWhile1 p = packed /$/ isome (satisfy p)
173+
174+ {-# MINIMAL joinErr, anyChar #-}
175+
176+ireplicate :: IsoApply f => Int -> f a -> f [a]
177+ireplicate 0 _ = ipure _Nil
178+ireplicate n m = _Cons /$/ m /*/ ireplicate (n-1) m
179+
180+isequence :: IsoApply f => [f a] -> f [a]
181+isequence [] = ipure _Nil
182+isequence (x:xs) = _Cons /$/ x /*/ isequence xs
183+
184+skipSpace :: (Syntax syn seq, IsSequence seq, Element seq ~ Char) => syn ()
185+skipSpace = oneWayConst (fromList []) /$/ takeWhile isSpace
186+
187+skipSpace1 :: (Syntax syn seq, IsSequence seq, Element seq ~ Char) => syn ()
188+skipSpace1 = oneWayConst (singleton ' ') /$/ takeWhile1 isSpace
189+
190+-- Attoparsec implementation.
191+
192+instance IsoFunctor (Parser i) where
193+ imap i m = fmap (runIdentity . apply i) m
194+ imapK i m = fmap (apply i) m
195+
196+instance IsoFail (Parser i) where
197+ ifail = fail
198+
199+instance IsoPointed (Parser i) where
200+ ipure = pure . runIdentity . (`apply` ())
201+
202+instance IsoApply (Parser i) where
203+ f /*/ g = (,) <$> f <*> g
204+
205+instance IsoAlternative (Parser i) where
206+ iempty = empty
207+ (/|/) = (<|>)
208+ imany = many
209+ isome = some
210+ sepBy = Text.sepBy
211+ sepBy1 = Text.sepBy1
212+
213+instance Syntax (Parser Text) Text where
214+ joinErr = (>>= either fail return)
215+ anyChar = Text.anyChar
216+ satisfy = Text.satisfy
217+ char = void . Text.char
218+ string = void . Text.string
219+ takeWhile = Text.takeWhile
220+ takeWhile1 = Text.takeWhile1
221+
222+-- Some AST.
223+
224+data AST = Var Text
225+ | App AST AST
226+ | Abs Text AST
227+ deriving (Show)
228+
229+_Var :: Monad m => KleisliIso m Text AST
230+_Var = isoK f g
231+ where
232+ f = return . Var
233+ g (Var t) = return t
234+ g _ = fail "expected a Var"
235+
236+_App :: Monad m => KleisliIso m (AST, AST) AST
237+_App = isoK f g
238+ where
239+ f = return . uncurry App
240+ g (App h x) = return (h, x)
241+ g _ = fail "expected an App"
242+
243+_Abs :: Monad m => KleisliIso m (Text, AST) AST
244+_Abs = isoK f g
245+ where
246+ f = return . uncurry Abs
247+ g (Abs n b) = return (n, b)
248+ g _ = fail "expected an Abs"
249+
250+name :: Syntax syn Text => syn Text
251+name = takeWhile1 isAlphaNum
252+
253+atom :: Syntax syn Text => syn AST
254+atom = _Var /$/ name
255+ /|/ char '(' */ expr /* char ')'
256+
257+expr :: Syntax syn Text => syn AST
258+expr = _App /$/ atom /* skipSpace1 /*/ atom
259+ /|/ _Abs /$/ char '\\' /* skipSpace
260+ */ name /* skipSpace
261+ /* string "->" /* skipSpace
262+ /*/ expr
263+ /|/ atom
syntax.cabal+14−43
@@ -1,52 +1,23 @@
1+-- Initial syntax.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
1name: syntax
4name: syntax
2−version: 1.0.0.0
5+version: 0.1.0.0
3−synopsis: Reversible parsing and pretty-printing.
6+synopsis: Abstract syntax descriptions for parsing and pretty-printing.
4−description:
7+-- description:
5− "syntax" allows you to write a single syntax description and instantiate is both as a parser and a pretty printer.
6− .
7− Syntax descriptions are written in applicative or arrow style. The library uses a custom typeclass hierarchy, provided
8− by the "semi-iso" package. Most of the time you will be using operators like '/$/', '/*/' and '/+/' (= '<|>'), just
9− like parser combinators. When more power is needed - e.g. when the syntax depends on the parsed or printed value -
10− you turn to arrows.
11− .
12− Semi-isomorphisms from "semi-iso" are the basic building block of syntax descriptions. I recommend reading
13− the hackage page of "semi-iso" first, as it contains much more information.
14− .
15− Once you write a syntax description (polymorphic in the syntax category) you can instantiate it both as a parser or as
16− a pretty-printer. The library "syntax-attoparsec" gives you the ability to extract an Attoparsec parser. Pretty-printing
17− is implemented by the "syntax-printer" library, which uses Text and ByteString builders. (Note that formatting is handled
18− by "syntax" itself, not by the printer library)
19− .
20− Advanced formatting and parsing (for example indentation, haskell layout rule) is implemented as category transformers
21− (similar to monad transformers). Currently only simple indentation is implemented (in "Data.Syntax.Indent") - basically
22− a reader category transformer that tracks current indentation level. I plan on implementing Haskell layout rule in the
23− future.
24− .
25− The library can work with both text and binary data. Alas, there are no binary combinators implemented yet.
26− I will implement them when i have the time (but these category transformers look so much more interesting for now ;).
27− .
28− EXAMPLES! See @syntax-example@ and @syntax-example-json@ for examples.
29− .
30− * "syntax-example" implements a simple lambda calculus.
31− .
32− * "syntax-example-json" implements a json parser and pretty printer.
33license: MIT
8license: MIT
34license-file: LICENSE
9license-file: LICENSE
35author: Paweł Nowak
10author: Paweł Nowak
36maintainer: Paweł Nowak <pawel834@gmail.com>
11maintainer: Paweł Nowak <pawel834@gmail.com>
37−copyright: Paweł Nowak 2014
12+-- copyright:
38−category: Data
13+-- category:
39build-type: Simple
14build-type: Simple
15+-- extra-source-files:
40cabal-version: >=1.10
16cabal-version: >=1.10
41
17
42−source-repository head
43− type: git
44− location: git@github.com:Pawel834/syntax.git
45−
46library
18library
47− exposed-modules: Data.Syntax
19+ -- exposed-modules:
48− Data.Syntax.Char
20+ other-modules: Test
49− Data.Syntax.Combinator
21+ -- other-extensions:
50− Data.Syntax.Indent
51− build-depends: base >= 4 && < 5, mono-traversable, lens >= 4, semi-iso >= 1, scientific >= 0.3, text, vector
22+ build-depends: base, transformers, attoparsec, text, mono-traversable, lens
52− default-language: Haskell2010
23+ default-language: Haskell2010