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