module Type.Environment where import Control.Applicative ((<$>), (<*>)) import Control.Exception (try, SomeException) import Control.Monad import Control.Monad.Error (ErrorT, throwError, liftIO) import qualified Control.Monad.State as State import qualified Data.Traversable as Traverse import qualified Data.Map as Map import qualified Data.Set as Set import Data.List (isPrefixOf) import qualified Text.PrettyPrint as PP import qualified AST.Type as T import qualified AST.Variable as V import AST.Module (CanonicalAdt, AdtInfo) import Type.Type type TypeDict = Map.Map String Type type VarDict = Map.Map String Variable data Environment = Environment { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)) , types :: TypeDict , value :: TypeDict } initialEnvironment :: [CanonicalAdt] -> IO Environment initialEnvironment datatypes = do types <- makeTypes datatypes let env = Environment { constructor = Map.empty , value = Map.empty , types = types } return $ env { constructor = makeConstructors env datatypes } makeTypes :: [CanonicalAdt] -> IO TypeDict makeTypes datatypes = do adts <- mapM makeImported datatypes bs <- mapM makeBuiltin builtins return (Map.fromList (adts ++ bs)) where makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type) makeImported (var, _) = do tvar <- namedVar Constant var return (V.toString var, varN tvar) makeBuiltin :: (String, Int) -> IO (String, Type) makeBuiltin (name, _) = do name' <- namedVar Constant (V.builtin name) return (name, varN name') builtins :: [(String, Int)] builtins = concat [ map tuple [0..9] , kind 1 ["List"] , kind 0 ["Int","Float","Char","String","Bool"] ] where tuple n = ("_Tuple" ++ show n, n) kind n names = map (\name -> (name, n)) names makeConstructors :: Environment -> [CanonicalAdt] -> Map.Map String (IO (Int, [Variable], [Type], Type)) makeConstructors env datatypes = Map.fromList builtins where list t = (types env Map.! "List") <| t inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type) inst numTVars tipe = do vars <- forM [1..numTVars] $ \_ -> variable Flexible let (args, result) = tipe (map (varN) vars) return (length args, vars, args, result) tupleCtor n = let name = "_Tuple" ++ show n in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs)) builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ] builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t)) , ("::", inst 1 $ \ [t] -> ([t, list t], list t)) ] ++ map tupleCtor [0..9] ++ concatMap (ctorToType env) datatypes ctorToType :: Environment -> (V.Canonical, AdtInfo V.Canonical) -> [(String, IO (Int, [Variable], [Type], Type))] ctorToType env (name, (tvars, ctors)) = zip (map (V.toString . fst) ctors) (map inst ctors) where inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type) inst ctor = do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty return (length args, Map.elems dict, args, tipe) go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type) go (_, args) = do types <- mapM (instantiator env) args returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars)) return (types, returnType) get :: Environment -> (Environment -> Map.Map String a) -> String -> a get env subDict key = Map.findWithDefault (error msg) key (subDict env) where msg = "Could not find type constructor '" ++ key ++ "' while checking types." freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type) freshDataScheme env name = get env constructor name instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type) instantiateType env sourceType dict = do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict) case result :: Either SomeException (Type, VarDict) of Left someError -> throwError [ PP.text $ show someError ] Right (tipe, dict') -> return (Map.elems dict', tipe) instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type instantiator env sourceType = instantiatorHelp env Set.empty sourceType instantiatorHelp :: Environment -> Set.Set String -> T.CanonicalType -> State.StateT VarDict IO Type instantiatorHelp env aliasVars sourceType = let go = instantiatorHelp env aliasVars in case sourceType of T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2 T.Var x -> do dict <- State.get case Set.member x aliasVars of True -> return (PlaceHolder x) False -> case Map.lookup x dict of Just v -> return (varN v) Nothing -> do v <- State.liftIO $ namedVar flex (V.local x) State.put (Map.insert x v dict) return (varN v) where flex | "number" `isPrefixOf` x = Is Number | "comparable" `isPrefixOf` x = Is Comparable | "appendable" `isPrefixOf` x = Is Appendable | otherwise = Flexible T.Aliased name args aliasType -> do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args aliasedType' <- case aliasType of T.Filled tipe -> instantiatorHelp env Set.empty tipe T.Holey tipe -> instantiatorHelp env (Set.fromList (map fst args)) tipe case aliasedType' of PlaceHolder _ -> error "problem instantiating type" VarN maybeSubAlias v -> case maybeSubAlias of Nothing -> return (VarN (Just (name,args')) v) Just _subAlias -> return (TermN (Just (name,args')) (Var1 aliasedType')) TermN maybeSubAlias t -> case maybeSubAlias of Nothing -> return (TermN (Just (name, args')) t) Just _subAlias -> return (TermN (Just (name,args')) (Var1 aliasedType')) T.Type name -> case Map.lookup (V.toString name) (types env) of Just t -> return t Nothing -> error $ "Could not find type constructor '" ++ V.toString name ++ "' while checking types." T.App t ts -> do t' <- go t ts' <- mapM go ts return $ foldl (<|) t' ts' T.Record fields ext -> do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields) ext' <- case ext of Nothing -> return $ termN EmptyRecord1 Just x -> go x return $ termN (Record1 fields' ext')