Skip to content
This repository has been archived by the owner on Mar 4, 2023. It is now read-only.

Commit

Permalink
Fix a problem with fundeps on GHC 7.2
Browse files Browse the repository at this point in the history
Introduced IsFunction type class, which is quoted from http://okmij.org/ftp/Haskell/typecast.html#is-function-type.
  • Loading branch information
Mitsutoshi Aoe committed Nov 19, 2011
1 parent a22dcd1 commit 939f5f7
Showing 1 changed file with 40 additions and 7 deletions.
47 changes: 40 additions & 7 deletions Data/AttoLisp.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings, Rank2Types, DeriveDataTypeable, BangPatterns #-}
-- The following is for the ParseList stuff
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,
UndecidableInstances #-}
UndecidableInstances, ScopedTypeVariables, OverlappingInstances, EmptyDataDecls #-}
-- | Efficient parsing and serialisation of S-Expressions (as used by Lisp).
--
-- This module is intended to be imported qualified, e.g.:
Expand Down Expand Up @@ -305,15 +305,48 @@ typeMismatch expected actual =
class ParseList a b | a -> b where
parseList :: String -> a -> [Lisp] -> Parser b

instance (FromLisp a, ParseList b c) => ParseList (a -> b) c where
parseList msg _ [] = fail $ "Too few arguments for object: " ++ msg
parseList msg f (x:xs) = do
instance (IsFunction a f, ParseList' f a b) => ParseList a b where
parseList = parseList' (undefined :: f)

class ParseList' f a b | f a -> b where
parseList' :: f -> String -> a -> [Lisp] -> Parser b

instance (FromLisp a, IsFunction b f, ParseList' f b c, ParseList b c)
=> ParseList' HTrue (a -> b) c where
parseList' _ msg _ [] = fail $ "Too few arguments for object: " ++ msg
parseList' _ msg f (x:xs) = do
y <- parseLisp x
parseList msg (f y) xs

instance ParseList a a where
parseList _msg r [] = return r
parseList msg _ (_:_) = fail $ "Too many arguments for object: " ++ msg
instance ParseList' HFalse a a where
parseList' _ _msg r [] = return r
parseList' _ msg _ (_:_) = fail $ "Too many arguments for object: " ++ msg

data HTrue
data HFalse

class IsFunction a b | a -> b

instance TypeCast f HTrue => IsFunction (x -> y) f
instance TypeCast f HFalse => IsFunction a f

class TypeCast a b | a -> b, b -> a where
typeCast :: a -> b

class TypeCast' t a b | t a -> b, t b -> a where
typeCast' :: t -> a -> b

class TypeCast'' t a b | t a -> b, t b -> a where
typeCast'' :: t -> a -> b

instance TypeCast' () a b => TypeCast a b where
typeCast x = typeCast' () x

instance TypeCast'' t a b => TypeCast' t a b where
typeCast' = typeCast''

instance TypeCast'' () a a where
typeCast'' _ x = x

-- | Decode structure serialised with 'mkStruct'.
--
Expand Down

0 comments on commit 939f5f7

Please sign in to comment.