Commit 09d0f45a authored by simonpj's avatar simonpj
Browse files

[project @ 2005-03-11 10:40:10 by simonpj]

Add more tests
parent a0938ad4
{-# OPTIONS -fglasgow-exts -farrows #-}
module ShouldCompile where
-- Test infix type notation and arrow notation
module Test where
import Control.Arrow
comp1 :: Arrow (~>) => (b~>c) -> (c~>d) -> (b~>d)
-- For readability, I use infix notation for arrow types. I'd prefer the
-- following, but GHC doesn't allow operators like "-=>" as type
-- variables.
--
-- comp1 :: Arrow (-=>) => b-=>c -> c-=>d -> b-=>d
comp1 :: Arrow (~>) => b~>c -> c~>d -> b~>d
comp1 f g = proc x -> do
b <- f -< x
g -< b
-- arrowp produces
-- comp1 f g = (f >>> g)
comp :: Arrow (~>) => (b~>c, c~>d)~>(b~>d)
comp = pure (uncurry (>>>))
-- app :: Arrow (~>) => (b c, b)~>c
type R = Float
type I = Int
z1,z2 :: Arrow (~>) => I~>(R~>R)
z1 = undefined
z2 = z1
z3 :: Arrow (~>) => (I,I)~>(R~>R,R~>R)
z3 = z1 *** z2
z4 :: Arrow (~>) => (I,I)~>(R~>R)
z4 = z3 >>> comp
comp4,comp5 :: Arrow (~>) =>
b~>(c~>d) -> e~>(d~>f) -> (b,e)~>(c~>f)
comp4 g f = proc (b,e) -> do
g' <- g -< b
f' <- f -< e
returnA -< (g' >>> f')
comp5 g f = (g *** f) >>> comp
lam,lam2 :: Arrow (~>) => (e,b)~>c -> e~>(b~>c)
lam f = pure $ \ e -> pure (pair e) >>> f
pair = (,)
-- I got the definition lam above by starting with
lam2 f = proc e ->
returnA -< (proc b -> do
c <- f -< (e,b)
returnA -< c)
-- I desugared with the arrows preprocessor, removed extra parens and
-- renamed "arr" (~>) "pure", (~>) get
--
-- lam f = pure (\ e -> pure (\ b -> (e, b)) >>> f)
-- Note that lam is arrow curry
-- curry :: ((e,b) -> c) -> (e -> b -> c)
-- All equivalent:
curry1 f e b = f (e,b)
curry2 f = \ e -> \ b -> f (e,b)
curry3 f = \ e -> f . (\ b -> (e,b))
curry4 f = \ e -> f . (pair e)
comp6 :: Arrow (~>) => b~>(c~>d) -> e~>(d~>f)
-> b~>(e~>(c~>f))
comp6 g f = lam $ comp5 g f
-- What about uncurrying?
-- uncurryA :: Arrow (~>) => b~>(c~>d)
-- -> (b,c)~>d
-- uncurryA f = proc (b,c) -> do
-- f' <- f -< b
-- returnA -< f' c
-- Why "lam" instead of "curryA" (good name also): so I can use Arrows
-- lambda notation, similar (~>)
compF g f = \ b e -> g b . f e
-- But I haven't figured out how (~>).
-- comp7 :: Arrow (~>) => b~>(c~>d) -> e~>(d~>f)
-- -> b~>(e~>(c~>f))
-- comp7 g f = proc b -> proc e -> do
-- g' <- g -< b
-- f' <- f -< e
-- returnA -< (g' >>> f')
-- Try "(| lam \ b -> ... |)" in the FOP arrows chapter
-- cmd ::= form exp cmd1 ... cmdn. Parens if nec
-- (| lam (\ b -> undefined) |)
-- Oh! The arrow syntax allows bindings with *infix* operators. And I
-- don't know how (~>) finish comp7.
-- Uncurried forms:
comp8 :: Arrow (~>) => (b,c)~>d -> (e,d)~>k -> (b,c,e)~>k
comp8 g f = proc (b,c,e) -> do
d <- g -< (b,c)
f -< (e,d)
-- This looks like straightforward~>translation. With insertions of
-- curry & uncurry operators, it'd probably be easy (~>) handle curried
-- definitions as well.
-- Simpler example, for experimentation
comp9 :: Arrow (~>) => (c,d)~>e -> b~>d -> (b,c)~>e
comp9 g f = proc (b,c) -> do
d <- f -< b
g -< (c,d)
-- Desugared:
comp9' :: Arrow (~>) => (c,d)~>e -> b~>d -> (b,c)~>e
comp9' g f = first f >>> arr (\ (d,c) -> (c,d)) >>> g
......@@ -118,3 +118,5 @@ test('tcfail129', normal, compile_fail, [''])
test('tcfail130', normal, compile_fail, [''])
test('tcfail131', normal, compile_fail, [''])
test('tcfail132', normal, compile_fail, [''])
test('tcfail133', normal, compile_fail, [''])
test('tcfail134', normal, compile_fail, [''])
{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}
-- This one crashed GHC 6.3 due to an error in TcSimplify.add_ors
module Foo where
data Zero = Zero deriving Show
data One = One deriving Show
infixl 9 :@
data (Number a, Digit b) => a :@ b = a :@ b deriving Show
class Digit a
instance Digit Zero
instance Digit One
class Number a
instance Number Zero
instance Number One
instance (Number a, Digit b) => Number (a :@ b)
--- Pretty printing of numbers ---
class PrettyNum a where
prettyNum :: a -> String
instance PrettyNum Zero where
prettyNum _ = "0"
instance PrettyNum One where
prettyNum _ = "1"
instance (Number a, Digit b, PrettyNum a, PrettyNum b)
=> PrettyNum (a :@ b) where
prettyNum ~(a:@b)
= prettyNum a ++ prettyNum b
--- Digit addition ---
class (Number a, Digit b, Number c)
=> AddDigit a b c | a b -> c where
addDigit :: a -> b -> c
addDigit = undefined
instance Number a => AddDigit a Zero a
instance AddDigit Zero One One
instance AddDigit One One (One:@Zero)
instance Number a => AddDigit (a:@Zero) One (a:@One)
instance AddDigit a One a'
=> AddDigit (a:@One) One (a':@Zero)
--- Addition ---
class (Number a, Number b, Number c)
=> Add a b c | a b -> c where
add :: a -> b -> c
add = undefined
instance Number n => Add n Zero n
instance Add Zero One One
instance Add One One (One:@One)
instance Number n
=> Add (n:@Zero) One (n:@One)
instance AddDigit n One r'
=> Add (n:@One) One (r':@Zero)
instance (Number n1, Digit d1, Number n2, Digit n2
,Add n1 n2 nr', AddDigit (d1:@nr') d2 r)
=> Add (n1:@d1) (n2:@d2) r
foo = show $ add (One:@Zero) (One:@One)
-- Add (One:@Zero) (One:@One) c, Show c
-- ==> Number One, Digit Zero, Number One, Digit One
-- Add One One nr', AddDigit (Zero:@nr') One c, Show c
--
-- ==> Add One One nr', AddDigit (Zero:@nr') One c, Show c
--
-- ==> Add One One (One:@One), AddDigit (Zero:@(One:@One)) One c, Show c
--
-- ==> AddDigit (Zero:@(One:@One)) One c, Show c
tcfail133.hs:67:13:
No instance for (AddDigit ((:@) Zero ((:@) One One)) One a)
arising from use of `add' at tcfail133.hs:67:13-15
Probable fix:
add an instance declaration for (AddDigit ((:@) Zero ((:@) One One)) One a)
In the second argument of `($)', namely `add (One :@ Zero) (One :@ One)'
In the definition of `foo': foo = show $ (add (One :@ Zero) (One :@ One))
-- Class used as a type, recursively
module ShouldFail where
class XML a where toXML :: a -> XML
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment