Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : master
http://hackage.haskell.org/trac/ghc/changeset/84a826dd6e265c6bf21017ec0dd9ebbc5a74fe23 >--------------------------------------------------------------- commit 84a826dd6e265c6bf21017ec0dd9ebbc5a74fe23 Author: Simon Peyton Jones <[email protected]> Date: Fri Jul 15 11:48:11 2011 +0100 Test Trac #5315 >--------------------------------------------------------------- tests/ghc-regress/simplCore/should_run/T5315.hs | 89 ++++++++++++++++++++ .../ghc-regress/simplCore/should_run/T5315.stdout | 1 + tests/ghc-regress/simplCore/should_run/all.T | 1 + 3 files changed, 91 insertions(+), 0 deletions(-) diff --git a/tests/ghc-regress/simplCore/should_run/T5315.hs b/tests/ghc-regress/simplCore/should_run/T5315.hs new file mode 100644 index 0000000..5b2ff39 --- /dev/null +++ b/tests/ghc-regress/simplCore/should_run/T5315.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +infixr 7 :*, .* +infix 8 :*:, .*. + +data HNil +data α :* β +type HSingle α = α :* HNil +type α :*: β = α :* β :* HNil + +data HList l where + HNil â· HList HNil + (:*) ⷠα â HList t â HList (α :* t) + +(.*) ⷠα â HList t â HList (α :* t) +(.*) = (:*) + +(.*.) ⷠα â β â HList (α :*: β) +a .*. b = a .* b .* HNil + +data First +data Next p + +data HIndex i where + First â· HIndex First + Next â· HIndex p â HIndex (Next p) + +class (l ~ (HHead l :* HTail l)) â HNonEmpty l where + type HHead l + type HTail l + +instance HNonEmpty (h :* t) where + type HHead (h :* t) = h + type HTail (h :* t) = t + +hHead â· HNonEmpty l â HList l â HHead l +hHead (h :* _) = h +hHead _ = undefined + +hTail â· HNonEmpty l â HList l â HList (HTail l) +hTail (_ :* t) = t +hTail _ = undefined + +data HFromWitness n l where + HFromFirst â· HFromWitness First l + HFromNext â· (HNonEmpty l, HFromClass p (HTail l), + HTail (HFrom (Next p) l) ~ HFrom (Next p) (HTail l)) + â HFromWitness (Next p) l + +class HFromClass n l where + type HFrom n l + hFromWitness â· HFromWitness n l + +instance HFromClass First l where + type HFrom First l = l + hFromWitness = HFromFirst + +instance (HNonEmpty l, HFromClass p (HTail l)) â HFromClass (Next p) l where + type HFrom (Next p) l = HFrom p (HTail l) + hFromWitness = case hFromWitness â· HFromWitness p (HTail l) of + HFromFirst â HFromNext + HFromNext â HFromNext + +hFrom â· â n l . HFromClass n l â HIndex n â HList l â HList (HFrom n l) +hFrom First l = l +hFrom (Next p) l = case hFromWitness â· HFromWitness n l of + HFromNext â hFrom p (hTail l) + _ â undefined + +type HNth n l = HHead (HFrom n l) + +hNth â· â n l . (HFromClass n l, HNonEmpty (HFrom n l)) + â HIndex n â HList l â HNth n l +hNth First l = hHead l +hNth (Next p) l = case hFromWitness â· HFromWitness n l of + HFromNext â hNth p (hTail l) + _ â undefined + +main = putStrLn $ hNth (Next First) (0 .*. "Test") + diff --git a/tests/ghc-regress/simplCore/should_run/T5315.stdout b/tests/ghc-regress/simplCore/should_run/T5315.stdout new file mode 100644 index 0000000..345e6ae --- /dev/null +++ b/tests/ghc-regress/simplCore/should_run/T5315.stdout @@ -0,0 +1 @@ +Test diff --git a/tests/ghc-regress/simplCore/should_run/all.T b/tests/ghc-regress/simplCore/should_run/all.T index a4a2e6c..174fa18 100644 --- a/tests/ghc-regress/simplCore/should_run/all.T +++ b/tests/ghc-regress/simplCore/should_run/all.T @@ -44,3 +44,4 @@ test('T3983', [only_ways(['normal','optasm']), test('T3972', extra_clean(['T3972A.hi', 'T3972A.o']), compile_and_run, ['']) +test('T5315', normal, compile_and_run, [''])
_______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
