{-# LANGUAGE FlexibleContexts #-}


-- | Defines a function to parse a string into a list of declarations.
--   This module is based on the \'haskell-src\' package most probably included
--   with every Haskell compiler.

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




------- Main parser function --------------------------------------------------


-- | Parses a string to a list of declarations.
--   The string should contain a Haskell module.
--
--   This function is based on the Haskell98 parser of the \'haskell-src\'
--   package, i.e. the module \'Language.Haskell.Parser\'.
--   That parser supports only Haskell98 and a few extensions. Especially, it
--   does not support explicit quantification of type variables and thus no 
--   higher-rank functions.
--
--   The declarations returned by 'parse' include only @type@, @data@, 
--   @newtype@, @class@ and type signature declarations.
--   All other declarations and syntactical elements in the input are ignored.
--   
--   Furthermore, the following restrictions apply:
--
--   * Multi-parameter type classes are not allowed and therefore ignored. When
--     declaring a type class, the argument to the type class name must be a
--     single type variable.
--
--   * A type variable must not be applied to any type. That means, for
--     example, that the type @m a@ is not accepted.
--
--   * Contexts and @deriving@ parts in @data@ and @newtype@ declarations
--     are ignored.
--
--   * The module names are ignored. If any identifier was given qualified, the
--     module part of a qualified name is ignored.
--   
--   * Special Haskell constructors (unit, list function) are not allowed as
--     identifiers.
--
--   If a parser error occurs, as suitable error message is returned in the
--   second component of the returned tuple and the first component will be the
--   empty list.
--   However, if parsing was successful, but the parsed structures could not
--   be completely transformed into @Declaration@s, suitable transformation
--   error messages are returned in the second component while the first
--   components contains all declarations which could be transformed
--   successfully.

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'])
      




------- Filter declarations ---------------------------------------------------



-- | Filters all declarations of a Haskell module.

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



-- | Transforms a list of declarations by simplifying type signatures.

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
    -- Type signatures can be given for several names at once.
    -- This function transforms declarations such that every type signature is
    -- given for exactly one name only.
    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





------- Transform declarations ------------------------------------------------



-- | Transforms a declaration.

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)

  -- no other case con occur, see above function 'filterDeclarations'. 


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."



-- | Adds an error message based on the name of a declaration if the given
--   transformation caused an error.

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



-- | Transforms the components of a type declaration.

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))



-- | Transforms the components of a data declaration.

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))
       


-- | Transforms a data constructor declaration.

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
  


-- | Transforms the components of a data constructor declaration.

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)



-- | Transforms the components of a newtype declaration.

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.")



-- | Transforms the components of a Haskell class declaration.
--   Every declaration in the class body is ignored except of type signatures.

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))
    -- mapping 'isSig' is safe because after applying 'filter' no other
    -- declarations are left except of type signatures

  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
    -- Returns 'True' if a declaration is a type signature, otherwise 'False'.
    isSig :: HsDecl -> Bool
    isSig :: HsDecl -> Bool
isSig HsDecl
decl = case HsDecl
decl of
      HsTypeSig SrcLoc
_ [HsName]
_ HsQualType
_ -> Bool
True
      HsDecl
otherwise       -> Bool
False

    -- Extracts a signature from a declaration.
    -- Note that no other has to be given here because all declarations passed
    -- as argument to this function are definitely type signatures.
    -- See application of 'isSig' above.
    toSig :: S.Declaration -> S.Signature
    toSig :: Declaration -> Signature
toSig (S.TypeSig Signature
s) = Signature
s

    -- Checks if only the given type variable occurs in the second parameter.
    -- If not, an error is returned, otherwise, the list of type classes is
    -- extracted.
    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."



-- | Transforms the components of a Haskell type signature.
--   The context is added to the type expression.

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
    -- Merges the context and the type expression. The context is represented
    -- as type abstractions.
    merge :: 
        [(S.TypeClass, S.TypeVariable)] 
        -> S.TypeExpression 
        -> S.TypeExpression
    merge :: [(TypeClass, TypeVariable)] -> TypeExpression -> TypeExpression
merge [(TypeClass, TypeVariable)]
ctx TypeExpression
t =
      let -- All variables occurring in a context.
          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
          -- Returns all classes associated to a type variable 'v' in '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



-- | Transforms a Haskell context.
--   If the context contains not only variables, but also more complex types,
--   this function fails with an appropriate error message.

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."





------- Transform type expressions --------------------------------------------



-- | Transforms a Haskell type.
--   Note that a type variable is not allowed to be applied to some type.

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)




-- | Collects applied types and transforms them into a type expression.

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 



-- | Interprets a qualified name as a type constructor and applies it to a list
--   of type expressions.
--   The function type constructor is handled specially because it has to have
--   exactly two arguments.

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."



-- | Transforms a qualified name into a type constructor.
--   Special care is taken for primitive types which could be qualified by
--   \'Prelude\'.

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

-- missing case '(Special HsFunCon)' cannot occur,
-- see function 'mkTypeCOnstructorApp'

-- missing case '(Special HsCons)' cannot occur,
-- this is not valid Haskell syntax



-- | Transforms a name into a type constructor. This functions differentiates
--   between primitive types and other types.

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



-- | Transforms a Haskell name into a type variable.

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



-- | Transforms a qualified Haskell name into an identifier.
--   The module part of a qualified name is ignored.
--   This function fails with an appropriate error message when applied to a
--   special Haskell constructor, i.e. a unit, list, function or tuple
--   constructor.

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."



-- | Transforms a Haskell name into an identifier.
--   This function encapsulates 'hsNameToIdentifier' into the 'ErrorOr' monad.

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



-- | Transforms a Haskell name into an identifier.

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



-- | Transforms a Haskell name into a string.
--   Haskell symbols are surrounded by parentheses.

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
")"