Commit c2a15491 authored by sof's avatar sof
Browse files

[project @ 1997-07-26 23:49:03 by sof]

parent 369746bf
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
HS_SRCS = $(wildcard *.hs)
SRC_RUNTEST_OPTS += -accept-output -o1 $*.stdout -o2 $*.stderr -x 0
HC_OPTS += -noC -O -ddump-simpl -dcore-lint
%.o : %.hs
%.o : %.hs
$(RUNTEST) $(HC) $(RUNTEST_OPTS) $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
all :: $(HS_OBJS)
include $(TOP)/mk/target.mk
--!!! Desugaring sections with function-type arguments
-- Although this is really a desugaring test, the problem is
-- only tickled by the simplifier
-- type Foo a b = a -> (b -> a) -> b
module Test where
(++++) :: (a -> (b -> a) -> b) -> (a -> (b -> a) -> b) -> a -> (b -> a) -> b
x ++++ y = y
g a xs = map (++++ a) xs
h b xs = map (b ++++) xs
================================================================================
Simplified:
++++{-r3h,x-} ::
_forall_
[a{-auX-} b{-auY-}]
=>
(a{-auX-} -> (b{-auY-} -> a{-auX-}) -> b{-auY-})
-> (a{-auX-} -> (b{-auY-} -> a{-auX-}) -> b{-auY-})
-> a{-auX-}
-> (b{-auY-} -> a{-auX-})
-> b{-auY-}
_A>_ 2 {-# L #-}
++++{-r3h,x-} =
_/\_ a{-sE8-} b{-sE9-} -> \ x_sDl ::
a{-sE8-} -> (b{-sE9-} -> a{-sE8-}) -> b{-sE9-}
{-# L #-}
x_sDl y_sCR ::
a{-sE8-} -> (b{-sE9-} -> a{-sE8-}) -> b{-sE9-}
{-# L #-}
y_sCR ->
y_sCR
g{-r3j,x-} ::
_forall_
[a{-avh-} b{-avi-} rk0{-avq-}]
=>
{PrelBase.Functor{-2b,p-} rk0{-avq-}}
-> (a{-avh-} -> (b{-avi-} -> a{-avh-}) -> b{-avi-})
-> rk0{-avq-} (a{-avh-} -> (b{-avi-} -> a{-avh-}) -> b{-avi-})
-> rk0{-avq-} (a{-avh-} -> (b{-avi-} -> a{-avh-}) -> b{-avi-})
_A>_ 3 {-# L #-}
g{-r3j,x-} =
_/\_ a{-sEd-} b{-sEe-} rk0{-sEf-} -> \ d.Functor_sDp ::
{PrelBase.Functor{-2b,p-} rk0{-sEf-}}
{-# L #-}
d.Functor_sDp a_sDk ::
a{-sEd-}
-> (b{-sEe-} -> a{-sEd-})
-> b{-sEe-}
{-# L #-}
a_sDk xs_sDV ::
rk0{-sEf-} (a{-sEd-}
-> (b{-sEe-}
-> a{-sEd-})
-> b{-sEe-})
{-# L #-}
xs_sDV ->
let {
ds_sDr ::
(a{-sEd-} -> (b{-sEe-} -> a{-sEd-}) -> b{-sEe-})
-> a{-sEd-}
-> (b{-sEe-} -> a{-sEd-})
-> b{-sEe-}
_A>_ 1 {-# L #-}
ds_sDr =
\ ds_sDq ::
a{-sEd-} -> (b{-sEe-} -> a{-sEd-}) -> b{-sEe-}
{-# L #-}
ds_sDq ->
a_sDk
} in
d.Functor_sDp
_@_ (a{-sEd-} -> (b{-sEe-} -> a{-sEd-}) -> b{-sEe-})
_@_ (a{-sEd-} -> (b{-sEe-} -> a{-sEd-}) -> b{-sEe-})
ds_sDr
xs_sDV
h{-r3i,x-} ::
_forall_
[a{-avI-} b{-avK-} rk0{-avT-}]
=>
{PrelBase.Functor{-2b,p-} rk0{-avT-}}
-> (a{-avI-} -> (b{-avK-} -> a{-avI-}) -> b{-avK-})
-> rk0{-avT-} (a{-avI-} -> (b{-avK-} -> a{-avI-}) -> b{-avK-})
-> rk0{-avT-} (a{-avI-} -> (b{-avK-} -> a{-avI-}) -> b{-avK-})
_A>_ 3 {-# L #-}
h{-r3i,x-} =
_/\_ a{-sEl-} b{-sEm-} rk0{-sEn-} -> \ d.Functor_sDZ ::
{PrelBase.Functor{-2b,p-} rk0{-sEn-}}
{-# L #-}
d.Functor_sDZ b_sEg ::
a{-sEl-}
-> (b{-sEm-} -> a{-sEl-})
-> b{-sEm-}
{-# L #-}
b_sEg xs_sEh ::
rk0{-sEn-} (a{-sEl-}
-> (b{-sEm-}
-> a{-sEl-})
-> b{-sEm-})
{-# L #-}
xs_sEh ->
let {
ds_sE0 ::
(a{-sEl-} -> (b{-sEm-} -> a{-sEl-}) -> b{-sEm-})
-> a{-sEl-}
-> (b{-sEm-} -> a{-sEl-})
-> b{-sEm-}
_A>_ 1 {-# L #-}
ds_sE0 =
\ ds_sDU ::
a{-sEl-} -> (b{-sEm-} -> a{-sEl-}) -> b{-sEm-}
{-# L #-}
ds_sDU ->
ds_sDU
} in
d.Functor_sDZ
_@_ (a{-sEl-} -> (b{-sEm-} -> a{-sEl-}) -> b{-sEm-})
_@_ (a{-sEl-} -> (b{-sEm-} -> a{-sEl-}) -> b{-sEm-})
ds_sE0
xs_sEh
--!!! class/instance mumble that failed Lint at one time
--
module Test where
class Foo a where
op :: Int -> a -> Bool
data Wibble a b c = MkWibble a b c
instance (Foo a, Foo b, Foo c) => Foo (Wibble a b c) where
op x y = error "xxx"
================================================================================
Simplified:
nrlit_sMT ::
[PrelBase.Char{-38,p-}]
{-# L #-}
nrlit_sMT =
PackedString.unpackCString#{-8F,p-}
"xxx"
$d1{-rJ7,x-} ::
_forall_
[a{-r3g-} b{-r3h-} c{-r3i-}]
=>
{Foo{-r3j,x-} a{-r3g-}}
-> {Foo{-r3j,x-} b{-r3h-}}
-> {Foo{-r3j,x-} c{-r3i-}}
-> {Foo{-r3j,x-} (Wibble{-r3y,x-} a{-r3g-} b{-r3h-} c{-r3i-})}
_A>_ 3 {-# L #-}
$d1{-rJ7,x-} =
_/\_ a{-sMG-} b{-sMH-} c{-sMI-} -> \ d.Foo_sLN ::
{Foo{-r3j,x-} a{-sMG-}}
{-# L #-}
d.Foo_sLN d.Foo_sLM ::
{Foo{-r3j,x-} b{-sMH-}}
{-# L #-}
d.Foo_sLM d.Foo_sLL ::
{Foo{-r3j,x-} c{-sMI-}}
{-# L #-}
d.Foo_sLL ->
let {
op_sLp ::
PrelBase.Int{-3g,p-}
-> Wibble{-r3y,x-} a{-sMG-} b{-sMH-} c{-sMI-}
-> PrelBase.Bool{-34,p-}
_A>_ 2 {-# L #-}
op_sLp =
\ x_sLs ::
PrelBase.Int{-3g,p-}
{-# L #-}
x_sLs y_sLq ::
Wibble{-r3y,x-} a{-sMG-} b{-sMH-} c{-sMI-}
{-# L #-}
y_sLq ->
IOBase.error{-87,p-}
_@_ PrelBase.Bool{-34,p-} nrlit_sMT } in
let {
op_sLO ::
PrelBase.Int{-3g,p-}
-> Wibble{-r3y,x-} a{-sMG-} b{-sMH-} c{-sMI-}
-> PrelBase.Bool{-34,p-}
_A>_ 2 {-# L #-}
op_sLO =
op_sLp } in
let {
d.Foo_sLP ::
{Foo{-r3j,x-} (Wibble{-r3y,x-} a{-sMG-} b{-sMH-} c{-sMI-})}
_A>_ 2 {-# L #-}
d.Foo_sLP =
op_sLp
} in
op_sLp
$d2{-rJ2,x-} ::
_forall_
[a{-r3s-} b{-r3t-} c{-r3u-}]
=>
{PrelBase.Eval{-24,p-} (Wibble{-r3y,x-} a{-r3s-} b{-r3t-} c{-r3u-})}
_A>_ 0 {-# L #-}
$d2{-rJ2,x-} =
_/\_ a{-sMV-} b{-sMW-} c{-sMX-} ->
let {
d.Eval_sM2 ::
{PrelBase.Eval{-24,p-} (Wibble{-r3y,x-} a{-sMV-} b{-sMW-} c{-sMX-})}
{-# L #-}
d.Eval_sM2 =
PrelBase.void{-8G,p-}
} in
PrelBase.void{-8G,p-}
nrlit_sMU ::
[PrelBase.Char{-38,p-}]
{-# L #-}
nrlit_sMU =
PackedString.unpackCString#{-8F,p-}
"Class Foo Method op"
$mop{-rIV,x-} ::
_forall_
[a{-r3w-}]
=>
{Foo{-r3j,x-} a{-r3w-}}
-> PrelBase.Int{-3g,p-}
-> a{-r3w-}
-> PrelBase.Bool{-34,p-}
_A>_ 3 {-# L #-}
$mop{-rIV,x-} =
_/\_ a{-sMJ-} -> \ d.Foo_sMg ::
{Foo{-r3j,x-} a{-sMJ-}}
{-# L #-}
d.Foo_sMg ->
GHCerr.noDefaultMethodError{-8k,p-}
_@_ (PrelBase.Int{-3g,p-} -> a{-sMJ-} -> PrelBase.Bool{-34,p-})
nrlit_sMU
op{-r3z,x-} ::
_forall_
[a{-r3w-}]
=>
{Foo{-r3j,x-} a{-r3w-}}
-> PrelBase.Int{-3g,p-}
-> a{-r3w-}
-> PrelBase.Bool{-34,p-}
_A>_ 1 {-# L #-}
op{-r3z,x-} =
_/\_ a{-sMK-} -> \ tpl_sMf ::
{Foo{-r3j,x-} a{-sMK-}}
{-# L #-}
tpl_sMf ->
tpl_sMf
MkWibble{-r3x,x-}{i} ::
_forall_
[a{-r3s-} b{-r3t-} c{-r3u-}]
=>
a{-r3s-}
-> b{-r3t-}
-> c{-r3u-}
-> Wibble{-r3y,x-} a{-r3s-} b{-r3t-} c{-r3u-}
_A>_ 3 {-# L #-}
MkWibble{-r3x,x-}{i} =
_/\_ a{-sMO-} b{-sMP-} c{-sMQ-} -> \ tpl_sML ::
a{-sMO-}
{-# L #-}
tpl_sML tpl_sMM ::
b{-sMP-}
{-# L #-}
tpl_sMM tpl_sMN ::
c{-sMQ-}
{-# L #-}
tpl_sMN ->
MkWibble{-r3x,x-}{i}
{_@_ a{-sMO-} _@_ b{-sMP-} _@_ c{-sMQ-} tpl_sML tpl_sMM tpl_sMN}
--!! INLINE on recursive functions.
{-
Date: Thu, 8 Dec 94 11:38:24 GMT
From: Julian Seward (DRL PhD) <sewardj@computer-science.manchester.ac.uk>
Message-Id: <9412081138.AA16652@rdf009.cs.man.ac.uk>
To: partain@dcs.gla.ac.uk
-}
module ShouldFail where
type IMonad a
= IMonadState -> IMonadReturn a
data IMonadReturn a
= IMonadOk IMonadState a
| IMonadFail IMonadState String
type IMonadState
= Int
returnI r = \s0 -> IMonadOk s0 r
failI msg = \s0 -> IMonadFail s0 msg
thenI m k
= \s0 -> case m s0 of
IMonadFail s1 msg -> IMonadFail s1 msg
IMonadOk s1 r1 -> k r1 s1
tickI n = \s0 -> IMonadOk (s0+n) ()
mapI f [] = returnI []
mapI f (x:xs) = f x `thenI` ( \ fx ->
mapI f xs `thenI` ( \ fxs ->
returnI (fx:fxs)
))
{-# INLINE returnI #-}
{-# INLINE failI #-}
{-# INLINE thenI #-}
{-# INLINE tickI #-}
{-# INLINE mapI #-}
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
HS_SRCS = $(wildcard *.lhs)
SRC_RUNTEST_OPTS += -accept-output -o1 $*.stdout -o2 $*.stderr -x 0
HC_OPTS += -noC -O -ddump-simpl -dcore-lint -dppr-user
%.o : %.lhs
%.o : %.lhs
$(RUNTEST) $(HC) $(RUNTEST_OPTS) -- $(HC_OPTS) -c $< -o $@ -osuf $(subst .,,$(suffix $@))
all :: $(HS_OBJS)
include $(TOP)/mk/target.mk
> module Test where
> data Boolean = FF | TT
> data Pair a b = MkPair a b
> data LList alpha = Nill | Conss alpha (LList alpha)
> data Nat = Zero | Succ Nat
> data Tree x = Leaf x | Node (Tree x) (Tree x)
> data A a = MkA a (A a)
>
> append :: LList a -> LList a -> LList a
> append xs ys = case xs of
> Conss z zs -> Conss z (append zs ys)
> v -> ys
--================================================================================
Simplified:
`$d5' ::
`{PrelBase.Eval (Pair a{-r3U-} b{-r3V-})}'
`$d5' =
_/\_ `a{-s1gp-}' `b{-s1gq-}' ->
`PrelBase.void'
`$d4' ::
`{PrelBase.Eval (LList alpha{-r3S-})}'
`$d4' =
_/\_ `alpha{-s1gr-}' ->
`PrelBase.void'
`$d2' ::
`{PrelBase.Eval (Tree x{-r3P-})}'
`$d2' =
_/\_ `x{-s1gs-}' ->
`PrelBase.void'
`$d1' ::
`{PrelBase.Eval (A a{-r3N-})}'
`$d1' =
_/\_ `a{-s1gt-}' ->
`PrelBase.void'
`MkPair' ::
`a{-r3U-} -> b{-r3V-} -> Pair a{-r3U-} b{-r3V-}'
`MkPair' =
_/\_ `a{-s1gc-}' `b{-s1gd-}' -> \ `tpl' ::
`a{-s1gc-}'
`tpl' `tpl' ::
`b{-s1gd-}'
`tpl' ->
`MkPair'
{_@_ `a{-s1gc-}' _@_ `b{-s1gd-}' `tpl' `tpl'}
`MkA' ::
`a{-r3N-} -> A a{-r3N-} -> A a{-r3N-}'
`MkA' =
_/\_ `a{-s1ge-}' -> \ `tpl' ::
`a{-s1ge-}'
`tpl' `tpl' ::
`A a{-s1ge-}'
`tpl' ->
`MkA'
{_@_ `a{-s1ge-}' `tpl' `tpl'}
`FF' ::
`Boolean'
`FF' =
`FF'
{}
`TT' ::
`Boolean'
`TT' =
`TT'
{}
`Nill' ::
`LList alpha{-r3S-}'
`Nill' =
_/\_ `alpha{-s1gf-}' ->
`Nill'
{_@_ `alpha{-s1gf-}'}
`Conss' ::
`alpha{-r3S-} -> LList alpha{-r3S-} -> LList alpha{-r3S-}'
`Conss' =
_/\_ `alpha{-s1gg-}' -> \ `tpl' ::
`alpha{-s1gg-}'
`tpl' `tpl' ::
`LList alpha{-s1gg-}'
`tpl' ->
`Conss'
{_@_ `alpha{-s1gg-}' `tpl' `tpl'}
Rec {
`append' ::
`LList a{-aH9-} -> LList a{-aH9-} -> LList a{-aH9-}'
`append' =
_/\_ `a{-s1gh-}' -> \ `xs' ::
`LList a{-s1gh-}'
`xs' `ys' ::
`LList a{-s1gh-}'
`ys' ->
case `xs' of {
`Nill' ->
`ys';
`Conss' `z' `zs' ->
let {
`ds' ::
`LList a{-s1gh-}'
`ds' =
`append'
_@_ `a{-s1gh-}' `zs' `ys'
} in
`Conss'
{_@_ `a{-s1gh-}' `z' `ds'};
}
end Rec }
`Zero' ::
`Nat'
`Zero' =
`Zero'
{}
`Succ' ::
`Nat -> Nat'
`Succ' =
\ `tpl' ::
`Nat'
`tpl' ->
`Succ'
{`tpl'}
`Leaf' ::
`x{-r3P-} -> Tree x{-r3P-}'
`Leaf' =
_/\_ `x{-s1gl-}' -> \ `tpl' ::
`x{-s1gl-}'
`tpl' ->
`Leaf'
{_@_ `x{-s1gl-}' `tpl'}
`Node' ::
`Tree x{-r3P-} -> Tree x{-r3P-} -> Tree x{-r3P-}'
`Node' =
_/\_ `x{-s1go-}' -> \ `tpl' ::
`Tree x{-s1go-}'
`tpl' `tpl' ::
`Tree x{-s1go-}'
`tpl' ->
`Node'
{_@_ `x{-s1go-}' `tpl' `tpl'}
`$d6' ::
`{PrelBase.Eval Boolean}'
`$d6' =
`PrelBase.void'
`$d3' ::
`{PrelBase.Eval Nat}'
`$d3' =
`PrelBase.void'
> module Test where
> fact :: Int -> Int
> fact n = if n==0 then 2 else (fact n) * n
--================================================================================
Simplified:
Rec {
`s1BQ' ::
`GHC.Int# -> PrelBase.Int'
`s1BQ' =
\ `ww' ::
`GHC.Int#'
`ww' ->
case# `ww' of {
0 ->
`PrelBase.I#'
{2};
`s' ->
case
`s1BQ'
`ww'
of {
`PrelBase.I#' `s1tCY' ->
case# *#! `s1tCY' `ww' of { `s1tDv' ->
`PrelBase.I#'
{`s1tDv'};};};
}
end Rec }
`fact' ::
`PrelBase.Int -> PrelBase.Int'
`fact' =
\ `n' ::
`PrelBase.Int'
`n' ->
case `n' of { `PrelBase.I#' `ww' ->
`s1BQ'
`ww';}
> module Test where
> data Fun = MkFun (Fun -> Fun)
> data LList a = Nill | Conss a (LList a)
> id :: Fun -> Fun
> id f = f
> module Test where
> data Goo a = Gsimpl | Gcompl ([Goo a])
> data Moo a b = Msimple | Mcompl (Moo b a)
> idGoo :: Goo a -> Goo a
> idGoo x = x
> idMoo :: Moo a -> Moo a
> idMoo x = x
TEST OF DEFACTORISATION FOR FUNCTIONS THAT DROP
POLYMORPHIC VARIABLES
> module Test where
> data Boolean = FF | TT
> data Pair a b = MkPair a b
> data LList alpha = Nill | Conss alpha (LList alpha)
> data Nat = Zero | Succ Nat
> data Tree x = Leaf x | Node (Tree x) (Tree x)
> data A a = MkA a (A a)
>
> append :: LList a -> LList a -> LList a
> append xs ys = case xs of
> Nill -> ys
> Conss z zs -> Conss z (append zs ys)
The following function drops @b@.
> flat :: Tree (Pair a b) -> LList a
> flat t = case t of
> Leaf (MkPair a b) -> Conss a Nill
> Node l r -> append (flat l) (flat r)
>
> fl :: Boolean -> LList Boolean
> fl x = flat (Leaf (MkPair TT Zero))
>
--================================================================================
Simplified:
`$d5' ::
`{PrelBase.Eval (Pair a{-r4b-} b{-r4c-})}'
`$d5' =
_/\_ `a{-s1NX-}' `b{-s1NY-}' ->
`PrelBase.void'
`$d4' ::
`{PrelBase.Eval (LList alpha{-r49-})}'
`$d4' =
_/\_ `alpha{-s1NZ-}' ->
`PrelBase.void'
`$d2' ::
`{PrelBase.Eval (Tree x{-r46-})}'
`$d2' =
_/\_ `x{-s1O0-}' ->
`PrelBase.void'