Infinite Types

gistfile1.hs

{-# LANGUAGE RankNTypes, GADTs, KindSignatures, ScopedTypeVariables, DataKinds,
             TypeSynonymInstances, FlexibleInstances, OverlappingInstances,
             TypeOperators, StandaloneDeriving #-}

module MyData.Trie where

import Control.Arrow
import Data.Array
import Data.Bits
import Data.Char

ordUnit :: Order () ()
ordUnit = TrivO

ordNat8 :: Order Int Int
ordNat8 = NatO 255

ordNat16 :: Order Int Int
ordNat16 = NatO 65535

ordInt32 :: Order ((Int,Int),(Int,Int)) Int
ordInt32 = MapO (splitW . (+ (-2147483648))) (ProdL ordNat16 ordNat16)

splitW :: Int -> (Int, Int)
splitW x = (shiftR x 16 .&. 65535, x .&. 65535)

ordChar8 :: Order (Int,Int) Char
ordChar8 = MapO ord ordNat8

ordChar16 :: Order (Int,Int) Char
ordChar16 = MapO ord ordNat16

fromList :: [t] -> Either () (t, [t])
fromList [] = Left ()
fromList (x : xs) = Right (x, xs)

--listL :: Order ??? t -> Order ??? [t]
listL r = MapO fromList (SumL ordUnit (ProdL r (listL r)))

--ordString8 :: Order String
--ordString8 = listL ordChar8

--ordString16 :: Order String
--ordString16 = listL ordChar16

deriving instance Show v => Show (Trie i k v)

instance Show (b -> a) where
    show _ = "<function>"

instance Show (TArray v) where
   show _ = "<base array>"

type TArray v = Array Int v

data Trie :: * -> * -> * -> * where
   TEmpty :: Trie z k v
   TUnit  :: v -> Trie () () v
   TSum   :: Trie p1 k1 v -> Trie p2 k2 v -> Trie (p1,p2) (Either k1 k2) v
   TProd  :: Trie p1 k1 (Trie p2 k2 v) -> Trie (p1,p2) (k1,k2) v
   TMap   :: (k1 -> k2) -> Trie p1 k2 v -> Trie (k2,p1) k1 v
   TInt   :: TArray v -> Trie Int Int v

instance Functor (Trie p k) where
   fmap _ TEmpty     = TEmpty
   fmap f (TUnit v)    = TUnit (f v)
   fmap f (TSum t1 t2) = TSum (fmap f t1) (fmap f t2)
   fmap f (TProd t)    = TProd (fmap (fmap f) t)
   fmap f (TMap g t)   = TMap g (fmap f t)
   fmap f (TInt t)     = TInt (fmap f t)

merge :: (v -> v -> v) -> Trie p k v -> Trie p k v -> Trie p k v
merge _ TEmpty t                  = t
merge _ t TEmpty                  = t
merge c (TUnit v1) (TUnit v2)     = TUnit $ c v1 v2
merge c (TSum t1 t2) (TSum s1 s2) = TSum (merge c t1 s1) (merge c t2 s2)
merge c (TProd t1) (TProd t2)     = TProd $ merge (merge c) t1 t2
merge c (TMap f t1) (TMap _ t2)   = TMap f (merge c t1 t2)
merge f (TInt a1) (TInt a2)       = TInt $ mergeArr f a1 a2
merge _ t _                       = t

tlookup :: Trie p k v -> k -> Maybe v
tlookup TEmpty _            = Nothing
tlookup (TUnit v) ()          = Just v
tlookup (TSum t1 _) (Left a)  = tlookup t1 a
tlookup (TSum _ t2) (Right a) = tlookup t2 a
tlookup (TProd t1) (k1,k2)    = tlookup t1 k1 >>= (`tlookup` k2)
tlookup (TMap g t1) k         = tlookup t1 $ g k
tlookup (TInt t1) k           = Just $ t1 ! k

data Order :: * -> * -> * where
   NatO  :: Int -> Order Int Int
   TrivO :: Order () ()
   SumL  :: Order i1 t1 -> Order i2 t2 -> Order (i1,i2) (Either t1 t2)
   ProdL :: Order i1 t1 -> Order i2 t2 -> Order (i1,i2) (t1, t2)
   MapO  :: (t1 -> t2) -> Order i2 t2 -> Order (t2,i2) t1

trie :: Order i k -> forall v.[(k,v)] -> Trie i k [v]
trie _ [ ]             = TEmpty
trie TrivO rel         = TUnit (map snd rel)
trie (SumL o1 o2) rel  = TSum l r
   where l = trie o1 (sumlefts rel)
         r = trie o2 (sumrights rel)
trie (ProdL o1 o2) rel = TProd (fmap (trie o2) (trie o1 (map curryl rel)))
trie (MapO g o) rel    = TMap g (trie o (map (first g) rel))
trie (NatO i) rel      = TInt (bdiscNat i rel)

-----------------
-- Helper code --
-----------------
curryl :: ((a,b),c) -> (a,(b,c))
curryl ((a,b),c) = (a,(b,c))

sumlefts :: [(Either a b,c)] -> [(a,c)]
sumlefts xs = [ (a,c) | (Left a, c) <- xs ]

sumrights :: [(Either a b,c)] -> [(b,c)]
sumrights xs = [ (b,c) | (Right b, c) <- xs ]

bdiscNat :: Int -> [(Int, v)] -> TArray [v]
bdiscNat (n :: Int) = accumArray (flip (:)) [] (0, n-1)

mergeArr :: (v -> v -> v) -> TArray v -> TArray v -> TArray v
mergeArr f a1 a2 = array (bounds a1) $ zipWith (\(a,b) (_,d) -> (a,f b d)) (assocs a1) (assocs a2)