module PartialTypeSigs
( sigs,
unionSigs,
) where
import qualified Data.Map as M
import Data.IORef
import System.IO.Unsafe
import Data.Maybe
import Language.Haskell.TH
import Data.Generics
import Language.Haskell.TH.Syntax
import Data.Monoid
import Control.Monad
import Data.Either
m :: IORef (M.Map String Int)
m = unsafePerformIO (newIORef M.empty)
sigs :: ExpQ -> DecsQ
sigs es = do
runIO $ writeIORef m M.empty
es <- es
let nts :: [(Exp, Type)]
nts = everything (<>)
( \x -> [ (e,t) | SigE e t <- maybeToList (cast x) ])
es
(ntsGood, ntsBad) = partitionEithers
$ map (\(e,t) -> case e of
VarE (Name (OccName n) _nameFlavour) -> Left (n,t)
LitE (StringL n) -> Left (n,t)
_ -> Right e)
nts
unless (null ntsBad) $ reportWarning
$ "Don't know how to interpret the left-hand-side of '::':" ++ show ntsBad
fmap concat $ mapM (\(n,t) -> unifiesWith1 n (return t)) ntsGood
unifiesWithPrefix = "partialTypeSig_"
unifiesWith1 :: String -> TypeQ -> DecsQ
unifiesWith1 e t = do
k <- runIO $ atomicModifyIORef m $ \k ->
let k' = M.insertWith (+) e 1 k
in (k', fromMaybe 1 $ M.lookup e k')
unifiesWith2 (unifiesWithPrefix++e++show k) (dyn e) t
unifiesWith2 :: String -> ExpQ -> TypeQ -> DecsQ
unifiesWith2 s e t = do
x <- newName "x"
fmap (:[]) $ funD (mkName s)
[clause [varP x]
(normalB [| ($(varE x) `asTypeOf` $e) `asTypeOf` (undefined :: $t) |])
[]]
unionSigs :: ExpQ -> ExpQ
unionSigs call = do
call <- call
VarE (Name (OccName k) _) : args <- return $ reverse (unappsErev call)
m <- runIO (readIORef m)
maybe noCxt (toExp k args) $ M.lookup k m
where
noCxt = do
reportWarning $ "PartialTypeSigs.unionSigs: missing a call to PartialTypeSigs.sigs directly above"
[| error "PartialTypeSigs.unionSigs no context given" |]
toExp :: String -> [Exp] -> Int -> ExpQ
toExp k args n =
foldr (\x y -> [| $x `asTypeOf` $y |])
[| error "PartialTypeSigs.unionSigs should be applied to an unreachable function clause" |]
[ foldl appE
[| $(dyn (unifiesWithPrefix++k++show i)) undefined |]
(map return args)
| i <- [1 .. n] ]
unappsErev :: Exp -> [Exp]
unappsErev (AppE x y) = y : unappsErev x
unappsErev (ConE x) | x == '() = []
unappsErev x = [x]