{-# LANGUAGE PatternSynonyms #-}
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
}
]
}
data PMonad a = PMonad
{ PMonad a -> a
pResult :: a
, PMonad a -> Maybe String
pError :: Maybe String
, PMonad a -> Maybe (PType -> PType)
pFun :: Maybe (PType -> PType)
}
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
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
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"
infixr 5 -->
infixl 6 $$
(-->) :: 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
($$) :: 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`
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]
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)
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 ])
, ("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))
, ("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)
]
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