git.iko.soy/syntax
on master help sign in
Remove Test.hs.
13372c0Paweł Nowak
Test.hsdeleted−263
compare with master
unifiedsplit
@@ -1,263 +0,0 @@
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