{-# 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 "unmtl")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 ("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 t :: 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
    m :: PMonad a
m >>= :: PMonad a -> (a -> PMonad b) -> PMonad b
>>= g :: 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 f :: PType
f _ = PType
f
lift1 :: (PType -> PType) -> Type -> PType
lift1 f :: PType -> PType
f n :: 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 f :: PType -> PType -> PType
f n :: 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 f :: PType -> PType -> PType -> PType
f n :: 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 f :: PType -> PType -> PType -> PType -> PType
f n :: 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 f :: PType -> PType -> PType -> PType -> PType -> PType
f n :: 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 n :: Type
n cont :: 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 p :: 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
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Pretty a => a -> String
prettyPrintInLine Type
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' is not applied to enough arguments" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (PType -> PType) -> String -> String -> String
full PType -> PType
fun ['A'..'Z'] "/\\"
        full :: (PType -> PType) -> String -> String -> String
full p :: PType -> PType
p (x :: Char
x:xs :: String
xs) l :: String
l = case PType -> PType
p (String -> PType
con [Char
x]) of
                   PMonad{pFun :: forall a. PMonad a -> Maybe (PType -> PType)
pFun    = Just p' :: 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 _}  -> "."
                   PMonad{pResult :: forall a. PMonad a -> a
pResult = Type
t }      -> ", 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
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Pretty a => a -> String
prettyPrintInLine Type
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'"
          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 _ [] _ = String -> String
forall a. HasCallStack => String -> a
error "UnMtl plugin error: ampty list"

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

infixr 5 -->
infixl 6 $$

-- Function type
(-->) :: PType -> PType -> PType
a :: PType
a --> :: PType -> PType -> PType
--> b :: 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 _ xs :: [Type]
xs) y :: 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 a :: Type
a b :: 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 f :: PType -> PType
f } x :: PType
x = PType -> PType
f PType
x
($$) f :: PType
f x :: 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
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]
++ "' is not a type function."
         , pFun :: Maybe (PType -> PType)
pFun    = Maybe (PType -> PType)
forall a. Maybe a
Nothing
         }
  where
    isFunction :: Type -> Bool
isFunction (TyFun _ _) = Bool
False
    isFunction (TyTuple _ _) = Bool
False
    isFunction _             = 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 _ xs :: [Type]
xs) = [Type]
xs
    unpack x :: Type
x = [Type
x]

-- a bit of a hack
forall_ :: String -> (PType -> PType) -> PType
forall_ :: String -> (PType -> PType) -> PType
forall_ x :: String
x f :: PType -> PType
f = String -> PType
var ("forall " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".") 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 =
    [ ("Cont",     (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \r :: PType
r       a :: PType
a -> (PType
a PType -> PType -> PType
-->      PType
r) PType -> PType -> PType
-->      PType
r)
    , ("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
$ \r :: PType
r     m :: PType
m a :: PType
a -> (PType
a PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
r) PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ PType
r)
    , ("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
$ \e :: PType
e     m :: PType
m a :: PType
a -> PType
m PType -> PType -> PType
$$ (String -> PType
con "Either" PType -> PType -> PType
$$ PType
e PType -> PType -> PType
$$ PType
a))
    , ("Identity", (PType -> PType) -> Type -> PType
lift1 ((PType -> PType) -> Type -> PType)
-> (PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \        a :: PType
a -> PType
a)
    , ("ListT",    (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \      m :: PType
m a :: 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))
    , ("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
$ \r :: PType
r w :: PType
w s :: PType
s   a :: PType
a -> PType
r PType -> PType -> PType
--> PType
s PType -> PType -> PType
-->      [PType] -> PType
tuple [PType
a, PType
s, PType
w])
    , ("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
$ \r :: PType
r w :: PType
w s :: PType
s m :: PType
m a :: 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])
    , ("Reader",   (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \r :: PType
r       a :: PType
a -> PType
r PType -> PType -> PType
-->            PType
a)
    , ("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
$ \r :: PType
r     m :: PType
m a :: PType
a -> PType
r PType -> PType -> PType
-->       PType
m PType -> PType -> PType
$$ PType
a)
    , ("Writer",   (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \  w :: PType
w     a :: PType
a ->                  [PType] -> PType
tuple [PType
a,    PType
w])
    , ("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
$ \  w :: PType
w   m :: PType
m a :: PType
a ->             PType
m PType -> PType -> PType
$$ [PType] -> PType
tuple [PType
a,    PType
w])
    , ("State",    (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \    s :: PType
s   a :: PType
a ->       PType
s PType -> PType -> PType
-->      [PType] -> PType
tuple [PType
a, PType
s   ])
    , ("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
$ \    s :: PType
s m :: PType
m a :: PType
a ->       PType
s PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ [PType] -> PType
tuple [PType
a, PType
s   ])
    -- very common:
    , ("MaybeT",   (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \      m :: PType
m a :: PType
a -> PType
m PType -> PType -> PType
$$ (String -> PType
con "Maybe" PType -> PType -> PType
$$ PType
a))
    -- from the Haskell wiki
    , ("Rand",     (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \g :: PType
g       a :: PType
a -> PType
g PType -> PType -> PType
-->      [PType] -> PType
tuple [PType
a, PType
g])
    , ("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
$ \g :: PType
g     m :: PType
m a :: PType
a -> PType
g PType -> PType -> PType
--> PType
m PType -> PType -> PType
$$ [PType] -> PType
tuple [PType
a, PType
g])
    , ("NonDet",   (PType -> PType) -> Type -> PType
lift1 ((PType -> PType) -> Type -> PType)
-> (PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \        a :: PType
a -> String -> (PType -> PType) -> PType
forall_ "b" ((PType -> PType) -> PType) -> (PType -> PType) -> PType
forall a b. (a -> b) -> a -> b
$ \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)
    , ("NonDetT",  (PType -> PType -> PType) -> Type -> PType
lift2 ((PType -> PType -> PType) -> Type -> PType)
-> (PType -> PType -> PType) -> Type -> PType
forall a b. (a -> b) -> a -> b
$ \      m :: PType
m a :: PType
a -> String -> (PType -> PType) -> PType
forall_ "b" ((PType -> PType) -> PType) -> (PType -> PType) -> PType
forall a b. (a -> b) -> a -> b
$ \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 input :: 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 ("type X = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
input String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n")
    [Decl]
decls <- case Module
hsMod of
        (Hs.Module _ _ _ decls :: [Decl]
decls) -> [Decl] -> Either String [Decl]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl]
decls
        _ -> String -> Either String [Decl]
forall a b. a -> Either a b
Left "Not a module?"
    Type
hsType <- case [Decl]
decls of
        (TypeDecl _ hsType :: Type
hsType:_) -> Type -> Either String Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
hsType
        _ -> String -> Either String Type
forall a b. a -> Either a b
Left "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 e :: String
e  -> String -> Either String Type
forall a b. a -> Either a b
Left String
e
        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) = a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    liftE (ParseFailed _src :: SrcLoc
_src str :: 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 v :: 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 pt :: Type -> PType
pt -> Type -> PType
pt Type
t
     Nothing -> Type -> PType
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
mtlParser' (TyApp a :: Type
a b :: Type
b) = Type -> PType
mtlParser' Type
a PType -> PType -> PType
$$ Type -> PType
mtlParser' Type
b
mtlParser' (TyParen t :: Type
t) = Type -> PType
mtlParser' Type
t
mtlParser' t :: 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