Commit 966ce80b authored by Luka Horvat's avatar Luka Horvat

Add a typechecker plugin to simulate fundeps

parent 545a93b2
......@@ -119,6 +119,7 @@ library
, Control.Effects.Yield
, Control.Effects.Resource
, Control.Effects.Newtype
, Control.Effects.Plugin
, Control.Monad.Runnable
, Tutorial.T1_Introduction
, Tutorial.T2_Details
......@@ -139,11 +140,14 @@ library
, text
, bytestring
, async
, ghc
, ghc-tcplugins-extra
ghc-options: -Wall -O2
test-suite tests
hs-source-dirs: test
main-is: Main.hs
other-modules: Fundep
default-language: Haskell2010
type: exitcode-stdio-1.0
build-depends: base >= 4.7 && < 5
......
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds, GADTs, RankNTypes, NoMonomorphismRestriction #-}
{-# LANGUAGE DataKinds, GADTs, RankNTypes, NoMonomorphismRestriction, PackageImports #-}
-- | Add non-determinism to your monad. Uses the 'ListT' transformer under the hood.
module Control.Effects.List
( module Control.Effects.List
......@@ -8,7 +8,7 @@ module Control.Effects.List
import Prelude hiding (splitAt, head)
import Import
import ListT hiding (take)
import "list-t" ListT hiding (take)
import Control.Effects
......
{-# LANGUAGE RecordWildCards, NamedFieldPuns, NoMonomorphismRestriction #-}
module Control.Effects.Plugin
( plugin )
where
-- external
import GHC.TcPluginM.Extra (lookupModule, lookupName)
-- GHC API
import FastString (fsLit)
import Module (mkModuleName)
import OccName (mkTcOcc)
import Plugins (Plugin (..), defaultPlugin)
import TcPluginM (TcPluginM, tcLookupClass)
import TcRnTypes
import TyCoRep (Type (..))
import Control.Monad
import Class
import Type
import Data.Maybe
import TcSMonad hiding (tcLookupClass)
import CoAxiom
plugin :: Plugin
plugin = defaultPlugin { tcPlugin = const (Just fundepPlugin) }
fundepPlugin :: TcPlugin
fundepPlugin = TcPlugin
{ tcPluginInit = do
md <- lookupModule (mkModuleName "Control.Effects") (fsLit "simple-effects")
monadEffectTcNm <- lookupName md (mkTcOcc "MonadEffect")
tcLookupClass monadEffectTcNm
, tcPluginSolve = solveFundep
, tcPluginStop = const (return ()) }
allMonadEffectConstraints :: Class -> [Ct] -> [(CtLoc, (Type, Type, Type))]
allMonadEffectConstraints cls cts =
[ (ctLoc cd, (effName, eff, mon))
| cd@CDictCan{cc_class = cls', cc_tyargs = [eff, mon]} <- cts
, cls == cls'
, let (effName, _) = splitAppTys eff ]
singleListToJust :: [a] -> Maybe a
singleListToJust [a] = Just a
singleListToJust _ = Nothing
findMatchingEffectIfSingular :: (Type, Type, Type) -> [(Type, Type, Type)] -> Maybe Type
findMatchingEffectIfSingular (effName, _, mon) ts = singleListToJust
[ eff'
| (effName', eff', mon') <- ts
, eqType effName effName'
, eqType mon mon' ]
solveFundep :: Class -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult
solveFundep effCls giv _ want = do
let wantedEffs = allMonadEffectConstraints effCls want
let givenEffs = snd <$> allMonadEffectConstraints effCls giv
eqs <- forM wantedEffs $ \(loc, e@(_, eff, _)) ->
case findMatchingEffectIfSingular e givenEffs of
Nothing -> return Nothing
Just eff' -> do
(ev, _) <- unsafeTcPluginTcM
(runTcSDeriveds (newWantedEq loc Nominal eff eff'))
return (Just (CNonCanonical ev))
return (TcPluginOk [] (catMaybes eqs))
{-# LANGUAGE PackageImports #-}
module Import (module X) where
import Control.Applicative as X
......@@ -10,7 +11,7 @@ import Control.Monad.Trans.Except as X hiding (liftListen, liftCallCC, liftPass)
import Control.Monad.Trans.Maybe as X hiding (liftListen, liftCallCC, liftCatch, liftPass)
import Control.Monad.Reader as X
import Data.Functor.Identity as X
import ListT as X
import "list-t" ListT as X
import Control.Monad.Trans.Control as X
import Control.Monad.Base as X
import GHC.Exts as X hiding (toList, fromList)
......
{-# LANGUAGE FlexibleContexts, UndecidableSuperClasses #-}
{-# OPTIONS_GHC -fplugin=Control.Effects.Plugin #-}
module Fundep where
import Control.Effects.State
import Control.Monad.IO.Class
testPlugin :: (MonadIO m, MonadEffect (State Int) m, Show Int) => m ()
testPlugin = do
s <- getState
liftIO $ print s
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment