module Types.Constrain (constrain) where
import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Arrow (second)
import Control.Monad (liftM,mapM,zipWithM,foldM)
import Control.Monad.State (evalState)
import Ast
import Guid
import Types.Types
import Types.Substitutions
prints xs v = v
beta = VarT `liftM` guid
unionA = Map.unionWith (++)
unionsA = Map.unionsWith (++)
getAliases imports hints = hints ++ concatMap aliasesFrom imports'
where imports' = map head . group $ sort imports
aliasesFrom (name,method) =
case method of
As alias -> concatMap (findAlias name alias) hints
Hiding [] -> concatMap (findAlias name "") hints
_ -> []
findAlias mName' mAlias (name,tipe) =
let mName = mName' ++ "." in
case mName `isPrefixOf` name of
True -> [ (mAlias ++ drop (length mName) name, tipe) ]
False -> []
findAmbiguous hints hints' assumptions continue =
let potentialDups = map head . filter (\g -> length g > 1) . group $ sort 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
constrain typeHints (Module _ _ imports stmts) = do
(ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
hints <- typeHints
let extraImports = ("Time", Hiding ["read"]) : map (\n -> (n, Hiding []))
["List","Signal","Text","Graphics","Color"]
insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
aliasHints = getAliases (imports ++ extraImports) hints
allHints = Map.fromList (aliasHints ++ concat schemess)
assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do
let f k s vs = map (\v -> Context k $ v :<<: s) vs
cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
escapees = Map.keys $ Map.difference assumptions allHints
return . Right . (,) escapees $ cs ++ Set.toList (Set.unions css)
gen :: Expr -> GuidCounter (Map.Map String [X],
Set.Set (Context String Constraint),
Type)
gen (Var x) =
do b <- guid
return (Map.singleton x [b], Set.empty, VarT b)
gen e@(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 e $ t1 :=: (LambdaT t2 b)]
, b )
gen (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 e $ VarT x :=: b) $
Map.findWithDefault [v] x a
, LambdaT b t )
gen (Let defs e) =
do (as,cs,t) <- gen e
(ass, schemes) <- liftM unzip (mapM defScheme defs)
let assumptions = unionsA (as:ass)
getName (FnDef f _ _) = f
getName (OpDef op _ _ _) = op
names = map getName defs
genCs name s = do
v <- guid
let vs = Map.findWithDefault [v] name assumptions
return $ map (\x -> ctx (Var name) $ x :<<: s) vs
cs' <- zipWithM genCs names schemes
return ( foldr Map.delete assumptions names
, Set.union (Set.fromList . concat $ cs') cs
, t )
gen ce@(Case e cases) =
do (as,cs,t) <- gen e
(ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
return ( unionsA $ as:ass
, let combine t1 t2 = ctx ce (t1 :=: t2) in
Set.unions $ Set.fromList (zipWith combine ts $ tail ts) : cs : css
, head ts)
gen e@(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]
, Set.unions [c1,c2,c3, Set.fromList [ ctx e1 (t1 :=: bool), ctx e (t2 :=: t3) ] ]
, t2 )
gen (Data name es) = gen $ foldl' App (Var name) es
gen (Binop op e1 e2) = gen (Var op `App` e1 `App` e2)
gen (Access (Var a) b) = gen . Var $ a ++ "." ++ b
gen (Access (Access (Var a) b) c) = gen . Var $ intercalate "." [a, b, c]
gen (Access (Access (Access (Var a) b) c) d) = gen . Var $ intercalate "." [a, b, c, d]
gen (Range e1 e2) =
do (a1,c1,t1) <- gen e1
(a2,c2,t2) <- gen e2
return ( unionsA [a1,a2]
, Set.unions [ c1, c2, Set.fromList [ ctx e1 (t1 :=: int)
, ctx e2 (t2 :=: int) ] ]
, listOf int )
gen e@(Guard ps) = do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
let cs = Set.fromList (map (ctx e . (t :=:)) ts)
return (unionsA ass, Set.unions (cs:css), t)
where genPair (b,e) = do
(a1,c1,t1) <- gen b
(a2,c2,t2) <- gen e
return ( unionsA [a1,a2]
, Set.unions [ c1, c2, Set.singleton (ctx b (t1 :=: bool)) ]
, t2 )
gen other =
case other of
IntNum _ -> do t <- beta
return (Map.empty, Set.singleton (ctx other $ t :<: number), t)
FloatNum _ -> primitive float
Chr _ -> primitive char
Str _ -> primitive string
Boolean _ -> primitive bool
Markdown _ -> primitive element
primitive t = return (Map.empty, Set.empty, t)
caseGen tipe (p,e) = do
(as ,cs , t ) <- gen e
(as',cs',[t']) <- patternGen (as,cs,[]) p
let cs'' = Set.union cs' . Set.singleton . ctx p $ t' :=: tipe
return ( as', cs'', t )
patternGen (as,cs,ts) PAnything = ((,,) as cs . (\t -> ts++[t])) `liftM` beta
patternGen (as,cs,ts) (PVar v) = do
b <- beta
let cs' = map (\x -> ctx (Var v) $ VarT x :=: b) $ Map.findWithDefault [] v as
return ( Map.delete v as, Set.union cs $ Set.fromList cs', ts ++ [b] )
patternGen (as,cs,ts) p@(PData name ps) = do
constr <- guid
output <- beta
(as',cs',ts') <- foldM patternGen (as,cs,[]) ps
let t = foldr (==>) output ts'
let getC | isTupleString name = do
vs <- mapM (\_ -> beta) ps
return . Set.singleton . ctx p $ output :=: ADT name vs
| otherwise = return Set.empty
cs'' <- getC
return ( unionA as' (Map.singleton name [constr])
, Set.unions [cs',cs'', Set.singleton . ctx p $ VarT constr :=: t]
, ts ++ [output] )
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 -> defGen' f args e
OpDef op a1 a2 e -> defGen' op [a1,a2] e
where defGen' 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 -> Context arg $ VarT x :=: VarT y) as'
cs' <- concat `liftM` mapM genCs argDict
scheme <- generalize (concat $ Map.elems as') $
Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
return ( as', Set.empty, (name, scheme) )
stmtGen (Definition def) = do (as,cs,hint) <- defGen def
return ( as, cs, [hint] )
stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'
return (Map.empty, Set.empty, schemes)
where var n = length xs + n
( a, b, c) = ( var 1, var 2, var 3)
(va,vb,vc) = (VarT a, VarT b, VarT c)
rnm (ADT n []) | n == "Number" = va
| n == "Appendable" = vb
| n == "Comparable" = vc
rnm t = t
tcs' = map (second (map rnm)) tcs
supers t = map (Context name) $
zipWith (:<:) [va,vb,vc] [number,appendable t,comparable]
gen' (n,ts) = do t <- beta
let s = Forall (xs ++ [a,b,c]) (supers t) $
foldr (==>) (ADT name $ map VarT xs) ts
(,) n `liftM` generalize [] s
stmtGen (ExportEvent js elm tipe) = do
x <- guid
return ( Map.singleton elm [x]
, Set.singleton . ctx (Var elm) $ VarT x :=: tipe
, [] )
stmtGen (ImportEvent js base elm tipe) = do
(as,cs,t) <- gen base
return ( as
, Set.insert (ctx base (signalOf t :=: tipe)) cs
, [ (elm, Forall [] [] tipe) ] )
getDatatypeInfo (Datatype name args tcs) =
Just (name, args, tcs)
getDatatypeInfo _ = Nothing