Ticket #2820: RepMinimal.hs

File RepMinimal.hs, 3.3 KB (added by ben.kavanagh, 5 years ago)

Minimal example of failure. Failure seems to be related to compilation of 'badFunction'

Line 
1{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE ExistentialQuantification, TypeOperators, GADTs #-}
3{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances  #-}
4{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables  #-}
5
6-----------------------------------------------------------------------------
7-- |
8-- Module      :  Data.RepLib.R
9-- Copyright   :  (c) The University of Pennsylvania, 2006
10-- License     :  BSD
11--
12-- Maintainer  :  sweirich@cis.upenn.edu
13-- Stability   :  experimental
14-- Portability :  non-portable
15--
16--
17-----------------------------------------------------------------------------
18
19module Data.RepLib.RepCombined (
20
21  -- ** Operations for heterogeneous lists
22  findCon, Val(..), 
23
24  -- ** SYB Reloaded
25  Typed(..), Spine(..), 
26
27  -- these seem to 'cause' the problem.
28  -- toSpine,
29  badFunction
30
31) where
32
33import Data.List
34
35data R a where
36   Int     :: R Int
37   Char    :: R Char 
38   Integer :: R Integer
39   Float   :: R Float
40   Double  :: R Double
41   Rational:: R Rational
42   IOError :: R IOError
43   IO      :: (Rep a) => R a -> R (IO a)
44   Arrow   :: (Rep a, Rep b) => R a -> R b -> R (a -> b)
45   Data    :: DT -> [Con R a] -> R a
46
47data Emb l a  = Emb { to     :: l -> a, 
48                      from   :: a -> Maybe l, 
49                      labels :: Maybe [String], 
50                      name   :: String,
51                      fixity :: Fixity
52                     }
53
54data Fixity =  Nonfix
55                | Infix      { prec      :: Int }
56                | Infixl     { prec      :: Int }
57                | Infixr     { prec      :: Int }
58
59data DT       = forall l. DT String (MTup R l)
60data Con r a  = forall l. Con (Emb l a) (MTup r l)
61
62
63data Nil = Nil 
64data a :*: l = a :*: l
65infixr 7 :*:
66
67data MTup r l where
68    MNil   :: MTup ctx Nil
69    (:+:)  :: (Rep a) => r a -> MTup r l -> MTup r (a :*: l)
70
71infixr 7 :+:
72
73class Rep a where rep :: R a
74
75instance Eq (R a) where
76         r1 == r2 = True
77
78-- | A datastructure to store the results of findCon
79data Val ctx a = forall l.  Val (Emb l a) (MTup ctx l) l
80
81-- | Given a list of constructor representations for a datatype,
82-- determine which constructor formed the datatype.
83findCon :: [Con ctx a] -> a -> Val ctx a
84findCon (Con rcd rec : rest) x = case (from rcd x) of 
85       Just ys -> Val rcd rec ys
86       Nothing -> findCon rest x
87
88
89-------------- Spine from SYB Reloaded ---------------------------
90
91data Typed a = a ::: R a
92infixr 7 :::
93
94data Spine a where
95         Constr :: a -> Spine a
96         (:<>:)  :: Spine (a -> b) -> Typed a -> Spine b
97
98{-
99
100toSpine :: Rep a => a -> Spine a
101toSpine = toSpineR rep
102
103toSpineR :: R a -> a -> Spine a
104toSpineR (Data _ cons) a =
105         case (findCon cons a) of
106            Val emb reps kids -> Constr toSpineRl reps kids (to emb)
107toSpineR _ a = Constr a
108
109toSpineRl :: MTup R l -> l -> (l -> a) -> Spine a
110toSpineRl MNil Nil into = Constr (into Nil)
111toSpineRl (ra :+: rs) (a :*: l) into =
112         (toSpineRl rs l into') :<>: (a ::: ra)
113                  where into' tl1 x1 = into (x1 :*: tl1)
114
115fromSpine :: Spine a -> a
116fromSpine (Constr x) = x
117fromSpine (x :<> (y:::_)) = fromSpine x y
118
119-}
120
121-- toSpineRl function causes problem
122badFunction :: MTup R l -> l -> (l -> a) -> Spine a
123badFunction MNil Nil into = Constr (into Nil)
124badFunction (ra :+: rs) (a :*: l) into = 
125         (badFunction rs l into') :<>: (a ::: ra)
126                  where into' tl1 x1 = into (x1 :*: tl1)
127
128
129