    {-# 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 = return
            [ (command "unmtl")
                { help = say "unroll mtl monads"
                , process = say . either ("err: " ++) prettyPrintInLine . mtlParser
                }
            ]
        }

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

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

    type PType = PMonad Type

    instance Functor PMonad where
        fmap :: forall a b. (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 :: forall a. a -> PMonad a
    pure = a -> PMonad a
    forall a. a -> PMonad a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
        <*> :: forall a b. 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 :: forall a. 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 >>= :: forall a b. 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 a. Maybe a -> Maybe a -> Maybe a
    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. HasCallStack => [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 a b. (a -> b -> b) -> b -> [a] -> b
    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
             { 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 a. Maybe a -> Maybe a -> Maybe a
    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 a. a -> PMonad a
    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 a. a -> PMonad a
    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)
    forall (m :: * -> *) a. Monad m => [m a] -> m [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 a. a -> PMonad a
    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
        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")
        decls <- case hsMod of
            (Hs.Module Maybe ModuleHead
    _ [ModulePragma]
    _ [ImportDecl]
    _ [Decl]
    decls) -> [Decl] -> Either String [Decl]
    forall a. a -> Either String a
    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?"
        hsType <- case decls of
            (TypeDecl DeclHead
    _ Type
    hsType:[Decl]
    _) -> Type -> Either String Type
    forall a. a -> Either String a
    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 = Type -> PType
    mtlParser' Type
    hsType
        case pError 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 a. a -> Either String a
    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 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 a. a -> PMonad a
    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 a. a -> PMonad a
    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