ParseType.hs

   1 {-# LANGUAGE FlexibleContexts, PatternSignatures, DeriveDataTypeable #-}
   2 module ParseType (
   3           parseType
   4         , instType
   5         , unquantify
   6         , TypVar(..)
   7         , Typ(..)
   8         ) where
   9
  10 import Language.Haskell.Parser (parseModule, ParseResult(..))
  11 import Language.Haskell.Syntax
  12
  13 import Control.Monad.Error
  14 import Control.Monad.Reader
  15 import Data.List
  16 import qualified Data.Map as M
  17
  18 import Data.Generics
  19 import Data.Generics.Schemes
  20 import Data.Char
  21 import Data.Maybe
  22
  23 data TypVar = TypVar Int        -- alpha, beta etc.
  24             | TypInst Int Bool  -- t1,t2 etc
  25         deriving (Show, Eq, Typeable, Data)
  26
  27 instType :: Bool -> Typ -> Typ
  28 instType rightSide typ = everywhere (mkT (\(TypVar i) -> TypInst i rightSide)) typ
  29
  30 data Typ    = TVar    TypVar
  31             | Arrow   Typ     Typ
  32             | All     TypVar  Typ       --wir geben Typen ohne Quantifier an
  33             | AllStar TypVar  Typ
  34             | List    Typ
  35             --Extensions
  36             | Int
  37             | TPair    Typ     Typ
  38             | TEither  Typ     Typ
  39             deriving (Show, Eq, Typeable, Data)
  40
  41 unquantify :: Typ -> Typ
  42 unquantify (All     _ t) = unquantify t
  43 unquantify (AllStar _ t) = unquantify t
  44 unquantify t             = t
  45
  46 parseType :: String -> Typ
  47 parseType = either error id . parseType'
  48
  49 -- | A simple type parser.
  50 --
  51 -- >  parseType "Int -> [Either a b] -> (a,b)" :: Either String Typ
  52 --
  53 --  Right (All (TypVar 3) (All (TypVar 4) (Arrow Int (Arrow (List (TEither (TVar (TypVar 3)) (TVar (TypVar 4)))) (TPair (TVar (TypVar 3)) (TVar (TypVar 4)))))))
  54 --
  55 parseType' :: (MonadError String t) => String -> t Typ
  56 parseType' s =  let (vars,types) = case span (/='.') s of
  57                         (v,'.':t) -> (words v, t)
  58                         _         -> ([], s)
  59                 in case parseModule ("x :: " ++ types) of
  60                   ParseOk hsModule -> do
  61                         hstype <- extractTheOneType hsModule
  62                         let varmap = createVarMap hstype
  63                             specials = mapMaybe (flip M.lookup varmap) (map HsIdent vars)
  64                         typ <- runReaderT (simplifiyType hstype) varmap
  65                         return (quantify specials typ)
  66                   ParseFailed l _  -> do
  67                         throwError ("Parse error at (" ++ show (srcLine l) ++ ":" ++ show (srcColumn l) ++ ").")
  68
  69 extractTheOneType :: (MonadError String m) => HsModule -> m HsType
  70 extractTheOneType (HsModule _ _ _ _ [HsTypeSig _ _ (HsQualType [] t)]) = return t
  71 extractTheOneType _  = throwError "parseModule gave unexpected result"
  72
  73 createVarMap :: HsType -> M.Map HsName TypVar
  74 createVarMap hstype = M.fromList $ zip
  75                         (nub (listify isVar hstype))
  76                         (map TypVar [1..])
  77   where isVar (HsIdent (x:_)) | isLower x  = True
  78         isVar _                            =  False
  79
  80
  81 simplifiyType :: (MonadReader (M.Map HsName TypVar) m, MonadError String m) =>
  82                  HsType -> m Typ
  83 simplifiyType (HsTyFun t1 t2)
  84                                 = liftM2 Arrow (simplifiyType t1) (simplifiyType t2)
  85 simplifiyType (HsTyTuple [t1,t2])
  86                                 = liftM2 TPair (simplifiyType t1) (simplifiyType t2)
  87 simplifiyType (HsTyTuple _)     = throwError "Tuple with more than one type not supported."
  88 simplifiyType (HsTyVar name)    = do Just tv <- asks (M.lookup name)
  89                                      return (TVar tv)
  90 simplifiyType (HsTyCon (UnQual (HsIdent "Int")))
  91                                 = return Int
  92 simplifiyType (HsTyApp (HsTyApp (HsTyCon (UnQual (HsIdent "Either"))) t1) t2)
  93                                 = liftM2 TEither (simplifiyType t1) (simplifiyType t2)
  94 simplifiyType (HsTyApp (HsTyCon (Special HsListCon)) t)
  95                                 = liftM  List (simplifiyType t)
  96 simplifiyType t
  97                                 = throwError ("Unsupported type " ++ show t)
  98
  99 quantify :: [TypVar] -> Typ -> Typ
 100 quantify special t = foldr allQuant t (nub (listify (\(_::TypVar) -> True) t))
 101   where allQuant v | v `elem` special = All v
 102                    | otherwise        = AllStar v