module HLearn.Algebra.Types.Indexing
(
Index(..)
, DepIndex(..)
, HasDepIndex(..)
, ValueList
, makeIndex
, TH_0
, TH_1
, TH_2
, TH_3
)
where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import HLearn.Algebra.Types.HList
class
( Eq (IndexType datatype)
, Bounded (IndexType datatype)
, Enum (IndexType datatype)
) => Index datatype
where
type IndexType datatype
type IndexResult datatype
(!) :: datatype -> IndexType datatype -> IndexResult datatype
class DepIndex datatype index where
type DepIndexResult datatype index
(#) :: datatype -> index -> datatype `DepIndexResult` index
type family (#) datatype index
type instance (#) datatype index = DepIndexResult datatype index
instance DepIndex (HList '[]) (Nat1Box Zero) where
type DepIndexResult (HList '[]) (Nat1Box Zero) = ()
_ # _ = ()
instance DepIndex (HList (x ': xs)) (Nat1Box Zero) where
type DepIndexResult (HList (x ': xs)) (Nat1Box Zero) = x
(x:::xs) # _ = x
instance (DepIndex (HList xs) (Nat1Box n)) => DepIndex (HList (x ': xs)) (Nat1Box (Succ n)) where
type DepIndexResult (HList (x ': xs)) (Nat1Box (Succ n)) = DepIndexResult (HList xs) (Nat1Box n)
(x:::xs) # Nat1Box = xs # (Nat1Box :: Nat1Box n)
class (IndexList datatype (HList (DepIndexList datatype))) => HasDepIndex datatype where
type DepIndexList datatype :: [*]
depIndexList :: datatype -> HList (DepIndexList datatype)
datatype2valueList ::
( HasDepIndex datatype
) => datatype -> HList (ValueList datatype)
datatype2valueList dp = valueList dp (depIndexList dp)
type ValueList datatype = IndexList2ValueList datatype (HList (DepIndexList datatype))
class IndexList dp indexL where
type IndexList2ValueList dp indexL :: [*]
valueList :: dp -> indexL -> HList (IndexList2ValueList dp indexL)
instance IndexList dp (HList '[]) where
type IndexList2ValueList dp (HList '[]) = '[]
valueList dp _ = HNil
instance
( IndexList dp (HList xs)
, DepIndex dp x
) => IndexList dp (HList (x ': xs))
where
type IndexList2ValueList dp (HList (x ': xs)) = (dp `DepIndexResult` x) ': (IndexList2ValueList dp (HList xs))
valueList dp (x:::xs) = dp # x ::: valueList dp xs
makeIndex :: Name -> Q [Dec]
makeIndex datatype = do
d2 <- makeDepIndexData datatype
c2 <- makeDepIndexClass datatype
d1 <- makeIndexData datatype
xs <- extractConstructorFields datatype
let (_,_,t0) = head xs
c1 <- if fst $ foldr (\(_,_,t) (bool,t') -> (t==t' && bool,t)) (True,t0) xs
then makeIndexClass datatype
else return []
return $ d1++c1++d2++c2
makeIndexData :: Name -> Q [Dec]
makeIndexData datatype = do
xs <- extractFieldStrings datatype
return $ [
DataD
[]
(mkName $ "I_" ++ nameBase datatype)
[]
(map (\x -> NormalC (mkName $ "I_" ++ x) []) xs)
[mkName "Show",mkName "Read",mkName "Eq",mkName "Ord",mkName "Bounded",mkName "Enum"]
]
makeIndexClass :: Name -> Q [Dec]
makeIndexClass datatype = do
xs <- extractConstructorFields datatype
let (_,_,t) = head xs
return $ [
InstanceD
[]
(AppT (ConT $ mkName "Index") (ConT datatype))
[ TySynInstD (mkName "IndexType" ) [ConT datatype] (ConT $ mkName $ "I_"++nameBase datatype)
, TySynInstD (mkName "IndexResult") [ConT datatype] t
, FunD
(mkName "!")
(map (\(x,_,_) -> Clause
[VarP $ mkName "datatype", ConP (mkName $ "I_"++nameBase x) []]
(NormalB $ AppE (VarE x) (VarE $ mkName "datatype"))
[]
) xs)
]
]
depIndexPrefix :: String
depIndexPrefix = "TH"
makeDepIndexData :: Name -> Q [Dec]
makeDepIndexData datatype = do
xs <- extractFieldStrings datatype
return $ map (\x ->
DataD
[]
(mkName $ depIndexPrefix++x)
[]
[NormalC (mkName $ depIndexPrefix++x) []]
[mkName "Show", mkName "Read", mkName "Eq", mkName "Ord"]
) xs
makeDepIndexClass :: Name -> Q [Dec]
makeDepIndexClass datatype = do
xs <- extractConstructorFields datatype
return $ map (\(x,_,t) ->
InstanceD
[]
(AppT (AppT (ConT $ mkName "DepIndex") (ConT datatype)) (ConT $ mkName $ depIndexPrefix++nameBase x))
[ TySynInstD (mkName "DepIndexResult") [ConT datatype, ConT $ mkName $ depIndexPrefix++nameBase x] t
, FunD
(mkName "#")
[ Clause
[VarP $ mkName "datatype", VarP $ mkName "index"]
(NormalB $ AppE (VarE x) (VarE $ mkName "datatype"))
[]
]
]
) xs
extractFieldStrings :: Name -> Q [String]
extractFieldStrings datatype = do
xs <- extractConstructorFields datatype
return $ do
(name,_,_) <- xs
return $ nameBase name
type ConstructorFieldInfo = (Name,Strict,Type)
extractConstructorFields :: Name -> Q [ConstructorFieldInfo]
extractConstructorFields datatype = do
let datatypeStr = nameBase datatype
i <- reify datatype
return $ case i of
TyConI (DataD _ _ _ [RecC _ fs] _) -> fs
TyConI (NewtypeD _ _ _ (RecC _ fs) _) -> fs
TyConI (DataD _ _ _ [_] _) -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr
TyConI NewtypeD{} -> error $ "Can't derive Lens without record selectors: " ++ datatypeStr
TyConI TySynD{} -> error $ "Can't derive Lens for type synonym: " ++ datatypeStr
TyConI DataD{} -> error $ "Can't derive Lens for tagged union: " ++ datatypeStr
_ -> error $ "Can't derive Lens for: " ++ datatypeStr ++ ", type name required."
data TH_0 = TH_0
data TH_1 = TH_1
data TH_2 = TH_2
data TH_3 = TH_3
data TH_4 = TH_4
data TH_5 = TH_5
data TH_6 = TH_6
data TH_7 = TH_7
data TH_8 = TH_8
data TH_9 = TH_9
instance DepIndex (a,b) TH_0 where
type (a,b) `DepIndexResult` TH_0 = a
(a,b) # TH_0 = a
instance DepIndex (a,b) TH_1 where
type (a,b) `DepIndexResult` TH_1 = b
(a,b) # TH_1 = b
instance (Ord a, Num a) => Index (a,a) where
type IndexType (a,a) = Int
type IndexResult (a,a) = a
(!) (a0,a1) 0 = a0
(!) (a0,a1) 1 = a1
instance DepIndex (a,b,c) TH_0 where
type (a,b,c) `DepIndexResult` TH_0 = a
(a,b,c) # TH_0 = a
instance DepIndex (a,b,c) TH_1 where
type (a,b,c) `DepIndexResult` TH_1 = b
(a,b,c) # TH_1 = b
instance DepIndex (a,b,c) TH_2 where
type (a,b,c) `DepIndexResult` TH_2 = c
(a,b,c) # TH_2 = c
instance (Ord a, Num a) => Index (a,a,a) where
type IndexType (a,a,a) = Int
type IndexResult (a,a,a) = a
(!) (a0,a1,a2) 0 = a0
(!) (a0,a1,a2) 1 = a1
(!) (a0,a1,a2) 2 = a2