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