{-# LANGUAGE TemplateHaskell, CPP #-}
module Data.Express.Express.Derive
( deriveExpress
, deriveExpressCascading
, deriveExpressIfNeeded
)
where
import Data.Express.Core
import Data.Express.Express
import Control.Monad
import Data.Char
import Data.List
import Data.Express.Utils.TH
import Data.Express.Utils.List
import Data.Express.Utils.String
deriveExpress :: Name -> DecsQ
deriveExpress = deriveWhenNeededOrWarn ''Express reallyDeriveExpress
deriveExpressIfNeeded :: Name -> DecsQ
deriveExpressIfNeeded = deriveWhenNeeded ''Express reallyDeriveExpress
deriveExpressCascading :: Name -> DecsQ
deriveExpressCascading = deriveWhenNeeded ''Express reallyDeriveExpressCascading
reallyDeriveExpress :: Name -> DecsQ
reallyDeriveExpress t = do
isEq <- t `isInstanceOf` ''Eq
isOrd <- t `isInstanceOf` ''Ord
(nt,vs) <- normalizeType t
#if __GLASGOW_HASKELL__ >= 710
cxt <- sequence [ [t| $(conT c) $(return v) |]
#else
cxt <- sequence [ classP c [return v]
#endif
| c <- ''Express:([''Eq | isEq] ++ [''Ord | isOrd])
, v <- vs]
cs <- typeConstructorsArgNames t
asName <- newName "x"
let withTheReturnTypeOfs = deriveWithTheReturnTypeOfs $ [length ns | (_,ns) <- cs]
let generalizableExpr = mergeIFns $ foldr1 mergeI
[ do let retTypeOf = mkName $ "-" ++ replicate (length ns) '>' ++ ":"
let exprs = [[| expr $(varE n) |] | n <- ns]
let conex = [| $(varE retTypeOf) $(conE c) $(varE asName) |]
let root = [| value $(stringE $ showJustName c) $(conex) |]
let rhs = foldl (\e1 e2 -> [| $e1 :$ $e2 |]) root exprs
[d| instance Express $(return nt) where
expr $(asP asName $ conP c (map varP ns)) = $rhs |]
| (c,ns) <- cs
]
withTheReturnTypeOfs |++| (cxt |=>| generalizableExpr)
reallyDeriveExpressCascading :: Name -> DecsQ
reallyDeriveExpressCascading = reallyDeriveCascading ''Express reallyDeriveExpress
deriveWithTheReturnTypeOfs :: [Int] -> DecsQ
deriveWithTheReturnTypeOfs =
fmap concat . mapM deriveWithTheReturnTypeOf . nubSort
deriveWithTheReturnTypeOf :: Int -> DecsQ
deriveWithTheReturnTypeOf n = do
mf <- lookupValueName name
case mf of
Nothing -> reallyDeriveWithTheReturnTypeOf n
Just _ -> return []
where
name = "-" ++ replicate n '>' ++ ":"
reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ
reallyDeriveWithTheReturnTypeOf n = do
td <- sigD name theT
vd <- [d| $(varP name) = const |]
return $ td:vd
where
theT = [t| $(theFunT) -> $(last vars) -> $(theFunT) |]
theFunT = foldr1 funT vars
funT t1 t2 = [t| $(t1) -> $(t2) |]
vars = map (varT . mkName) . take (n+1) . primeCycle $ map (:"") ['a'..'z']
name = mkName $ "-" ++ replicate n '>' ++ ":"