{-# LANGUAGE PatternSynonyms #-}
----------------------------------------------------------------------
-- |
-- Module      : Plugin.UnMtl
-- Copyright   : Don Stewart, Lennart Kolmodin 2007, Twan van Laarhoven 2008
-- License     : GPL-style (see LICENSE)
--
-- Unroll the MTL monads with your favorite bot!
--
----------------------------------------------------------------------

module Lambdabot.Plugin.Haskell.UnMtl (unmtlPlugin) where

import Lambdabot.Plugin
import qualified Lambdabot.Plugin as Lmb (Module)
import Lambdabot.Util.Parser (prettyPrintInLine)

import Control.Applicative
import Control.Monad
import Language.Haskell.Exts.Simple as Hs hiding (tuple, var)

unmtlPlugin :: Lmb.Module ()
unmtlPlugin :: Module ()
unmtlPlugin = Module ()
forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"unmtl")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"unroll mtl monads"
            , process :: String -> Cmd (ModuleT () LB) ()
process = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT () LB) ())
-> (String -> String) -> String -> Cmd (ModuleT () LB) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String)
-> (Type -> String) -> Either String Type -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String
"err: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) Type -> String
forall a. Pretty a => a -> String
prettyPrintInLine (Either String Type -> String)
-> (String -> Either String Type) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Type
mtlParser
            }
        ]
    }

-----------------------------------------------------------
-- 'PType' wrapper type

data PMonad a = PMonad
       { PMonad a -> a
pResult :: a                      -- The result (trsnsformed type)
       , PMonad a -> Maybe String
pError  :: Maybe String           -- An error message?
       , PMonad a -> Maybe (PType -> PType)
pFun    :: Maybe (PType -> PType) -- A type function
       }

type PType = PMonad Type

instance Functor PMonad where
    fmap :: (a -> b) -> PMonad a -> PMonad b
fmap = (a -> b) -> PMonad a -> PMonad b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative PMonad where
    pure :: a -> PMonad a
pure = a -> PMonad a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: PMonad (a -> b) -> PMonad a -> PMonad b
(<*>) = PMonad (a -> b) -> PMonad a -> PMonad b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

-- A monad instance so we get things like liftM and sequence for free
instance Monad PMonad where
    return :: a -> PMonad a
return a
t = a -> Maybe String -> Maybe (PType -> PType) -> PMonad a
forall a. a -> Maybe String -> Maybe (PType -> PType) -> PMonad a
PMonad a
t Maybe String
forall a. Maybe a
Nothing Maybe (PType -> PType)
forall a. Maybe a
Nothing
    PMonad a
m >>= :: PMonad a -> (a -> PMonad b) -> PMonad b
>>= a -> PMonad b
g  = let x :: PMonad b
x = a -> PMonad b
g (PMonad a -> a
forall a. PMonad a -> a
pResult PMonad a
m)
               in b -> Maybe String -> Maybe (PType -> PType) -> PMonad b
