Orphans.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, StandaloneDeriving, DeriveDataTypeable, ImpredicativeTypes, ScopedTypeVariables, Trustworthy #-}

module Data.Columbia.Internal.Orphans (LazyFix(LazyFix), LazyMap(..)) where

import Data.Word
import Data.Typeable hiding (Proxy)
import qualified Data.Map as M
import Generics.Pointless.Functors
import Data.Generics.SYB.WithClass.Basics
import Data.Columbia.Internal.IntegralTypes
import Data.Columbia.Internal.Headers
import Data.Columbia.Types
import Data.Columbia.FRecord
import Data.Columbia.WithAddress
import Data.Array.Unboxed
import Data.Tree

idConstr = Constr(AlgConstr 1) "IdF" [] Prefix idDataType
idDataType = DataType "Generics.Pointless.Functors" (AlgRep[idConstr])
instance (Sat(ctx(Id x)), Data ctx x) => Data ctx(Id x) where
	gfoldl _ o f (IdF x) = f IdF `o` x
	gunfold _ k f _ = k(f IdF)
	dataTypeOf _ _ = idDataType
	toConstr _ _ = idConstr
	dataCast1 _ = gcast1

constConstr = Constr(AlgConstr 1) "ConsF" [] Prefix idDataType
constDataType = DataType "Generics.Pointless.Functors" (AlgRep[constConstr])
instance (Sat(ctx(Const t x)), Data ctx t, Data ctx x) => Data ctx(Const t x) where
	gfoldl _ o f (ConsF x) = f ConsF `o` x
	gunfold _ k f _ = k(f ConsF)
	dataTypeOf _ _ = constDataType
	toConstr _ _ = constConstr
	dataCast1 _ = gcast1

sumConstr1 = Constr(AlgConstr 1) "InlF" [] Prefix sumDataType
sumConstr2 = Constr(AlgConstr 2) "InrF" [] Prefix sumDataType
sumDataType = DataType "Generics.Pointless.Functors" (AlgRep[sumConstr1,sumConstr2])
instance (Sat(ctx((:+:) g h x)), Typeable1 g, Typeable1 h, Data ctx x, Data ctx(g x), Data ctx(h x)) => Data ctx((:+:) g h x) where
	gfoldl _ o f (InlF x) = f InlF `o` x
	gfoldl _ o f (InrF x) = f InrF `o` x
	gunfold _ k f constr = case constrIndex constr of
		1 -> k(f InlF)
		2 -> k(f InrF)
		_ -> error"Sum.gunfold: unrecognized constructor index"
	dataTypeOf _ _ = sumDataType
	toConstr _ (InlF _) = sumConstr1
	toConstr _ (InrF _) = sumConstr2
	dataCast1 _ = gcast1

prodConstr = Constr(AlgConstr 1) "ProdF" [] Prefix prodDataType
prodDataType = DataType "Generics.Pointless.Functors" (AlgRep[prodConstr])
instance (Sat(ctx((:*:) g h x)), Typeable1 g, Typeable1 h, Data ctx x, Data ctx(g x), Data ctx(h x)) => Data ctx((:*:) g h x) where
	gfoldl _ o f (ProdF x x2) = f ProdF `o` x `o` x2
	gunfold _ k f _ = k(k(f ProdF))
	dataTypeOf _ _ = prodDataType
	toConstr _ _ = prodConstr
	dataCast1 _ = gcast1

compConstr = Constr(AlgConstr 1) "CompF" [] Prefix compDataType
compDataType = DataType "Generics.Pointless.Functors" (AlgRep[compConstr])
instance (Sat(ctx((:@:) g h x)), Typeable1 g, Typeable1 h, Data ctx x, Data ctx(g(h x))) => Data ctx((:@:) g h x) where
	gfoldl _ o f (CompF x) = f CompF `o` x
	gunfold _ k f _ = k(f CompF)
	toConstr _ _ = compConstr
	dataTypeOf _ _ = compDataType
	dataCast1 _ = gcast1

----------------------------------------------

deriving instance (Eq(Rep f(Fix f))) => Eq(Fix f)

deriving instance (Ord(Rep f(Fix f))) => Ord(Fix f)

deriving instance (Typeable1 f) => Typeable(LazyFix f)

deriving instance (Eq(Rep f(LazyFix f))) => Eq(LazyFix f)

deriving instance (Ord(Rep f(LazyFix f))) => Ord(LazyFix f)

deriving instance (Show(Rep f(LazyFix f))) => Show(LazyFix f)

deriving instance (Read(Rep f(LazyFix f))) => Read(LazyFix f)

lazyFixConstr = Constr(AlgConstr 1) "LazyFix" [] Prefix lazyFixDataType
lazyFixDataType = DataType "Generics.Pointless.Functors" (AlgRep[lazyFixConstr])
instance (Sat(ctx(LazyFix f)), Typeable1 f, Data ctx(Rep f(LazyFix f))) => Data ctx(LazyFix f) where
	gfoldl _ o f (LazyFix x) = f LazyFix `o` x
	gunfold _ k f _ = k(f LazyFix)
	dataTypeOf _ _ = lazyFixDataType
	toConstr _ _ = lazyFixConstr

instance (Typeable1 f) => RW(LazyFix f)
instance KeyComparable(LazyFix f)

----------------------------------------------

instance (Ix i, IArray UArray e, Sat(ctx(UArray i e)), Typeable i, Data ctx e, Sat(ctx[e])) => Data ctx(UArray i e) where
	gfoldl _ o f ua = f(listArray(bounds ua)) `o` elems ua
	gunfold = error"no gunfold"
	toConstr = error"no toConstr"
	dataTypeOf _ _ = mkNorepType"Data.Array.Unboxed.UArray"
	dataCast1 _ = gcast1

----------------------------------------------

treeConstr = Constr(AlgConstr 1) "Node" [] Prefix treeDataType
treeDataType = DataType "Data.Tree.Tree" (AlgRep[treeConstr])
instance (Data ctx t,Data ctx[Tree t],Sat(ctx(Tree t))) => Data ctx(Tree t) where
	gfoldl _ o k (Node x ls) = k Node `o` x `o` ls
	gunfold _ f k _ = f(f(k Node))
	toConstr _ _ = treeConstr
	dataTypeOf _ _ = treeDataType
	dataCast1 _ = gcast1

----------------------------------------------

binConstr = Constr(AlgConstr 1) "Bin" [] Prefix mapDataType
tipConstr = Constr(AlgConstr 2) "Tip" [] Prefix mapDataType
mapDataType = DataType "Data.Columbia.Orphans.LazyMap" (AlgRep[binConstr,tipConstr])
instance (Sat(ctx Int), Sat(ctx Word32), Data ctx k, Data ctx v, Sat(ctx(LazyMap k v)), Sat(ctx(WithAddress(LazyMap k v)))) => Data ctx(LazyMap k v) where
	gfoldl _ o f (BinPrime sz k v bin bin2) = f BinPrime `o` sz `o` k `o` v `o` bin `o` bin2
	gfoldl _ _ f TipPrime = f TipPrime
	gunfold _ f k constr = case constrIndex constr of
		1 -> f(f(f(f(f(k BinPrime)))))
		2 -> k TipPrime
		_ -> error"LazyMap.gunfold: invalid constructor index"
	toConstr _ (BinPrime _ _ _ _ _) = binConstr
	toConstr _ TipPrime = tipConstr
	dataTypeOf _ _ = mapDataType
	dataCast1 _ = gcast1
	dataCast2 _ = gcast2

instance (Typeable k, Typeable v) => RW(LazyMap k v)
instance KeyComparable(LazyMap k v)