7a7fc3b0b5aad9d9cdc373e29eb8821300722da9
[darcs-mirror-polyfix.git] / 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