{-# LANGUAGE FlexibleContexts #-}
module Language.Haskell.FreeTheorems.Parser.Haskell98 (parse) where
import Control.Monad (foldM, liftM, liftM2)
import Control.Monad.Error (throwError)
import Control.Monad.Writer (Writer, tell)
import Data.Generics (everywhere, mkT)
import Data.List (nub)
import Language.Haskell.Parser (parseModule, ParseResult(..))
import Language.Haskell.Syntax
import Text.PrettyPrint
import qualified Language.Haskell.FreeTheorems.Syntax as S
import Language.Haskell.FreeTheorems.Frontend.Error
parse :: String -> Parsed [S.Declaration]
parse :: String -> Parsed [Declaration]
parse String
text = case String -> ParseResult HsModule
parseModule String
text of
ParseOk HsModule
hsModule -> let decls :: [HsDecl]
decls = [HsDecl] -> [HsDecl]
transform forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsModule -> [HsDecl]
filterDeclarations forall a b. (a -> b) -> a -> b
$ HsModule
hsModule
in forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [Declaration] -> HsDecl -> Parsed [Declaration]
collectDeclarations [] [HsDecl]
decls
ParseFailed SrcLoc
l String
_ -> do forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String -> Doc
pp (String
"Parse error at (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SrcLoc -> Int
srcLine SrcLoc
l)
forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SrcLoc -> Int
srcColumn SrcLoc
l) forall a. [a] -> [a] -> [a]
++ String
").")]
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
collectDeclarations :: [S.Declaration] -> HsDecl -> Parsed [S.Declaration]
collectDeclarations :: [Declaration] -> HsDecl -> Parsed [Declaration]
collectDeclarations [Declaration]
ds HsDecl
d =
case HsDecl -> ErrorOr Declaration
mkDeclaration HsDecl
d of
Left Doc
e -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Doc
e] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds
Right Declaration
d' -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Declaration]
ds forall a. [a] -> [a] -> [a]
++ [Declaration
d'])
filterDeclarations :: HsModule -> [HsDecl]
filterDeclarations :: HsModule -> [HsDecl]
filterDeclarations (HsModule SrcLoc
_ Module
_ Maybe [HsExportSpec]
_ [HsImportDecl]
_ [HsDecl]
ds) = forall a. (a -> Bool) -> [a] -> [a]
filter HsDecl -> Bool
isAcceptedDeclaration [HsDecl]
ds
where
isAcceptedDeclaration :: HsDecl -> Bool
isAcceptedDeclaration HsDecl
decl = case HsDecl
decl of
HsTypeDecl SrcLoc
_ HsName
_ [HsName]
_ HsType
_ -> Bool
True
HsDataDecl SrcLoc
_ HsContext
_ HsName
_ [HsName]
_ [HsConDecl]
_ [HsQName]
_ -> Bool
True
HsNewTypeDecl SrcLoc
_ HsContext
_ HsName
_ [HsName]
_ HsConDecl
_ [HsQName]
_ -> Bool
True
HsClassDecl SrcLoc
_ HsContext
_ HsName
_ [HsName]
_ [HsDecl]
_ -> Bool
True
HsTypeSig SrcLoc
_ [HsName]
_ HsQualType
_ -> Bool
True
HsDecl
otherwise -> Bool
False
transform :: [HsDecl] -> [HsDecl]
transform :: [HsDecl] -> [HsDecl]
transform = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT [HsDecl] -> [HsDecl]
extendTypeSignature)
where
extendTypeSignature :: [HsDecl] -> [HsDecl]
extendTypeSignature :: [HsDecl] -> [HsDecl]
extendTypeSignature [HsDecl]
ds = case [HsDecl]
ds of
((HsTypeSig SrcLoc
l [HsName]
ns HsQualType
t):[HsDecl]
ds') -> (forall a b. (a -> b) -> [a] -> [b]
map (\HsName
n -> SrcLoc -> [HsName] -> HsQualType -> HsDecl
HsTypeSig SrcLoc
l [HsName
n] HsQualType
t) [HsName]
ns) forall a. [a] -> [a] -> [a]
++ [HsDecl]
ds'
[HsDecl]
otherwise -> [HsDecl]
ds
mkDeclaration :: HsDecl -> ErrorOr S.Declaration
mkDeclaration :: HsDecl -> ErrorOr Declaration
mkDeclaration HsDecl
decl = case HsDecl
decl of
HsTypeDecl SrcLoc
l HsName
n [HsName]
vs HsType
t -> SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
l HsName
n (HsName -> [HsName] -> HsType -> ErrorOr Declaration
mkType HsName
n [HsName]
vs HsType
t)
HsDataDecl SrcLoc
l HsContext
_ HsName
n [HsName]
vs [HsConDecl]
cs [HsQName]
_ -> SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
l HsName
n (HsName -> [HsName] -> [HsConDecl] -> ErrorOr Declaration
mkData HsName
n [HsName]
vs [HsConDecl]
cs)
HsNewTypeDecl SrcLoc
l HsContext
_ HsName
n [HsName]
vs HsConDecl
c [HsQName]
_ -> SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
l HsName
n (HsName -> [HsName] -> HsConDecl -> ErrorOr Declaration
mkNewtype HsName
n [HsName]
vs HsConDecl
c)
HsClassDecl SrcLoc
l HsContext
scs HsName
n [HsName
v] [HsDecl]
ds -> SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
l HsName
n (HsContext -> HsName -> HsName -> [HsDecl] -> ErrorOr Declaration
mkClass HsContext
scs HsName
n HsName
v [HsDecl]
ds)
HsTypeSig SrcLoc
l [HsName
n] (HsQualType HsContext
cx HsType
t) -> SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
l HsName
n (HsContext -> HsName -> HsType -> ErrorOr Declaration
mkSignature HsContext
cx HsName
n HsType
t)
HsClassDecl SrcLoc
l HsContext
_ HsName
n [] [HsDecl]
_ -> SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
l HsName
n (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Doc
missingVar)
HsClassDecl SrcLoc
l HsContext
_ HsName
n (HsName
_:HsName
_:[HsName]
_) [HsDecl]
_ -> SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
l HsName
n (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Doc
noMultiParam)
missingVar :: Doc
missingVar = String -> Doc
pp String
"Missing type variable to be constrained by type class."
noMultiParam :: Doc
noMultiParam = String -> Doc
pp String
"Multi-parameter type classes are not allowed."
addErr :: SrcLoc -> HsName -> ErrorOr S.Declaration-> ErrorOr S.Declaration
addErr :: SrcLoc -> HsName -> ErrorOr Declaration -> ErrorOr Declaration
addErr SrcLoc
loc HsName
name ErrorOr Declaration
e = case forall a. ErrorOr a -> Maybe Doc
getError ErrorOr Declaration
e of
Maybe Doc
Nothing -> ErrorOr Declaration
e
Just Doc
doc -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
String -> Doc
pp (String
"In the declaration of `" forall a. [a] -> [a] -> [a]
++ HsName -> String
hsNameToString HsName
name
forall a. [a] -> [a] -> [a]
++ String
"' at (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SrcLoc -> Int
srcLine SrcLoc
loc) forall a. [a] -> [a] -> [a]
++ String
":"
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SrcLoc -> Int
srcColumn SrcLoc
loc) forall a. [a] -> [a] -> [a]
++ String
"):")
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 Doc
doc
mkType :: HsName -> [HsName] -> HsType -> ErrorOr S.Declaration
mkType :: HsName -> [HsName] -> HsType -> ErrorOr Declaration
mkType HsName
name [HsName]
vars HsType
ty = do
Identifier
ident <- HsName -> ErrorOr Identifier
mkIdentifier HsName
name
[TypeVariable]
tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsName -> ErrorOr TypeVariable
mkTypeVariable [HsName]
vars
TypeExpression
t <- HsType -> ErrorOr TypeExpression
mkTypeExpression HsType
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeDeclaration -> Declaration
S.TypeDecl (Identifier -> [TypeVariable] -> TypeExpression -> TypeDeclaration
S.Type Identifier
ident [TypeVariable]
tvs TypeExpression
t))
mkData :: HsName -> [HsName] -> [HsConDecl] -> ErrorOr S.Declaration
mkData :: HsName -> [HsName] -> [HsConDecl] -> ErrorOr Declaration
mkData HsName
name [HsName]
vars [HsConDecl]
cons = do
Identifier
ident <- HsName -> ErrorOr Identifier
mkIdentifier HsName
name
[TypeVariable]
tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsName -> ErrorOr TypeVariable
mkTypeVariable [HsName]
vars
[DataConstructorDeclaration]
ds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsConDecl -> ErrorOr DataConstructorDeclaration
mkDataConstructorDeclaration [HsConDecl]
cons
forall (m :: * -> *) a. Monad m => a -> m a
return (DataDeclaration -> Declaration
S.DataDecl (Identifier
-> [TypeVariable]
-> [DataConstructorDeclaration]
-> DataDeclaration
S.Data Identifier
ident [TypeVariable]
tvs [DataConstructorDeclaration]
ds))
mkDataConstructorDeclaration ::
HsConDecl -> ErrorOr S.DataConstructorDeclaration
mkDataConstructorDeclaration :: HsConDecl -> ErrorOr DataConstructorDeclaration
mkDataConstructorDeclaration (HsConDecl SrcLoc
_ HsName
name [HsBangType]
btys) = HsName -> [HsBangType] -> ErrorOr DataConstructorDeclaration
mkDataConDecl HsName
name [HsBangType]
btys
mkDataConstructorDeclaration (HsRecDecl SrcLoc
_ HsName
name [([HsName], HsBangType)]
rbtys) =
let btys :: [HsBangType]
btys = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([HsName]
l,HsBangType
ty) -> forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsName]
l) HsBangType
ty) [([HsName], HsBangType)]
rbtys
in HsName -> [HsBangType] -> ErrorOr DataConstructorDeclaration
mkDataConDecl HsName
name [HsBangType]
btys
mkDataConDecl ::
HsName -> [HsBangType] -> ErrorOr S.DataConstructorDeclaration
mkDataConDecl :: HsName -> [HsBangType] -> ErrorOr DataConstructorDeclaration
mkDataConDecl HsName
name [HsBangType]
btys = do
Identifier
ident <- HsName -> ErrorOr Identifier
mkIdentifier HsName
name
[BangTypeExpression]
bts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsBangType -> Either Doc BangTypeExpression
mkBangTyEx [HsBangType]
btys
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier -> [BangTypeExpression] -> DataConstructorDeclaration
S.DataCon Identifier
ident [BangTypeExpression]
bts)
where
mkBangTyEx :: HsBangType -> Either Doc BangTypeExpression
mkBangTyEx (HsBangedTy HsType
ty) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TypeExpression -> BangTypeExpression
S.Banged (HsType -> ErrorOr TypeExpression
mkTypeExpression HsType
ty)
mkBangTyEx (HsUnBangedTy HsType
ty) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TypeExpression -> BangTypeExpression
S.Unbanged (HsType -> ErrorOr TypeExpression
mkTypeExpression HsType
ty)
mkNewtype :: HsName -> [HsName] -> HsConDecl -> ErrorOr S.Declaration
mkNewtype :: HsName -> [HsName] -> HsConDecl -> ErrorOr Declaration
mkNewtype HsName
name [HsName]
vars HsConDecl
con = do
Identifier
ident <- HsName -> ErrorOr Identifier
mkIdentifier HsName
name
[TypeVariable]
tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsName -> ErrorOr TypeVariable
mkTypeVariable [HsName]
vars
(Identifier
con,TypeExpression
t) <- HsConDecl -> Either Doc (Identifier, TypeExpression)
mkNewtypeConDecl HsConDecl
con
forall (m :: * -> *) a. Monad m => a -> m a
return (NewtypeDeclaration -> Declaration
S.NewtypeDecl (Identifier
-> [TypeVariable]
-> Identifier
-> TypeExpression
-> NewtypeDeclaration
S.Newtype Identifier
ident [TypeVariable]
tvs Identifier
con TypeExpression
t))
where
mkNewtypeConDecl :: HsConDecl -> Either Doc (Identifier, TypeExpression)
mkNewtypeConDecl (HsConDecl SrcLoc
_ HsName
c [HsBangType]
bts) = HsName -> [HsBangType] -> Either Doc (Identifier, TypeExpression)
mkNCD HsName
c [HsBangType]
bts
mkNewtypeConDecl (HsRecDecl SrcLoc
_ HsName
c [([HsName], HsBangType)]
bts) = HsName -> [HsBangType] -> Either Doc (Identifier, TypeExpression)
mkNCD HsName
c (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [([HsName], HsBangType)]
bts)
mkNCD :: HsName -> [HsBangType] -> Either Doc (Identifier, TypeExpression)
mkNCD HsName
c [HsBangType
bty] = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (HsName -> ErrorOr Identifier
mkIdentifier HsName
c) (HsBangType -> ErrorOr TypeExpression
bang HsBangType
bty)
mkNCD HsName
c [] = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Doc
errNewtype
mkNCD HsName
c (HsBangType
_:HsBangType
_:[HsBangType]
_) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Doc
errNewtype
errNewtype :: Doc
errNewtype =
String -> Doc
pp String
"A `newtype' declaration must have exactly one type expression."
bang :: HsBangType -> ErrorOr TypeExpression
bang (HsUnBangedTy HsType
ty) = HsType -> ErrorOr TypeExpression
mkTypeExpression HsType
ty
bang (HsBangedTy HsType
ty) =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Doc
pp String
"A `newtype' declaration must not use a strictness flag.")
mkClass :: HsContext -> HsName -> HsName -> [HsDecl] -> ErrorOr S.Declaration
mkClass :: HsContext -> HsName -> HsName -> [HsDecl] -> ErrorOr Declaration
mkClass HsContext
ctx HsName
name HsName
var [HsDecl]
decls = do
Identifier
ident <- HsName -> ErrorOr Identifier
mkIdentifier HsName
name
TypeVariable
tv <- HsName -> ErrorOr TypeVariable
mkTypeVariable HsName
var
[TypeClass]
superCs <- HsContext -> ErrorOr [(TypeClass, TypeVariable)]
mkContext HsContext
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeVariable
-> [(TypeClass, TypeVariable)] -> Either Doc [TypeClass]
check TypeVariable
tv
[Signature]
sigs <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Signature
toSig) (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsDecl -> ErrorOr Declaration
mkDeclaration (forall a. (a -> Bool) -> [a] -> [a]
filter HsDecl -> Bool
isSig [HsDecl]
decls))
forall (m :: * -> *) a. Monad m => a -> m a
return (ClassDeclaration -> Declaration
S.ClassDecl ([TypeClass]
-> Identifier -> TypeVariable -> [Signature] -> ClassDeclaration
S.Class [TypeClass]
superCs Identifier
ident TypeVariable
tv [Signature]
sigs))
where
isSig :: HsDecl -> Bool
isSig :: HsDecl -> Bool
isSig HsDecl
decl = case HsDecl
decl of
HsTypeSig SrcLoc
_ [HsName]
_ HsQualType
_ -> Bool
True
HsDecl
otherwise -> Bool
False
toSig :: S.Declaration -> S.Signature
toSig :: Declaration -> Signature
toSig (S.TypeSig Signature
s) = Signature
s
check ::
S.TypeVariable
-> [(S.TypeClass, S.TypeVariable)]
-> ErrorOr [S.TypeClass]
check :: TypeVariable
-> [(TypeClass, TypeVariable)] -> Either Doc [TypeClass]
check tv :: TypeVariable
tv@(S.TV (S.Ident String
v)) [(TypeClass, TypeVariable)]
ctx =
let ([TypeClass]
tcs, [TypeVariable]
tvs) = forall a b. [(a, b)] -> ([a], [b])
unzip [(TypeClass, TypeVariable)]
ctx
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= TypeVariable
tv) [TypeVariable]
tvs)
then forall (m :: * -> *) a. Monad m => a -> m a
return [TypeClass]
tcs
else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Doc
errClass String
v)
errClass :: String -> Doc
errClass String
v =
String -> Doc
pp forall a b. (a -> b) -> a -> b
$ String
"Only `" forall a. [a] -> [a] -> [a]
++ String
v forall a. [a] -> [a] -> [a]
++ String
"' can be constrained by the superclasses."
mkSignature :: HsContext -> HsName -> HsType -> ErrorOr S.Declaration
mkSignature :: HsContext -> HsName -> HsType -> ErrorOr Declaration
mkSignature HsContext
ctx HsName
var HsType
ty = do
[(TypeClass, TypeVariable)]
context <- HsContext -> ErrorOr [(TypeClass, TypeVariable)]
mkContext HsContext
ctx
Identifier
ident <- HsName -> ErrorOr Identifier
mkIdentifier HsName
var
TypeExpression
t <- HsType -> ErrorOr TypeExpression
mkTypeExpression HsType
ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Signature -> Declaration
S.TypeSig (Identifier -> TypeExpression -> Signature
S.Signature Identifier
ident ([(TypeClass, TypeVariable)] -> TypeExpression -> TypeExpression
merge [(TypeClass, TypeVariable)]
context TypeExpression
t))
where
merge ::
[(S.TypeClass, S.TypeVariable)]
-> S.TypeExpression
-> S.TypeExpression
merge :: [(TypeClass, TypeVariable)] -> TypeExpression -> TypeExpression
merge [(TypeClass, TypeVariable)]
ctx TypeExpression
t =
let
vars :: [TypeVariable]
vars = (forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip) [(TypeClass, TypeVariable)]
ctx
classes :: TypeVariable -> [TypeClass]
classes TypeVariable
v = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(==) TypeVariable
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(TypeClass, TypeVariable)]
ctx)
in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TypeVariable
v -> TypeVariable -> [TypeClass] -> TypeExpression -> TypeExpression
S.TypeAbs TypeVariable
v (TypeVariable -> [TypeClass]
classes TypeVariable
v)) TypeExpression
t [TypeVariable]
vars
mkContext :: HsContext -> ErrorOr [(S.TypeClass, S.TypeVariable)]
mkContext :: HsContext -> ErrorOr [(TypeClass, TypeVariable)]
mkContext = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsQName, [HsType]) -> Either Doc (TypeClass, TypeVariable)
trans
where
trans :: (HsQName, [HsType]) -> Either Doc (TypeClass, TypeVariable)
trans (HsQName
qname, [HsType]
tys) = case [HsType]
tys of
[HsTyVar HsName
var] -> do TypeClass
ident <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Identifier -> TypeClass
S.TC (HsQName -> ErrorOr Identifier
mkIdentifierQ HsQName
qname)
TypeVariable
tv <- HsName -> ErrorOr TypeVariable
mkTypeVariable HsName
var
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (TypeClass
ident, TypeVariable
tv)
[HsType]
otherwise -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Doc
errContext
errContext :: Doc
errContext =
String -> Doc
pp String
"Only a type variable may be constrained by a class in a context."
mkTypeExpression :: HsType -> ErrorOr S.TypeExpression
mkTypeExpression :: HsType -> ErrorOr TypeExpression
mkTypeExpression (HsTyVar HsName
var) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM TypeVariable -> TypeExpression
S.TypeVar (HsName -> ErrorOr TypeVariable
mkTypeVariable HsName
var)
mkTypeExpression (HsTyApp HsType
ty1 HsType
ty2) = HsType -> [HsType] -> ErrorOr TypeExpression
mkAppTyEx HsType
ty1 [HsType
ty2]
mkTypeExpression (HsTyCon HsQName
qname) = HsQName -> [TypeExpression] -> ErrorOr TypeExpression
mkTypeConstructorApp HsQName
qname []
mkTypeExpression (HsTyFun HsType
ty1 HsType
ty2) = do
TypeExpression
t1 <- HsType -> ErrorOr TypeExpression
mkTypeExpression HsType
ty1
TypeExpression
t2 <- HsType -> ErrorOr TypeExpression
mkTypeExpression HsType
ty2
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeExpression -> TypeExpression -> TypeExpression
S.TypeFun TypeExpression
t1 TypeExpression
t2)
mkTypeExpression (HsTyTuple [HsType]
tys) = do
[TypeExpression]
ts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsType -> ErrorOr TypeExpression
mkTypeExpression [HsType]
tys
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeConstructor -> [TypeExpression] -> TypeExpression
S.TypeCon (Int -> TypeConstructor
S.ConTuple (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeExpression]
ts)) [TypeExpression]
ts)
mkAppTyEx :: HsType -> [HsType] -> ErrorOr S.TypeExpression
mkAppTyEx :: HsType -> [HsType] -> ErrorOr TypeExpression
mkAppTyEx HsType
ty [HsType]
tys = case HsType
ty of
HsTyFun HsType
_ HsType
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> Doc
pp (String
"A function type must not be applied to a "
forall a. [a] -> [a] -> [a]
++ String
"type.")
HsTyTuple [HsType]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Doc
pp String
"A tuple type must not be applied to a type.")
HsTyVar HsName
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Doc
pp String
"A variable must not be applied to a type.")
HsTyApp HsType
t1 HsType
t2 -> HsType -> [HsType] -> ErrorOr TypeExpression
mkAppTyEx HsType
t1 (HsType
t2 forall a. a -> [a] -> [a]
: [HsType]
tys)
HsTyCon HsQName
qname -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsType -> ErrorOr TypeExpression
mkTypeExpression [HsType]
tys forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HsQName -> [TypeExpression] -> ErrorOr TypeExpression
mkTypeConstructorApp HsQName
qname
mkTypeConstructorApp ::
HsQName
-> [S.TypeExpression]
-> ErrorOr S.TypeExpression
mkTypeConstructorApp :: HsQName -> [TypeExpression] -> ErrorOr TypeExpression
mkTypeConstructorApp (Special HsSpecialCon
HsFunCon) [TypeExpression
t1,TypeExpression
t2] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeExpression -> TypeExpression -> TypeExpression
S.TypeFun TypeExpression
t1 TypeExpression
t2
mkTypeConstructorApp (Special HsSpecialCon
HsFunCon) [TypeExpression]
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Doc
errorTypeConstructorApp
mkTypeConstructorApp HsQName
qname [TypeExpression]
ts =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\TypeConstructor
con -> TypeConstructor -> [TypeExpression] -> TypeExpression
S.TypeCon TypeConstructor
con [TypeExpression]
ts) (HsQName -> ErrorOr TypeConstructor
mkTypeConstructor HsQName
qname)
errorTypeConstructorApp :: Doc
errorTypeConstructorApp =
String -> Doc
pp String
"The function type constructor `->' must be applied to exactly two types."
mkTypeConstructor :: HsQName -> ErrorOr S.TypeConstructor
mkTypeConstructor :: HsQName -> ErrorOr TypeConstructor
mkTypeConstructor (Qual (Module String
mod) HsName
hsName) =
if String
mod forall a. Eq a => a -> a -> Bool
== String
"Prelude"
then forall (m :: * -> *) a. Monad m => a -> m a
return (HsName -> TypeConstructor
asCon HsName
hsName)
else forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier -> TypeConstructor
S.Con forall a b. (a -> b) -> a -> b
$ HsName -> Identifier
hsNameToIdentifier HsName
hsName)
mkTypeConstructor (UnQual HsName
hsName) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HsName -> TypeConstructor
asCon HsName
hsName
mkTypeConstructor (Special HsSpecialCon
HsUnitCon) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeConstructor
S.ConUnit
mkTypeConstructor (Special HsSpecialCon
HsListCon) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TypeConstructor
S.ConList
mkTypeConstructor (Special (HsTupleCon Int
n)) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> TypeConstructor
S.ConTuple Int
n
asCon :: HsName -> S.TypeConstructor
asCon :: HsName -> TypeConstructor
asCon HsName
name = case HsName
name of
HsIdent String
"Int" -> TypeConstructor
S.ConInt
HsIdent String
"Integer" -> TypeConstructor
S.ConInteger
HsIdent String
"Float" -> TypeConstructor
S.ConFloat
HsIdent String
"Double" -> TypeConstructor
S.ConDouble
HsIdent String
"Char" -> TypeConstructor
S.ConChar
HsName
otherwise -> Identifier -> TypeConstructor
S.Con forall a b. (a -> b) -> a -> b
$ HsName -> Identifier
hsNameToIdentifier HsName
name
mkTypeVariable :: HsName -> ErrorOr S.TypeVariable
mkTypeVariable :: HsName -> ErrorOr TypeVariable
mkTypeVariable = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> TypeVariable
S.TV forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName -> Identifier
hsNameToIdentifier
mkIdentifierQ :: HsQName -> ErrorOr S.Identifier
mkIdentifierQ :: HsQName -> ErrorOr Identifier
mkIdentifierQ (UnQual HsName
hsName) = forall (m :: * -> *) a. Monad m => a -> m a
return (HsName -> Identifier
hsNameToIdentifier HsName
hsName)
mkIdentifierQ (Qual (Module String
_) HsName
hsName) = forall (m :: * -> *) a. Monad m => a -> m a
return (HsName -> Identifier
hsNameToIdentifier HsName
hsName)
mkIdentifierQ (Special HsSpecialCon
HsUnitCon) = forall {m :: * -> *} {a}. MonadError Doc m => String -> m a
throwErrorIdentifierQ String
"`()'"
mkIdentifierQ (Special HsSpecialCon
HsListCon) = forall {m :: * -> *} {a}. MonadError Doc m => String -> m a
throwErrorIdentifierQ String
"`[]'"
mkIdentifierQ (Special HsSpecialCon
HsFunCon) = forall {m :: * -> *} {a}. MonadError Doc m => String -> m a
throwErrorIdentifierQ String
"`->'"
mkIdentifierQ (Special HsSpecialCon
HsCons) = forall {m :: * -> *} {a}. MonadError Doc m => String -> m a
throwErrorIdentifierQ String
"`:'"
mkIdentifierQ (Special (HsTupleCon Int
_)) = forall {m :: * -> *} {a}. MonadError Doc m => String -> m a
throwErrorIdentifierQ String
"for tuples"
throwErrorIdentifierQ :: String -> m a
throwErrorIdentifierQ String
s = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> Doc
pp forall a b. (a -> b) -> a -> b
$
String
"The constructor " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" must not be used as an identifier."
mkIdentifier :: HsName -> ErrorOr S.Identifier
mkIdentifier :: HsName -> ErrorOr Identifier
mkIdentifier = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName -> Identifier
hsNameToIdentifier
hsNameToIdentifier :: HsName -> S.Identifier
hsNameToIdentifier :: HsName -> Identifier
hsNameToIdentifier = String -> Identifier
S.Ident forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsName -> String
hsNameToString
hsNameToString :: HsName -> String
hsNameToString :: HsName -> String
hsNameToString (HsIdent String
s) = String
s
hsNameToString (HsSymbol String
s) = String
"(" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
")"