Commit dee603f0 authored by ralf's avatar ralf

[project @ 2004-11-07 14:42:39 by ralf]

A long-pending commit.
Another commit later today,
(Once an up-to-date GHC is running.)
parent b6f41939
......@@ -43,6 +43,7 @@ clean:
rm -f gmapQ-assoc
rm -f gread
rm -f gread2
rm -f gshow2
rm -f gshow/gshow
rm -f gzip/gzip
rm -f hopat
......
test('newtype', normal, compile_and_run, [''])
test('datatype', normal, compile_and_run, [''])
test('encode', normal, compile, [''])
test('ext', normal, compile, [''])
test('where', normal, compile_and_run, [''])
test('gmapQ-assoc', normal, compile_and_run, [''])
test('nested-datatypes', normal, compile_and_run, [''])
......@@ -8,6 +10,7 @@ test('labels', normal, compile_and_run, [''])
test('twin', normal, compile_and_run, [''])
test('gread', normal, compile_and_run, [''])
test('gread2', normal, compile_and_run, [''])
test('gshow2', normal, compile_and_run, [''])
test('hlist', normal, compile_and_run, [''])
test('hopat', normal, compile_and_run, [''])
test('foldTree', normal, compile_and_run, [''])
......
{-# OPTIONS -fglasgow-exts #-}
-- A bit more test code for the 2nd boilerplate paper.
-- These are downscaled versions of library functionality or real test cases.
-- We just wanted to typecheck the fragments as shown in the paper.
module Main where
import Data.Generics
data Bit = Zero | One
------------------------------------------------------------------------------
-- Sec. 3.2
data2bits :: Data a => a -> [Bit]
data2bits t = encodeCon (dataTypeOf t) (toConstr t)
++ concat (gmapQ data2bits t)
-- The encoder for constructors
encodeCon :: DataType -> Constr -> [Bit]
encodeCon ty con = natToBin (max-1) (idx-1)
where
max = maxConstrIndex ty
idx = constrIndex con
natToBin :: Int -> Int -> [Bit]
natToBin = undefined
------------------------------------------------------------------------------
-- Sec. 3.3
data State -- Abstract
initState :: State
encodeCon' :: DataType -> Constr
-> State -> (State, [Bit])
initState = undefined
encodeCon' = undefined
data2bits' :: Data a => a -> [Bit]
data2bits' t = snd (show_bin t initState)
show_bin :: Data a => a -> State -> (State, [Bit])
show_bin t st = (st2, con_bits ++ args_bits)
where
(st1, con_bits) = encodeCon' (dataTypeOf t)
(toConstr t) st
(st2, args_bits) = foldr do_arg (st1,[])
enc_args
enc_args :: [State -> (State,[Bit])]
enc_args = gmapQ show_bin t
do_arg fn (st,bits) = (st', bits' ++ bits)
where
(st', bits') = fn st
------------------------------------------------------------------------------
-- Sec. 3.3 cont'd
data EncM a -- The encoder monad
instance Monad EncM
where
return = undefined
c >>= f = undefined
runEnc :: EncM () -> [Bit]
emitCon :: DataType -> Constr -> EncM ()
runEnc = undefined
emitCon = undefined
data2bits'' :: Data a => a -> [Bit]
data2bits'' t = runEnc (emit t)
emit :: Data a => a -> EncM ()
emit t = do { emitCon (dataTypeOf t) (toConstr t)
; sequence_ (gmapQ emit t) }
------------------------------------------------------------------------------
main = undefined
{-# OPTIONS -fglasgow-exts #-}
module Main where
-- There were typos in these definitions in the ICFP 2004 paper.
import Data.Generics
extQ fn spec_fn arg
= case gcast (Q spec_fn) of
Just (Q spec_fn') -> spec_fn' arg
Nothing -> fn arg
newtype Q r a = Q (a -> r)
extT fn spec_fn arg
= case gcast (T spec_fn) of
Just (T spec_fn') -> spec_fn' arg
Nothing -> fn arg
newtype T a = T (a -> a)
extM :: (Typeable a, Typeable b)
=> (a -> m a) -> (b -> m b) -> (a -> m a)
extM fn spec_fn
= case gcast (M spec_fn) of
Just (M spec_fn') -> spec_fn'
Nothing -> fn
newtype M m a = M (a -> m a)
main = undefined
......@@ -13,7 +13,7 @@ import LittleLanguage
-- Generate all terms of a given depth
genUpTo :: forall a. Data a => Int -> [a]
genUpTo :: Data a => Int -> [a]
genUpTo 0 = []
genUpTo d = result
where
......
......@@ -3,10 +3,8 @@
{-
For the discussion in the 2nd boilerplate paper,
we favour some simplified generic read.
So the full story is in Data.Generics.Text,
but the short version from the paper is turned into a test
case below.
we favour some simplified generic read, which is checked to compile.
For the full/real story see Data.Generics.Text.
-}
......@@ -37,6 +35,7 @@ parseConstr ty = D (\s ->
where
match :: String -> [Constr]
-> Maybe (String, Constr)
match _ [] = Nothing
match input (con:cons)
| take n input == showConstr con
= Just (drop n input, con)
......@@ -49,13 +48,14 @@ parseConstr ty = D (\s ->
readM :: Data a => DecM a
readM = read
where
read = do { let ty = dataTypeOf (foo read)
read = do { let val = argOf read
; let ty = dataTypeOf val
; constr <- parseConstr ty
; let con::a = fromConstr constr
; gmapM (\_ -> readM) con }
foo :: DecM a -> a
foo = undefined
argOf :: c a -> a
argOf = undefined
yareadM :: Data a => DecM a
yareadM = readM'
......
{-# OPTIONS -fglasgow-exts #-}
{-
The generic show example from the 2nd boilerplate paper.
(There were some typos in the ICFP 2004 paper.)
Also check out Data.Generics.Text.
-}
module Main where
import Data.Generics hiding (gshow)
import Prelude hiding (showString)
gshow :: Data a => a -> String
gshow = gshow_help `extQ` showString
gshow_help :: Data a => a -> String
gshow_help t
= "("
++ showConstr (toConstr t)
++ concat (intersperse " " (gmapQ gshow t))
++ ")"
showString :: String -> String
showString s = "\"" ++ concat (map escape s) ++ "\""
where
escape '\n' = "\\n"
escape other_char = [other_char]
gshowList :: Data b => [b] -> String
gshowList xs
= "[" ++ concat (intersperse "," (map gshow xs)) ++ "]"
gshow' :: Data a => a -> String
gshow' = gshow_help `ext1Q` gshowList
`extQ` showString
intersperse :: a -> [a] -> [a]
intersperse _ [] = []
intersperse x [e] = [e]
intersperse x (e:es) = (e:(x:intersperse x es))
main = print $ ( gshow' "foo"
, gshow' [True,False]
)
......@@ -16,7 +16,7 @@ import CompanyDatatypes
-- Trealise Data to Tree
data2tree :: forall a. Data a => a -> Tree String
data2tree :: Data a => a -> Tree String
data2tree = gdefault `extQ` atString
where
atString (x::String) = Node x []
......@@ -24,7 +24,7 @@ data2tree = gdefault `extQ` atString
-- De-trealise Tree to Data
tree2data :: forall a. Data a => Tree String -> Maybe a
tree2data :: Data a => Tree String -> Maybe a
tree2data = gdefault `extR` atString
where
atString (Node x []) = Just x
......
......@@ -46,6 +46,38 @@ gfoldlQ k z t = unR (gfoldl k' z' t)
z' _ = R z
k' (R r) c = R (k r c)
main = print $ ( geq [True,True] [True,True]
, geq [True,True] [True,False]
-----------------------------------------------------------------------------
-- A dependently polymorphic geq
geq'' :: Data a => a -> a -> Bool
geq'' x y = toConstr x == toConstr y
&& and (gzipWithQ' geq'' x y)
-- A helper type for existentially quantified queries
data XQ r = forall a. Data a => XQ (a -> r)
-- A dependently polymorphic gzipWithQ
gzipWithQ' :: (forall a. Data a => a -> a -> r)
-> (forall a. Data a => a -> a -> [r])
gzipWithQ' f t1 t2
= gApplyQ' (gmapQ (\x -> XQ (f x)) t1) t2
-- Apply existentially quantified queries
-- Insist on equal types!
--
gApplyQ' :: Data a => [XQ r] -> a -> [r]
gApplyQ' qs t = reverse (snd (gfoldlQ k z t))
where
z = (qs, [])
k (XQ q : qs, rs) child = (qs, q' child : rs)
where
q' = error "Twin mismatch" `extQ` q
-----------------------------------------------------------------------------
main = print $ ( geq [True,True] [True,True]
, geq [True,True] [True,False]
, geq'' [True,True] [True,True]
, geq'' [True,True] [True,False]
)
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