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