Separate substitution finder and definition finder
[darcs-mirror-polyfix.git] / ParseType.hs
index 824ffbd..624f0b8 100644 (file)
@@ -1,6 +1,8 @@
 {-# LANGUAGE FlexibleContexts, PatternSignatures, DeriveDataTypeable #-}
 module ParseType (
          parseType
+       , instType
+       , unquantify
        , TypVar(..)
        , Typ(..)
        ) where
@@ -17,8 +19,14 @@ import qualified Data.Map as M
 import Data.Generics
 import Data.Generics.Schemes
 import Data.Char
+import Data.Maybe
 
-newtype TypVar = TypVar Int deriving (Show, Eq, Typeable, Data)
+data TypVar = TypVar Int        -- alpha, beta etc.
+            | TypInst Int Bool  -- t1,t2 etc
+       deriving (Show, Eq, Typeable, Data)
+
+instType :: Bool -> Typ -> Typ
+instType rightSide typ = everywhere (mkT (\(TypVar i) -> TypInst i rightSide)) typ
 
 data Typ    = TVar    TypVar
             | Arrow   Typ     Typ
@@ -31,6 +39,10 @@ data Typ    = TVar    TypVar
             | TEither  Typ     Typ
             deriving (Show, Eq, Typeable, Data)
 
+unquantify (All     _ t) = unquantify t
+unquantify (AllStar _ t) = unquantify t
+unquantify t             = t
+
 parseType = either error id . parseType'
 
 -- | A simple type parser.
@@ -40,13 +52,18 @@ parseType = either error id . parseType'
 --  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)))))))
 --
 parseType' :: (MonadError String t) => String -> t Typ
-parseType' s = case parseModule ("x :: " ++ s) of
-  ParseOk hsModule -> do
+parseType' s =  let (vars,types) = case span (/='.') s of
+                       (v,'.':t) -> (words v, t)
+                        _         -> ([], s)
+               in case parseModule ("x :: " ++ types) of
+                 ParseOk hsModule -> do
                        hstype <- extractTheOneType hsModule
                        let varmap = createVarMap hstype
+                           specials = mapMaybe (flip M.lookup varmap) (map HsIdent vars)
                        typ <- runReaderT (simplifiyType hstype) varmap
-                       return (quantify typ)
-  ParseFailed l _  -> do throwError ("Parse error at (" ++ show (srcLine l) ++ ":" ++ show (srcColumn l) ++ ").")
+                       return (quantify specials typ)
+                 ParseFailed l _  -> do
+                       throwError ("Parse error at (" ++ show (srcLine l) ++ ":" ++ show (srcColumn l) ++ ").")
 
 extractTheOneType :: (MonadError String m) => HsModule -> m HsType
 extractTheOneType (HsModule _ _ _ _ [HsTypeSig _ _ (HsQualType [] t)]) = return t
@@ -78,5 +95,7 @@ simplifiyType (HsTyApp (HsTyCon (Special HsListCon)) t)
 simplifiyType t
                                = throwError ("Unsupported type " ++ show t)
 
-quantify :: Typ -> Typ
-quantify t = foldr All t (nub (listify (\(_::TypVar) -> True) t))
+quantify :: [TypVar] -> Typ -> Typ
+quantify special t = foldr all t (nub (listify (\(_::TypVar) -> True) t))
+  where all v | v `elem` special = All v
+              | otherwise        = AllStar v