module Type.Cluss.TH (clussify) where
import Data.List
import Data.Maybe
import Language.Haskell.TH
import qualified Type.Cluss as C
appt :: Type -> Type -> Type
appt = AppT
infixl 1 `appt`
nary, ovrlp, bond :: Int -> Maybe Type
nary n = fmap ConT $ case n of
1 -> return ''C.Unary
2 -> return ''C.Binary
3 -> return ''C.Ternary
4 -> return ''C.Quaternary
5 -> return ''C.Quinary
6 -> return ''C.Senary
7 -> return ''C.Septenary
8 -> return ''C.Octary
9 -> return ''C.Nonary
10 -> return ''C.Denary
_ -> Nothing
ovrlp n = fmap ConT $ case n of
1 -> return ''(C.>+<)
2 -> return ''(C.>++<)
3 -> return ''(C.>+++<)
4 -> return ''(C.>++++<)
5 -> return ''(C.>+++++<)
6 -> return ''(C.>++++++<)
7 -> return ''(C.>+++++++<)
8 -> return ''(C.>++++++++<)
9 -> return ''(C.>+++++++++<)
10 -> return ''(C.>++++++++++<)
_ -> Nothing
bond n = fmap ConT $ case n of
2 -> return ''(C.>|<)
3 -> return ''(C.>||<)
4 -> return ''(C.>|||<)
5 -> return ''(C.>||||<)
6 -> return ''(C.>|||||<)
7 -> return ''(C.>||||||<)
8 -> return ''(C.>|||||||<)
9 -> return ''(C.>||||||||<)
10 -> return ''(C.>|||||||||<)
_ -> Nothing
clussify :: Name -> Q Type
clussify nm = do
info <- reify nm
return (ConT ''(C.>+<) `appt` ConT nm `appt` convertInfo info)
convertInfo :: Info -> Type
convertInfo (ClassI _ idecs) = ConT ''C.In `appt` foldr
(\typ1 typ2 -> PromotedConsT `appt` typ1 `appt` typ2) PromotedNilT (map fromJust . filter isJust . map convertIdec $ idecs)
convertInfo _ = error "Type.Cluss.TH.convertInfo: unsupported Info"
convertIdec :: InstanceDec -> Maybe Type
convertIdec (InstanceD prds (AppT (ConT _z) typ) _) = do
typs <- foldr (\prd res -> do
res' <- res
ct <- convertPred tvs prd
return $ ct : res') (return []) prds
case n of
0 -> return $ ConT ''C.Type `appt` typa
_ -> do
o <- ovrlp n
p <- makeCnstrnt n n (ConT ''C.Pure)
a <- nary n
let typp = foldl (\typ1 typ2 -> o `appt` typ1 `appt` typ2) p typs
return $ a `appt` typa `appt` typp
where
n = length tvs
(typa, tvs) = convertType typ
convertIdec _ = error "Type.Cluss.TH.convertIdec: unsupported InstanceDec"
convertType :: Type -> (Type, [Name])
convertType (AppT typ (VarT tv)) = (typ', tvs ++ [tv])
where
(typ', tvs) = convertType typ
convertType (AppT typ (SigT (VarT tv) _)) = (typ', tv : tvs)
where
(typ', tvs) = convertType typ
convertType typ = (typ, [])
convertPred :: [Name] -> Pred -> Maybe Type
convertPred tvs (ClassP nm (typs@(_:_))) = do
tv <- case last typs of
VarT tv' -> return tv'
_ -> Nothing
let k = fromJust (elemIndex tv tvs)
makeCnstrnt n k typ
where
n = length tvs
typ = foldl (\typ' prm -> typ' `appt` prm) (ConT nm) (init typs)
convertPred tvs (EqualP typ (VarT tv)) = makeCnstrnt n k (ConT ''C.Is `appt` typ)
where
n = length tvs
k = fromJust (elemIndex tv tvs)
convertPred _ _ = Nothing
makeCnstrnt :: Int -> Int -> Type -> Maybe Type
makeCnstrnt 1 0 t = return $ t
makeCnstrnt 1 _ _ = return $ ConT ''C.Pure
makeCnstrnt n k t = do
b <- bond n
m <- makeCnstrnt (n 1) k t
return $ b `appt` m `appt` c
where
c = if n 1 == k then t else ConT ''C.Pure