module Types.Constrain (constrain) where import Control.Arrow (second) import Control.Monad (liftM,mapM,zipWithM,foldM) import Control.Monad.State (evalState) import Data.Char (isDigit) import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf) import qualified Data.Map as Map import qualified Data.Set as Set import Ast import Context import Guid import Types.Types import qualified Types.Substitutions as Subs beta = VarT `liftM` guid unionA = Map.unionWith (++) unionsA = Map.unionsWith (++) getAliases imports hints = concatMap aliasesFrom imports where aliasesFrom (name,method) = let values = concatMap (getValue name) hints in case method of As alias -> map (\(n,t) -> (alias ++ "." ++ n, t)) values Hiding vs -> filter (\(n,t) -> n `notElem` vs) values Importing vs -> filter (\(n,t) -> n `elem` vs) values getValue inModule (name,tipe) = case inModule `isPrefixOf` name of True -> [ (drop (length inModule + 1) name, tipe) ] False -> [] findAmbiguous hints assumptions continue = let potentialDups = map head . filter (\g -> length g > 1) . group . sort $ filter (elem '.') hints dups = filter (\k -> Map.member k assumptions) potentialDups in case dups of n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++ "' could refer to " ++ intercalate ", " (filter (isSuffixOf n) hints) _ -> continue mergeSchemes :: [Map.Map String Scheme] -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme) mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs return (Map.unions ass, Set.unions css, Map.unions sss) where kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss) split (k,vs) = let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs eq t u = C (Just $ msg ++ k) NoSpan (VarT t :=: VarT u) msg = "the definition of " in do xs <- mapM (\_ -> guid) vs return ( Map.fromList $ zip (map fst ps) (map (:[]) xs) , case xs of t:ts -> Set.fromList $ zipWith eq (t:ts) ts [] -> Set.empty , Map.fromList ps ) constrain typeHints (Module _ _ imports stmts) = do (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts aliasHints <- getAliases imports `liftM` typeHints (as', cs', schemes) <- mergeSchemes schemess let constraints = Set.unions (cs':css) as = unionsA (as':ass) allHints = Map.union schemes (Map.fromList aliasHints) insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as assumptions <- foldM insert as (Map.keys schemes) findAmbiguous (map fst aliasHints) assumptions $ do let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions escapees = Map.keys $ Map.difference assumptions allHints return $ case escapees of _ -> Right (Set.toList constraints ++ cs) --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees) type TVarMap = Map.Map String [X] type ConstraintSet = Set.Set (Context Constraint) ctx e span = C (Just $ show e) span gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type) gen (C _ span expr) = let ctx' = C (Just $ show expr) span in case expr of Var x -> do b <- guid return (Map.singleton x [b], Set.empty, VarT b) App e1 e2 -> do (a1,c1,t1) <- gen e1 (a2,c2,t2) <- gen e2 b <- beta return ( unionA a1 a2 , Set.unions [c1,c2 ,Set.singleton . ctx' $ t1 :=: (LambdaT t2 b)] , b ) Lambda x e -> do (a,c,t) <- gen e b <- beta v <- guid return ( Map.delete x a , Set.union c . Set.fromList . map (\x -> ctx' $ VarT x :=: b) $ Map.findWithDefault [v] x a , LambdaT b t ) Let defs e -> do (as,cs,t) <- gen e (ass, schemes) <- liftM unzip (mapM defScheme defs) let assumptions = unionsA (as:ass) getName d = case d of FnDef f _ _ -> f OpDef op _ _ _ -> op names = map getName defs genCs name s = do v <- guid let vs = Map.findWithDefault [v] name assumptions return $ map (\x -> ctx name span $ x :<<: s) vs cs' <- zipWithM genCs names schemes return ( foldr Map.delete assumptions names , Set.union (Set.fromList . concat $ cs') cs , t ) Case e cases -> do (as,cs,t) <- gen e (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases return ( unionsA $ as:ass , let cases' = map snd cases ctxs = zipWith epos cases' (tail cases') csts = zipWith (:=:) ts (tail ts) cs' = Set.fromList (zipWith ($) ctxs csts) in Set.unions $ cs' : cs : css , head ts) If e1 e2 e3 -> do (a1,c1,t1) <- gen e1 (a2,c2,t2) <- gen e2 (a3,c3,t3) <- gen e3 return ( unionsA [a1,a2,a3] , let c4 = Set.fromList [ ctx e1 span (t1 :=: bool) , ctx' (t2 :=: t3) ] in Set.unions [c1,c2,c3,c4] , t2 ) Data name es -> gen $ foldl' (\f x -> epos f x $ App f x) (ctx' $ Var name) es Binop op e1 e2 -> gen $ ctx' (App (ctx' $ App (ctx' $ Var op) e1) e2) Access e label -> do (as,cs,rtype) <- gen e t <- beta rtype' <- beta let fs = Map.singleton label [t] c = (ctx' (RecordT fs rtype' :=: rtype)) return (as, Set.insert c cs, t) Remove e x -> do (as,cs,rtype) <- gen e t <- beta rtype' <- beta let c = (ctx' (RecordT (Map.singleton x [t]) rtype' :=: rtype)) return (as, Set.insert c cs, rtype') Insert e x v -> do (eas,ecs,etype) <- gen e (vas,vcs,vtype) <- gen v return ( unionA eas vas , Set.union ecs vcs , RecordT (Map.singleton x [vtype]) etype ) Modify record fields -> do (ras,rcs,rtype) <- gen record (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields) oldTs <- mapM (\_ -> beta) fields rtype' <- beta let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype' c = Set.singleton (ctx' (rtype :=: rT oldTs)) return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs ) Record fields -> let insert label tipe = Map.insertWith (++) label [tipe] getScheme (f,args,e) = do (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e return (as, cs, insert label tipe) in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields return ( unionsA ass , Set.fromList (concat css) , RecordT (foldr ($) Map.empty fs) EmptyRecord ) Range e1@(C w1 s1 _) e2@(C w2 s2 _) -> do (a1,c1,t1) <- gen e1 (a2,c2,t2) <- gen e2 return ( unionsA [a1,a2] , Set.unions [ c1, c2, Set.fromList [ C w1 s1 (t1 :=: int) , C w1 s2 (t2 :=: int) ] ] , listOf int ) MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps let cs = Set.fromList (map (ctx' . (t :=:)) ts) return (unionsA ass, Set.unions (cs:css), t) where genPair (b@(C t s _),e) = do (a1,c1,t1) <- gen b (a2,c2,t2) <- gen e return ( unionsA [a1,a2] , Set.unions [ c1, c2 , Set.singleton (C t s (t1 :=: bool)) ] , t2 ) IntNum _ -> do t <- beta return (Map.empty, Set.singleton (ctx' $ t :<: number), t) FloatNum _ -> primitive float Chr _ -> primitive char Str _ -> primitive string Boolean _ -> primitive bool Markdown _ -> primitive element primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type) primitive t = return (Map.empty, Set.empty, t) caseGen :: Type -> (Pattern, CExpr) -> GuidCounter (TVarMap, ConstraintSet, Type) caseGen tipe (p, ce@(C _ span e)) = do (as ,cs ,t) <- gen ce (as',cs',_) <- patternGen (ctx p span) tipe as p return ( as', Set.union cs cs', t ) patternGen :: (Constraint -> Context Constraint) -> Type -- Type of e in `case e of ...` -> TVarMap -> Pattern -> GuidCounter (TVarMap, ConstraintSet, Type) patternGen ctxt tipe as pattern = case pattern of PAnything -> do b <- beta ; return ( as, Set.empty, b ) PVar v -> do b <- beta let cs = map (ctxt . (b :=:) . VarT) (Map.findWithDefault [] v as) return ( Map.delete v as, Set.fromList (ctxt (b :=: tipe) : cs), b ) PData name ps -> do constr <- guid output <- beta let step (as,cs,tipe) p = do b <- beta (as',cs',t) <- patternGen ctxt b as p return (as', Set.union cs cs', t ==> tipe) (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps) return ( Map.insert name [constr] as' , Set.insert (ctxt (VarT constr :=: t)) cs , output ) PRecord fs -> do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs b <- beta let t = RecordT (Map.fromList $ map (second (:[])) pairs) b mkCs (name,tipe) = map (ctxt . (tipe :=:) . VarT) (Map.findWithDefault [] name as) return ( foldr Map.delete as fs , Set.fromList (ctxt (t :=: tipe) : concatMap mkCs pairs) , t ) defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme) defScheme def = do (as,cs,hint) <- defGen def return ( as, snd hint ) defGen def = case def of FnDef f args e -> defGenHelp f args e OpDef op a1 a2 e -> defGenHelp op [a1,a2] e defGenHelp name args e = do argDict <- mapM (\a -> liftM ((,) a) guid) args (as,cs,t) <- gen e let as' = foldr Map.delete as args tipe = foldr (==>) t $ map (VarT . snd) argDict genCs (arg,x) = do v <- guid let as' = Map.findWithDefault [v] arg as return $ map (\y -> ctx arg NoSpan $ VarT x :=: VarT y) as' cs' <- concat `liftM` mapM genCs argDict scheme <- Subs.generalize (concat $ Map.elems as') $ Forall (map snd argDict) (cs' ++ Set.toList cs) tipe return ( as', Set.empty, (name, scheme) ) stmtGen :: Statement -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme) stmtGen stmt = case stmt of Definition def -> do (as,cs,hint) <- defGen def return ( as, cs, uncurry Map.singleton hint ) Datatype name xs tcs -> let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts) in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs)) ExportEvent js elm tipe -> do x <- guid return ( Map.singleton elm [x] , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe , Map.empty ) ImportEvent js e@(C txt span base) elm tipe -> do (as,cs,t) <- gen e return ( as , Set.insert (C txt span (signalOf t :=: tipe)) cs , Map.singleton elm (Forall [] [] tipe) ) TypeAnnotation name tipe -> do schm <- Subs.generalize [] =<< Subs.superize name tipe return (Map.empty, Set.empty, Map.singleton name schm) TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)