forall a. a -> Maybe String -> Maybe (PType -> PType) -> PMonad a
PMonad (PMonad b -> b
forall a. PMonad a -> a
pResult PMonad b
x) (PMonad a -> Maybe String
forall a. PMonad a -> Maybe String
pError PMonad a
m Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` PMonad b -> Maybe String
forall a. PMonad a -> Maybe String
pError PMonad b
x) Maybe (PType -> PType)
forall a. Maybe a
Nothing

-----------------------------------------------------------
-- Lifiting function types

type P = PType

lift0 :: P                            -> Type -> P
lift1 :: (P -> P)                     -> Type -> P
lift2 :: (P -> P -> P)                -> Type -> P
lift3 :: (P -> P -> P -> P)           -> Type -> P
lift4 :: (P -> P -> P -> P -> P)      -> Type -> P
lift5 :: (P -> P -> P -> P -> P -> P) -> Type -> P

lift0 :: PType -> Type -> PType
lift0 PType
f Type
_ = PType
f
lift1 :: (PType -> PType) -> Type -> PType
lift1 PType -> PType
f Type
n = Type -> (PType -> Type -> PType) -> PType
mkPfun Type
n (PType -> Type -> PType
lift0 (PType -> Type -> PType)
-> (PType -> PType) -> PType -> Type -> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PType -> PType
f)
lift2 :: (PType -> PType -> PType) -> Type -> PType
lift2 PType -> PType -> PType
f Type
n = Type -> (PType -> Type -> PType) -> PType
mkPfun Type
n ((PType -> PType) -> Type -> PType
lift1 ((PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> PType -> Type -> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PType -> PType -> PType
f)
lift3 :: (PType -> PType -> PType -> PType) -> Type -> PType
lift3 PType -> PType -> PType -> PType
f Type
n = Type -> (PType -> Type -> PType) -> PType
mkPfun Type
n ((PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> PType -> Type -> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PType -> PType -> PType -> PType
f)
lift4 :: (PType -> PType -> PType -> PType -> PType) -> Type -> PType
lift4 PType -> PType -> PType -> PType -> PType
f Type
n = Type -> (PType -> Type -> PType) -> PType
mkPfun Type
n ((PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType -> PType)
-> PType
-> Type
-> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PType -> PType -> PType -> PType -> PType
f)
lift5 :: (PType -> PType -> PType -> PType -> PType -> PType)
-> Type -> PType
lift5 PType -> PType -> PType -> PType -> PType -> PType
f Type
n = Type -> (PType -> Type -> PType) -> PType
mkPfun Type
n ((PType -> PType -> PType -> PType -> PType) -> Type -> PType
lift4 ((PType -> PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType -> PType -> PType)
-> PType
-> Type
-> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PType -> PType -> PType -> PType -> PType -> PType
f)

mkPfun :: Type -> (PType -> Type -> PType) -> PType
mkPfun :: Type -> (PType -> Type -> PType) -> PType
mkPfun Type
n PType -> Type -> PType
cont = Type -> Maybe String -> Maybe (PType -> PType) -> PType
forall a. a -> Maybe String -> Maybe (PType -> PType) -> PMonad a
PMonad Type
n (String -> Maybe String
forall a. a -> Maybe a
Just String
msg) ((PType -> PType) -> Maybe (PType -> PType)
forall a. a -> Maybe a
Just PType -> PType
fun)
  where fun :: PType -> PType
fun PType
p = PType -> Type -> PType
cont PType
p (Type -> Type -> Type
TyApp Type
n (PType -> Type
forall a. PMonad a -> a
pResult PType
p))
        msg :: String
msg = String
"`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Pretty a => a -> String
prettyPrintInLine Type
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not applied to enough arguments" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (PType -> PType) -> String -> String -> String
full PType -> PType
fun [Char
'A'..Char
'Z'] String
"/\\"
        full :: (PType -> PType) -> String -> String -> String
full PType -> PType
p (Char
x:String
xs) String
l = case PType -> PType
p (String -> PType
con [Char
x]) of
                   PMonad{pFun :: forall a. PMonad a -> Maybe (PType -> PType)
pFun    = Just PType -> PType
p'} -> (PType -> PType) -> String -> String -> String
full PType -> PType
p' String
xs String
l'
                   PMonad{pError :: forall a. PMonad a -> Maybe String
pError  = Just String
_}  -> String
"."
                   PMonad{pResult :: forall a. PMonad a -> a
pResult = Type
t }      -> String
", giving `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
init String
l' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Pretty a => a -> String
prettyPrintInLine Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
          where l' :: String
l' = String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
x] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
        full PType -> PType
_ [] String
_ = String -> String
forall a. HasCallStack => String -> a
error String
"UnMtl plugin error: ampty list"

-----------------------------------------------------------
-- Helpers for constructing types

infixr 5 -->
infixl 6 $$

-- Function type
(-->) :: PType -> PType -> PType
PType
a --> :: PType -> PType -> PType
--> PType
b = (Type -> Type -> Type) -> PType -> PType -> PType
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Type -> Type -> Type
cu PType
a PType
b

cu :: Type -> Type -> Type
cu :: Type -> Type -> Type
cu (TyTuple Boxed
_ [Type]
xs) Type
y = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TyFun Type
y [Type]
xs
cu Type
a Type
b = Type -> Type -> Type
TyFun Type
a Type
b

-- Type application:
--   If we have a type function, use that
--   Otherwise use TyApp, but check for stupid errors
($$) :: PType -> PType -> PType
$$ :: PType -> PType -> PType
($$) PMonad{ pFun :: forall a. PMonad a -> Maybe (PType -> PType)
pFun=Just PType -> PType
f } PType
x = PType -> PType
f PType
x
($$) PType
f PType
x = PMonad :: forall a. a -> Maybe String -> Maybe (PType -> PType) -> PMonad a
PMonad
         { pResult :: Type
pResult = Type -> Type -> Type
TyApp (PType -> Type
forall a. PMonad a -> a
pResult PType
f) (PType -> Type
forall a. PMonad a -> a
pResult PType
x)
         , pError :: Maybe String
pError  = PType -> Maybe String
forall a. PMonad a -> Maybe String
pError PType
f Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` -- ignore errors in x, the type constructor f might have a higher kind and ignore x
                      if Type -> Bool
isFunction (PType -> Type
forall a. PMonad a -> a
pResult PType
f) then Maybe String
forall a. Maybe a
Nothing else
                            String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Pretty a => a -> String
prettyPrintInLine (PType -> Type
forall a. PMonad a -> a
pResult PType
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a type function."
         , pFun :: Maybe (PType -> PType)
pFun    = Maybe (PType -> PType)
forall a. Maybe a
Nothing
         }
  where
    isFunction :: Type -> Bool
isFunction (TyFun Type
_ Type
_) = Bool
False
    isFunction (TyTuple Boxed
_ [Type]
_) = Bool
False
    isFunction Type
_             = Bool
True

con, var :: String -> PType
con :: String -> PType
con = Type -> PType
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PType) -> (String -> Type) -> String -> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Type
TyCon (QName -> Type) -> (String -> QName) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> QName
UnQual (Name -> QName) -> (String -> Name) -> String -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Ident
var :: String -> PType
var = Type -> PType
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PType) -> (String -> Type) -> String -> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
TyVar (Name -> Type) -> (String -> Name) -> String -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Ident

tuple :: [PType] -> PType
tuple :: [PType] -> PType
tuple = ([Type] -> Type) -> PMonad [Type] -> PType
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Boxed -> [Type] -> Type
TyTuple Boxed
Boxed ([Type] -> Type) -> ([Type] -> [Type]) -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Type]) -> [Type] -> [Type]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Type]
unpack) (PMonad [Type] -> PType)
-> ([PType] -> PMonad [Type]) -> [PType] -> PType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PType] -> PMonad [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    where
    unpack :: Type -> [Type]
unpack (TyTuple Boxed
_ [Type]
xs) = [Type]
xs
    unpack Type
x = [Type
x]

-- a bit of a hack
forall_ :: String -> (PType -> PType) -> PType
forall_ :: String -> (PType -> PType) -> PType
forall_ String
x PType -> PType
f = String -> PType
var (String
"forall " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") PType -> PType -> PType
$$ PType -> PType
f (String -> PType
var String
x)

-----------------------------------------------------------
-- Definitions from the MTL library

-- MTL types (plus MaybeT)
types :: [(String, Type -> PType)]
types :: [(String, Type -> PType)]
types =
    [ (String
"Cont",     (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
r       PType
a -> (PType
a PType -> PType -> PType
-->      PType
r) PType -> PType -> PType
-->      PType
r)
    , (String
"ContT",    (PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
r     PType
m PType
a -> (PType
a PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
r) PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
r)
    , (String
"ErrorT",   (PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
e     PType
m PType
a -> PType
m PType -> PType -> PType
$$ (String -> PType
con String
"Either" PType -> PType -> PType
$$ PType
e PType -> PType -> PType
$$ PType
a))
    , (String
"ExceptT",  (PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
e     PType
m PType
a -> PType
m PType -> PType -> PType
$$ (String -> PType
con String
"Either" PType -> PType -> PType
$$ PType
e PType -> PType -> PType
$$ PType
a))
    , (String
"Identity", (PType -> PType) -> Type -> PType
lift1 ((PType -> PType) -> Type -> PType)
-> (PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \        PType
a -> PType
a)
    , (String
"ListT",    (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \      PType
m PType
a -> PType
m PType -> PType -> PType
$$ (Type -> PType
forall (m :: * -> *) a. Monad m => a -> m a
return Type
list_tycon PType -> PType -> PType
$$ PType
a))
    , (String
"RWS",      (PType -> PType -> PType -> PType -> PType) -> Type -> PType
lift4 ((PType -> PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
r PType
w PType
s   PType
a -> PType
r PType -> PType -> PType
--> PType
s PType -> PType -> PType
-->      [PType] -> PType
tuple [PType
a, PType
s, PType
w])
    , (String
"RWST",     (PType -> PType -> PType -> PType -> PType -> PType)
-> Type -> PType
lift5 ((PType -> PType -> PType -> PType -> PType -> PType)
 -> Type -> PType)
-> (PType -> PType -> PType -> PType -> PType -> PType)
-> Type
-> PType
forall a b. (a -> b) -> a -> b
$ \PType
r PType
w PType
s PType
m PType
a -> PType
r PType -> PType -> PType
--> PType
s PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ [PType] -> PType
tuple [PType
a, PType
s, PType
w])
    , (String
"Reader",   (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
r       PType
a -> PType
r PType -> PType -> PType
-->            PType
a)
    , (String
"ReaderT",  (PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
r     PType
m PType
a -> PType
r PType -> PType -> PType
-->       PType
m PType -> PType -> PType
$$ PType
a)
    , (String
"Writer",   (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \  PType
w     PType
a ->                  [PType] -> PType
tuple [PType
a,    PType
w])
    , (String
"WriterT",  (PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \  PType
w   PType
m PType
a ->             PType
m PType -> PType -> PType
$$ [PType] -> PType
tuple [PType
a,    PType
w])
    , (String
"State",    (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \    PType
s   PType
a ->       PType
s PType -> PType -> PType
-->      [PType] -> PType
tuple [PType
a, PType
s   ])
    , (String
"StateT",   (PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \    PType
s PType
m PType
a ->       PType
s PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ [PType] -> PType
tuple [PType
a, PType
s   ])
    -- very common:
    , (String
"MaybeT",   (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \      PType
m PType
a -> PType
m PType -> PType -> PType
$$ (String -> PType
con String
"Maybe" PType -> PType -> PType
$$ PType
a))
    -- from the Haskell wiki
    , (String
"Rand",     (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
g       PType
a -> PType
g PType -> PType -> PType
-->      [PType] -> PType
tuple [PType
a, PType
g])
    , (String
"RandT",    (PType -> PType -> PType -> PType) -> Type -> PType
lift3 ((PType -> PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \PType
g     PType
m PType
a -> PType
g PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ [PType] -> PType
tuple [PType
a, PType
g])
    , (String
"NonDet",   (PType -> PType) -> Type -> PType
lift1 ((PType -> PType) -> Type -> PType)
-> (PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \        PType
a -> String -> (PType -> PType) -> PType
forall_ String
"b" ((PType -> PType) -> PType) -> (PType -> PType) -> PType
forall a b. (a -> b) -> a -> b
$ \PType
b -> (PType
a PType -> PType -> PType
--> PType
b PType -> PType -> PType
--> PType
b) PType -> PType -> PType
--> PType
b PType -> PType -> PType
--> PType
b)
    , (String
"NonDetT",  (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \      PType
m PType
a -> String -> (PType -> PType) -> PType
forall_ String
"b" ((PType -> PType) -> PType) -> (PType -> PType) -> PType
forall a b. (a -> b) -> a -> b
$ \PType
b -> (PType
a PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
b PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
b) PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
b PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
b)
    ]

--------------------------------------------------
-- Parsing of types

mtlParser :: String -> Either String Type
mtlParser :: String -> Either String Type
mtlParser String
input = do
    Module
hsMod <- ParseResult Module -> Either String Module
forall a. ParseResult a -> Either String a
liftE (ParseResult Module -> Either String Module)
-> ParseResult Module -> Either String Module
forall a b. (a -> b) -> a -> b
$ String -> ParseResult Module
parseModule (String
"type X = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
    [Decl]
decls <- case Module
hsMod of
        (Hs.Module Maybe ModuleHead
_ [ModulePragma]
_ [ImportDecl]
_ [Decl]
decls) -> [Decl] -> Either String [Decl]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl]
decls
        Module
_ -> String -> Either String [Decl]
forall a b. a -> Either a b
Left String
"Not a module?"
    Type
hsType <- case [Decl]
decls of
        (TypeDecl DeclHead
_ Type
hsType:[Decl]
_) -> Type -> Either String Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsType
        [Decl]
_ -> String -> Either String Type
forall a b. a -> Either a b
Left String
"No parse?"
    let result :: PType
result = Type -> PType
mtlParser' Type
hsType
    case PType -> Maybe String
forall a. PMonad a -> Maybe String
pError PType
result of
        Just String
e  -> String -> Either String Type
forall a b. a -> Either a b
Left String
e
        Maybe String
Nothing -> Type -> Either String Type
forall (m :: * -> *) a. Monad m => a -> m a
return (PType -> Type
forall a. PMonad a -> a
pResult PType
result)
  where
    liftE :: ParseResult a -> Either String a
liftE (ParseOk a
a) = a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    liftE (ParseFailed SrcLoc
_src String
str) = String -> Either String a
forall a b. a -> Either a b
Left String
str

mtlParser' :: Type -> PType
mtlParser' :: Type -> PType
mtlParser' t :: Type
t@(TyCon (UnQual (Ident String
v))) = case String -> [(String, Type -> PType)] -> Maybe (Type -> PType)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
v [(String, Type -> PType)]
types of
     Just Type -> PType
pt -> Type -> PType
pt Type
t
     Maybe (Type -> PType)
Nothing -> Type -> PType
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
mtlParser' (TyApp Type
a Type
b) = Type -> PType
mtlParser' Type
a PType -> PType -> PType
$$ Type -> PType
mtlParser' Type
b
mtlParser' (TyParen Type
t) = Type -> PType
mtlParser' Type
t
mtlParser' Type
t = Type -> PType
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t

-----------------------------------------------------------
-- Examples
--
-- ContT ByteString (StateT s IO) a
-- StateT s (ContT ByteString IO) a
-- ErrorT ByteString (WriterT String (State s)) a