module Language.Syntactic.Functional.Tuple.TH where
import Data.Generics
import Language.Haskell.TH
import Language.Syntactic ((:->), Full, AST (..), (:<:), Syntactic (..))
import Language.Syntactic.TH
class SelectX tup
where
type SelX tup
selectX :: tup -> SelX tup
classTemplate :: DecsQ
classTemplate =
[d| class SelectX tup
where
type SelX tup
selectX :: tup -> SelX tup
|]
instanceTemplate :: DecsQ
instanceTemplate =
[d| instance SelectX tup
where
type SelX tup = Double
selectX tup = undefined
|]
mkSelectClassPlusInstances
:: Int
-> DecsQ
mkSelectClassPlusInstances n = do
[classTempl] <- classTemplate
[instanceTempl] <- instanceTemplate
let classDecs = [everywhere (mkT (fixName s)) classTempl | s <- [1..n]]
instDecs =
[ everywhere
( mkT (fixTupType s w)
. mkT (fixTupPat s w)
. mkT (fixTupExp s w)
. mkT (fixName s)
)
instanceTempl
| w <- [2..n]
, s <- [1..w]
]
return (classDecs ++ instDecs)
fixName :: Int -> Name -> Name
fixName s
= mkName
. concatMap (\c -> if c=='X' then show s else [c])
. takeWhile (/='_')
. nameBase
fixTupType :: Int -> Int -> Type -> Type
fixTupType s w ty
| VarT tup <- ty
, "tup" <- show tup = foldl1 AppT ((TupleT w) : tupVars)
| ConT doub <- ty
, show doub == "Double" = tupVars !! (s1)
| otherwise = ty
where
tupVars = map VarT $ take w varSupply
fixTupPat :: Int -> Int -> Pat -> Pat
fixTupPat s w pat
| VarP tup <- pat
, "tup" <- show tup = TupP tupVars
| otherwise = pat
where
tupVars = map VarP $ take w varSupply
fixTupExp :: Int -> Int -> Exp -> Exp
fixTupExp s w ex
| VarE tup <- ex
, "tup" <- show tup = TupE tupVars
| VarE undef <- ex
, show undef == "undefined" = tupVars !! (s1)
| otherwise = ex
where
tupVars = map VarE $ take w varSupply
mkTupleSym
:: String
-> String
-> String
-> Int
-> DecsQ
mkTupleSym tyName tupName selName n = do
let tupCons =
[ ForallC
(map PlainTV (take w varSupply))
[eqPred (VarT (mkName "sig")) (signature w)]
(NormalC (mkName (tupName ++ show w)) [])
| w <- [2..n]
]
let selCons =
[ ForallC
[PlainTV (mkName "tup")]
[ eqPred
(VarT (mkName "sig"))
( foldl1 AppT
[ ConT ''(:->)
, VarT (mkName "tup")
, AppT (ConT ''Full) (AppT (ConT (mkName ("Sel" ++ show s))) (VarT (mkName "tup")))
]
)
, classPred (mkName ("Select" ++ show s)) [VarT (mkName "tup")]
]
(NormalC (mkName (selName ++ show s)) [])
| s <- [1..n]
]
return [DataD [] (mkName tyName) [PlainTV (mkName "sig")] (tupCons ++ selCons) []]
where
signature :: Int -> Type
signature w = foldr
(\a res -> foldl1 AppT [ConT ''(:->), a, res])
(AppT (ConT ''Full)
(foldl AppT (TupleT w) vars))
vars
where
vars = map VarT $ take w varSupply
deriveSyntacticForTuples
:: (Type -> Cxt)
-> (Type -> Type)
-> (Exp -> Exp)
-> Int
-> DecsQ
deriveSyntacticForTuples internalPred mkDomain symInj n = return $
map deriveSyntacticForTuple [2..n]
where
deriveSyntacticForTuple w = InstanceD
( concat
[ map (classPred ''Syntactic . return) varsT
, concatMap internalPred $ map (AppT (ConT ''Internal)) varsT
, [classPred ''(:<:) [ConT (mkName "Tuple"), VarT (mkName "sym")]]
, [eqPred domainA (mkDomain (VarT (mkName "sym")))]
, [eqPred domainA (AppT (ConT ''Domain) b)
| b <- tail varsT
]
]
)
(AppT (ConT ''Syntactic) tupT)
[ tySynInst ''Domain [tupT] domainA
, tySynInst ''Internal [tupT] tupTI
, FunD 'desugar
[ Clause
[TupP varsP]
(NormalB
( foldl
(\s a -> foldl1 AppE [ConE '(:$), s, AppE (VarE 'desugar) a])
(AppE (ConE 'Sym) (symInj (ConE (mkName ("Tup" ++ show w)))))
varsE
)
)
[]
]
, FunD 'sugar
[ Clause
[VarP (mkName "tup")]
(NormalB
( TupE
[ AppE
(VarE 'sugar)
( foldl1 AppE
[ ConE '(:$)
, AppE (ConE 'Sym) (symInj (ConE (mkName ("Sel" ++ show s))))
, VarE (mkName "tup")
]
)
| s <- [1..w]
]
)
)
[]
]
]
where
varsT = map VarT $ take w varSupply
tupT = foldl AppT (TupleT w) varsT
tupTI = foldl AppT (TupleT w) $ map (AppT (ConT ''Internal)) varsT
domainA = AppT (ConT ''Domain) (VarT (mkName "a"))
varsP = map VarP $ take w varSupply
varsE = map VarE $ take w varSupply