75593c5 · elk · git.iko.soy

elm/src/Ast.hs+7−4

@@ -6,16 +6,13 @@ import Data.List (intercalate)

66import Types

77import Guid

88

9−data Module = Module [String] Exports Imports [Definition] JSFFI

9+data Module = Module [String] Exports Imports [Statement]

1010

1111type Exports = [String]

1212

1313type Imports = [(String, ImportMethod)]

1414data ImportMethod = As String | Hiding [String] | Importing [String]

1515

16−type JSFFI = ( [(String, Expr, String, Type)]

17− , [(String, String, Type)] )

18−

1916

2017data Pattern = PData String [Pattern] | PVar String | PAnything

2118 deriving (Eq)

@@ -44,6 +41,12 @@ data Expr = IntNum Int

4441data Definition = Definition String [String] Expr

4542 deriving (Eq)

4643

44+data Statement = Def String [String] Expr

45+ | Datatype String [X] [(String,[Type])]

46+ | ImportEvent String Expr String Type

47+ | ExportEvent String String Type

48+ deriving (Eq)

49+

4750cons h t = Data "Cons" [h,t]

4851nil = Data "Nil" []

4952list = foldr cons nil

elm/src/Compiler.hs+1−1

@@ -73,7 +73,7 @@ getModules uses file = do

7373 code <- readFile file

7474 case initialize code of

7575 Left err -> return . Left $ "Error in " ++ file ++ ":\n" ++ err

76− Right modul@(Module _ _ imports _ _) ->

76+ Right modul@(Module _ _ imports _) ->

7777 let imps = filter (`notElem` builtInModules) $ map fst imports in

7878 case intersect uses imps of

7979 x:_ -> return . Left $ "Error: Cyclic dependency. Module " ++

elm/src/FreeVar.hs+1−1

@@ -1,4 +1,4 @@

1−module FreeVar (freeIn) where

1+module FreeVar (freeIn,freeVars) where

22

33import Ast

44import Data.Set (union, unions, delete, singleton, empty, difference, member)

elm/src/Gen/CompileToJS.hs+51−23

@@ -2,6 +2,7 @@

22module CompileToJS (showErr, jsModule) where

33

44import Ast

5+import Control.Arrow (first)

56import Control.Monad (liftM,(<=<),join)

67import Data.Char (isAlpha,isDigit)

78import Data.List (intercalate,sortBy,inits)

@@ -38,39 +39,36 @@ tryBlock names e =

3839 ]

3940

4041

41−jsModule (Module names exports imports defs foreigns) =

42+jsModule (Module names exports imports stmts) =

4243 tryBlock (tail modNames) $ concat

4344 [ concatMap (\n -> globalAssign n $ n ++ " || {}") .

4445 map (intercalate ".") . drop 2 . inits $

4546 take (length modNames - 1) modNames

4647 , "\nif (" ++ modName ++ ") throw \"Module name collision, '" ++

4748 intercalate "." (tail modNames) ++ "' is already defined.\"; "

48− , globalAssign modName $ jsFunc "" (includes++ims++body++exs++export)++"()"

49+ , globalAssign modName $ jsFunc "" (includes ++body++ export) ++ "()"

4950 , mainEquals $ modName ++ ".main" ]

50− where modNames = if null names then ["ElmCode", "Main"] else "ElmCode" : names

51+ where modNames = if null names then ["ElmCode", "Main"]

52+ else "ElmCode" : names

5153 modName = intercalate "." modNames

52− includes = concatMap jsImport $

53− map (\(x,y) -> ("ElmCode." ++ x,y)) imports

54− body = jsDefs defs

55− export = ret . braces . intercalate "," $ mapMaybe getNames defs

54+ includes = concatMap jsImport $ map (first ("ElmCode."++)) imports

55+ body = stmtsToJS stmts

56+ export = getExports exps stmts

5657 exps = if null exports then ["main"] else exports

57− getNames (Definition x _ _) =

58− let y = reverse . tail . dropWhile isDigit $ reverse x in

59− if y `elem` exps then Just $ y ++ ":" ++ x else Nothing

60− (ims,exs) = let (i,e) = foreigns in

61− (concatMap importEvent i, concatMap exportEvent e)

6258

63−importEvent (js,base,elm,_) =

64− concat [ "\nvar " ++ elm ++ " = Elm.Input(" ++ toJS base ++ ");"

65− , "\nSignal.addListener(document, '" ++ js

66− , "', function(e) { Dispatcher.notify(" ++ elm

67− , ".id, e.value); });" ]

68−exportEvent (js,elm,_) =

69− concat [ "\nlift(function(v) { var e = document.createEvent('Event');"

70− , "e.initEvent('" ++ js ++ "', true, true);"

71− , "e.value = v;"

72− , "document.dispatchEvent(e); return v; })(" ++ elm ++ ");"

73− ]

59+stripID var

60+ | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var

61+ | otherwise = var

62+

63+getExports names stmts = ret . braces $ intercalate "," pairs

64+ where pairs = mapMaybe pair $ concatMap get stmts

65+ pair x = if y `elem` names then Just $ y ++ ":" ++ x else Nothing

66+ where y = stripID x

67+ get s = case s of Def x _ _ -> [x]

68+ Datatype _ _ tcs -> map fst tcs

69+ ImportEvent _ _ x _ -> [x]

70+ ExportEvent _ _ _ -> []

71+

7472

7573jsImport (modul, how) =

7674 concat [ "\ntry{" ++ modul ++ " instanceof Object} catch(e) {throw \"Module '"

@@ -90,7 +88,37 @@ jsImport' (modul, Hiding vs) =

9088 , globalAssign "this[i]" $ modul ++ "[i]"

9189 , "}" ]

9290

91+stmtsToJS :: [Statement] -> String

92+stmtsToJS stmts = concatMap stmtToJS (sortBy cmpStmt stmts)

93+ where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)

94+ valueOf s = case s of Datatype _ _ _ -> 1

95+ ImportEvent _ _ _ _ -> 3

96+ Def _ [] _ -> 3

97+ Def _ _ _ -> 4

98+ ExportEvent _ _ _ -> 5

99+

100+stmtToJS :: Statement -> String

101+stmtToJS (Def name [] e) = assign name (toJS e)

102+stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++

103+ braces (ret . toJS $ foldr Lambda e as) ++ ";"

104+stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs

105+ where toDef (name,args) = Def name vars $ Data (stripID name) (map Var vars)

106+ where vars = map (('a':) . show) [1..length args]

107+stmtToJS (ImportEvent js base elm _) =

108+ concat [ "\nvar " ++ elm ++ " = Elm.Input(" ++ toJS base ++ ");"

109+ , "\nSignal.addListener(document, '" ++ js

110+ , "', function(e) { Dispatcher.notify(" ++ elm

111+ , ".id, e.value); });" ]

112+stmtToJS (ExportEvent js elm _) =

113+ concat [ "\nlift(function(v) { var e = document.createEvent('Event');"

114+ , "e.initEvent('" ++ js ++ "', true, true);"

115+ , "e.value = v;"

116+ , "document.dispatchEvent(e); return v; })(" ++ elm ++ ");"

117+ ]

118+

119+

93120

121+toJS :: Expr -> String

94122toJS expr =

95123 case expr of

96124 IntNum n -> show n

elm/src/Gen/ExtractNoscript.hs+4−2

@@ -3,8 +3,10 @@ module ExtractNoscript (extract) where

33

44import Ast

55

6−extract (Module _ _ _ defs _) =

7− concatMap (\s -> "<p>" ++ s ++ "</p>") $ concatMap (\(Definition _ _ e) -> extract' e) defs

6+extract (Module _ _ _ stmts) =

7+ concatMap (\s -> "<p>" ++ s ++ "</p>") (concatMap stmtExtract stmts)

8+ where stmtExtract (Def _ _ e) = extract' e

9+ stmtExtract _ = []

810

911extract' expr =

1012 let f = extract' in

elm/src/Gen/GenerateHtml.hs+2−2

@@ -53,13 +53,13 @@ modulesToHtml title libLoc jss nscrpt modules = createHtml libLoc title' js nosc

5353 where js = Right $ jss ++ concatMap jsModule modules

5454 noscript = if nscrpt then extract $ last modules else ""

5555 title' = if null title then altTitle else title

56− altTitle = (\(Module names _ _ _ _) -> intercalate "." names) $

56+ altTitle = (\(Module names _ _ _) -> intercalate "." names) $

5757 last modules

5858

5959

6060linkedHtml rtLoc jsLoc modules =

6161 createHtml rtLoc title (Left jsLoc) (H.noscript "")

62− where title = (\(Module names _ _ _ _) -> intercalate "." names) $

62+ where title = (\(Module names _ _ _) -> intercalate "." names) $

6363 last modules

6464

6565

elm/src/Initialize.hs+8−19

@@ -1,11 +1,12 @@

11module Initialize (initialize) where

22

3+import Control.Applicative ((<$>))

34import Control.Monad.Error

45import Data.List (lookup)

56

67import Ast

78import Parser (parseProgram)

8−import Hints

9+import Hints (hints)

910import Unify

1011import Rename

1112import Types ((-:))

@@ -14,21 +15,9 @@ import Optimize

1415

1516initialize str =

1617 let nameOf (Definition n _ _) = n in

17− do (Module name ex im defs (ims,exs), tipes) <- parseProgram str

18− let (Let ds _) = rename . Let defs $ Var "_"

19− let dict n = maybe n id . lookup n $ zip (map nameOf defs) (map nameOf ds)

20− let allHints = hints ++ tipes ++ ffiHints (ims,exs)

21− subs <- unify allHints . Let ds $ checkFFI dict ims exs

22− let Let defs' _ = optimize (Let ds $ Var "_")

23− let im' = if any ((=="Prelude") . fst) im then im else

24− ("Prelude", Importing []):im

25− let exs' = map (\(js,n,t) -> (js,dict n,t)) exs

26− return (subs `seq` Module name ex im' defs' (ims,exs'))

27−

28−

29−ffiHints (ims,exs) =

30− map (\(_,_,n,t) -> n -: t) ims ++ map (\(_,n,t) -> n -: t) exs

31−

32−checkFFI dict ims exs = list $ ims' ++ exs'

33− where ims' = map (\(_,b,n,_)-> Binop "==" (Var n) (App (Var "constant") b)) ims

34− exs' = map (\(_,n,_) -> Binop "==" (Var n) (Var $ dict n)) exs

18+ do modul@(Module name ex im stmts) <- rename <$> parseProgram str

19+ subs <- unify hints modul

20+ let modul' = Module name ex im' stmts

21+ where im' | any ((=="Prelude") . fst) im = im

22+ | otherwise = ("Prelude", Importing []) : im

23+ subs `seq` return (optimize modul')

elm/src/Optimize.hs+9−2

@@ -5,9 +5,16 @@ import Control.Arrow (second)

55import Data.Char (isAlpha)

66

77

8−optimize exp = if exp == exp' then exp' else optimize exp'

9− where exp' = simp exp

8+optimize (Module name ims exs stmts) =

9+ Module name ims exs (map optimizeStmt stmts)

1010

11+optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'

12+ where stmt' = simpStmt stmt

13+ simpStmt (Def name args e) = Def name args (simp e)

14+ simpStmt (ImportEvent js b elm t) = ImportEvent js (simp b) elm t

15+ simpStmt stmt = stmt

16+

17+simp :: Expr -> Expr

1118simp expr =

1219 let f = simp in

1320 case expr of

elm/src/Parse/ParseExpr.hs+1−6

@@ -117,13 +117,8 @@ assignExpr = do

117117 whitespace; string "="; whitespace; exp <- expr

118118 flattenPatterns patterns exp

119119

120+def = map (\(Definition n as e) -> Def n as e) <$> assignExpr

120121

121−def = do ds <- assignExpr

122− return (ds,[])

123−{--

124− do (fs,es) <- unzip <$> assignExpr

125− return (fs, es, map (\_ -> Forall [0] [] (VarT 0)) fs)

126−--}

127122

128123parseDef str =

129124 case parse def "" str of

elm/src/Parse/ParseForeign.hs+5−11

@@ -1,5 +1,5 @@

11

2−module ParseForeign (foreignDefs) where

2+module ParseForeign (foreignDef) where

33

44import Control.Applicative ((<$>), (<*>))

55import Data.Either (partitionEithers)

@@ -12,14 +12,8 @@ import ParseTypes

1212import Types (signalOf)

1313

1414

15−foreignDefs = do

16− f <- foreign --commitIf (reserved "foreign") foreign

17− fs <- many (commitIf (freshLine >> reserved "foreign") (freshLine >> foreign))

18− return . partitionEithers $ f:fs

19−

20−

21−foreign = do try (reserved "foreign") ; whitespace

22− Left <$> importEvent <|> Right <$> exportEvent

15+foreignDef = do try (reserved "foreign") ; whitespace

16+ importEvent <|> exportEvent

2317

2418exportEvent = do

2519 try (reserved "export" >> whitespace >> reserved "jsevent" >> whitespace)

@@ -29,7 +23,7 @@ exportEvent = do

2923 tipe <- typeExpr

3024 case tipe of

3125 ADTPT "Signal" [pt] ->

32− either fail (return . (,,) js elm . signalOf) (toForeignType pt)

26+ either fail (return . ExportEvent js elm . signalOf) (toForeignType pt)

3327 _ -> fail "When exporting events, the exported value must be a Signal."

3428

3529importEvent = do

@@ -42,7 +36,7 @@ importEvent = do

4236 tipe <- typeExpr

4337 case tipe of

4438 ADTPT "Signal" [pt] ->

45− either fail (return . (,,,) js base elm . signalOf) (toForeignType pt)

39+ either fail (return . ImportEvent js base elm . signalOf) (toForeignType pt)

4640 _ -> fail "When importing events, the imported value must be a Signal."

4741

4842

elm/src/Parse/ParseTypes.hs+9−17

@@ -2,7 +2,7 @@ module ParseTypes where

22

33import Ast

44import Control.Applicative ((<$>),(<*>))

5−import Control.Monad (liftM)

5+import Control.Monad (liftM,mapM)

66import Data.Char (isUpper,isLower)

77import Data.Maybe (fromMaybe)

88import Data.List (lookup)

@@ -52,41 +52,33 @@ typeExpr = do

5252typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])

5353typeConstructor = (,) <$> (capVar <?> "another type constructor") <*> spacePrefix (typeSimple <|> typeUnambiguous)

5454

55−datatype :: (Monad m) => ParsecT [Char] u m ([Definition], [(String,Scheme)])

55+datatype :: (Monad m) => ParsecT [Char] u m Statement

5656datatype = do

5757 reserved "data" <?> "datatype definition (data T = A | B | ...)"

5858 forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar

5959 whitespace ; string "=" ; whitespace

6060 tcs <- pipeSep1 typeConstructor

61− case getConstraints name args tcs of

62− Right cs -> return (map toDef tcs, cs)

61+ case toDatatype name args tcs of

62+ Right dt -> return dt

6363 Left msg -> fail msg

6464

6565beta = liftM VarT guid

6666

67−toDef (name,types) = Definition name args (Data name (map Var args))

68− where args = map (('a':) . show) [1..length types]

69−

70−getConstraints name args constructors =

71− mapM (toConstraint tvarDict . ADT name $ map (VarT . snd) tvarDict) constructors

72− where tvarDict = zip args [1..length args]

73−

74−toConstraint tvarDict outType (name,args) =

75− ((,) name . Forall [1..n+2] cs . foldr (==>) outType) <$> mapM toT args

76− where n = length tvarDict

77− cs = [ VarT (n+1) :<: time, VarT (n+2) :<: number ]

67+toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs

68+ where n = length args

69+ tvarDict = zip args [1..n]

70+ toC (name,pt) = (,) name <$> mapM toT pt

7871 toT (LambdaPT t1 t2) = (==>) <$> toT t1 <*> toT t2

7972 toT (ADTPT name args) = ADT name <$> mapM toT args

8073 toT (VarPT x@(c:_))

8174 | isLower c = VarT <$> case lookup x tvarDict of

8275 Just v -> Right v

8376 Nothing -> Left $ msg x

84− | x == "Time" = return $ VarT (n+1)

85− | x == "Number" = return $ VarT (n+2)

8677 | otherwise = return $ ADT x []

8778 msg x = "Type variable '" ++ x ++

8879 "' is unbound in type constructor '" ++ name ++ "'."

8980

81+

9082toForeignType (LambdaPT t1 t2) =

9183 fail $ "Elm's JavaScript event interface does not yet handle functions. " ++

9284 "Only simple values can be imported and exported in this release."

elm/src/Parse/Parser.hs+10−6

@@ -14,22 +14,26 @@ import ParseModules

1414import ParseForeign

1515

1616

17+statement = (:[]) <$> foreignDef

18+ <|> (:[]) <$> datatype

19+ <|> def

20+ <?> "datatype or variable definition"

21+

1722freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

1823 freshLine

19− datatype <|> def <?> "another datatype or variable definition"

24+ statement <?> "another datatype or variable definition"

2025

21−defs1 = do d <- datatype <|> def <?> "at least one datatype or variable definition"

22− (d:) <$> many freshDef

26+defs1 = do d <- statement <?> "at least one datatype or variable definition"

27+ concat <$> (d:) <$> many freshDef

2328

2429program = do

2530 optional freshLine

2631 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

2732 is <- (do try (lookAhead $ reserved "import")

2833 imports `followedBy` freshLine) <|> return []

29− jsffi <- foreignDefs `followedBy` freshLine <|> return ([],[])

30− (defss, schemess) <- unzip <$> defs1

34+ statements <- defs1

3135 optional freshLine ; optional spaces ; eof

32− return (Module names exports is (concat defss) jsffi, concat schemess)

36+ return $ Module names exports is statements

3337

3438parseProgram source =

3539 case parse program "" source of

elm/src/Rename.hs+29−11

@@ -8,8 +8,26 @@ import Control.Monad.State (evalState, State, get, put)

88import Data.Char (isLower)

99import Guid

1010

11−rename :: Expr -> Expr

12−rename = run . rename' id

11+rename :: Module -> Module

12+rename (Module name ex im stmts) =

13+ Module name ex im . run $ renameStatements id stmts

14+

15+renameStatements env stmts = do env' <- extends env $ concatMap getNames stmts

16+ mapM (renameStmt env') stmts

17+ where getNames stmt = case stmt of Def n _ _ -> [n]

18+ Datatype _ _ tcs -> map fst tcs

19+ ImportEvent _ _ n _ -> [n]

20+ ExportEvent _ _ _ -> []

21+ renameStmt env (Def name args e) =

22+ do env' <- extends env args

23+ Def (env name) (map env' args) `liftM` rename' env' e

24+ renameStmt env (Datatype name args tcs) =

25+ return $ Datatype name args $ map (first env) tcs

26+ renameStmt env (ImportEvent js base elm tipe) =

27+ do base' <- rename' env base

28+ return $ ImportEvent js base' (env elm) tipe

29+ renameStmt env (ExportEvent js elm tipe) =

30+ return $ ExportEvent js (env elm) tipe

1331

1432rename' :: (String -> String) -> Expr -> GuidCounter Expr

1533rename' env expr =

@@ -48,15 +66,7 @@ rename' env expr =

4866

4967 Async e -> Async `liftM` rnm e

5068

51− Let defs e ->

52− let (fs,argss,es) = unzip3 $ map (\(Definition a b c) -> (a,b,c)) defs in

53− do env' <- extends env fs

54− let combine args e = do env'' <- extends env' args

55− re <- rename' env'' e

56− return (map env'' args, re)

57− defs' <- zipWith (\f -> uncurry $ Definition f) (map env' fs) `liftM` zipWithM combine argss es

58− re <- rename' env' e

59− return $ Let defs' re

69+ Let defs e -> renameLet env defs e

6070

6171 Var x -> return . Var $ env x

6272

@@ -93,3 +103,11 @@ patternRename env (p,e) = do

93103 (rp,env') <- patternExtend p env

94104 re <- rename' env' e

95105 return (rp,re)

106+

107+renameLet env defs e = do env' <- extends env $ map getNames defs

108+ defs' <- mapM (renameDef env') defs

109+ Let defs' `liftM` rename' env' e

110+ where getNames (Definition n _ _) = n

111+ renameDef env (Definition name args e) =

112+ do env' <- extends env args

113+ Definition (env name) (map env' args) `liftM` rename' env' e

elm/src/Types/Constrain.hs+84−31

@@ -1,11 +1,12 @@

11

2−module Constrain where

2+module Constrain (constrain, Context (..)) where

33

44import Ast

55import Types

66import Data.List (foldl')

77import qualified Data.Set as Set

88import qualified Data.Map as Map

9+import Control.Arrow (second)

910import Control.Monad (liftM,mapM,zipWithM)

1011import Control.Monad.State (evalState)

1112import Guid

@@ -14,39 +15,42 @@ beta = VarT `liftM` guid

1415unionA = Map.unionWith (++)

1516unionsA = Map.unionsWith (++)

1617

17−data Context a b = Context a b deriving (Eq,Show)

18+data Context a b = Context a b deriving (Eq, Show)

1819ctx e = Context e

1920

2021instance (Ord a, Eq c) => Ord (Context c a) where

2122 compare (Context _ x) (Context _ y) = compare x y

2223

23−constrain hints expr = do

24− (as,cs,t) <- inference expr

25− let cMap = Map.intersectionWithKey combine (Map.fromList hints) as

26− where combine k s vs = map (\v -> ctx (Var k) $ VarT v :<<: s) vs

27− return (Set.toList cs ++ (concatMap snd $ Map.toList cMap))

24+constrain hints (Module _ _ _ stmts) = do

25+ (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts

26+ let allHints = Map.fromList $ hints ++ concat schemess

27+ let combine k s vs = map (\v -> ctx (Var k) $ VarT v :<<: s) vs

28+ let cMap = Map.intersectionWithKey combine allHints (unionsA ass)

29+ return (Set.toList (Set.unions css) ++ (concatMap snd $ Map.toList cMap))

2830

29−inference :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context Expr Constraint), Type)

30−inference (Var x) =

31+gen :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context Expr Constraint), Type)

32+

33+gen (Var x) =

3134 do b <- guid

3235 return (Map.singleton x [b], Set.empty, VarT b)

33−inference e@(App e1 e2) =

34− do (a1,c1,t1) <- inference e1

35− (a2,c2,t2) <- inference e2

36+

37+gen e@(App e1 e2) =

38+ do (a1,c1,t1) <- gen e1

39+ (a2,c2,t2) <- gen e2

3640 b <- beta

3741 return ( unionA a1 a2

3842 , Set.unions [c1,c2,Set.singleton . ctx e $ t1 :=: (LambdaT t2 b)]

3943 , b )

40−inference (Lambda x e) =

41− do (a,c,t) <- inference e

44+gen (Lambda x e) =

45+ do (a,c,t) <- gen e

4246 b <- beta

4347 v <- guid

4448 return ( Map.delete x a

4549 , Set.union c . Set.fromList . map (\x -> ctx e $ VarT x :=: b) $

4650 Map.findWithDefault [v] x a

4751 , LambdaT b t )

48−inference (Let defs e) =

49− do (as,cs,t) <- inference e

52+gen (Let defs e) =

53+ do (as,cs,t) <- gen e

5054 (ass, schemes) <- liftM unzip (mapM defScheme defs)

5155 let assumptions = unionsA (as:ass)

5256 let names = map (\(Definition x _ _) -> x) defs

@@ -58,28 +62,28 @@ inference (Let defs e) =

5862 , Set.union (Set.fromList . concat $ cs') cs

5963 , t )

6064

61−inference ce@(Case e cases) =

62− do (as,cs,t) <- inference e

63− (ass,css,ts) <- liftM unzip3 $ mapM (caseInference t) cases

65+gen ce@(Case e cases) =

66+ do (as,cs,t) <- gen e

67+ (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases

6468 return ( unionsA $ as:ass

6569 , let combine t1 t2 = ctx ce (t1 :=: t2) in

6670 Set.unions $ Set.fromList (zipWith combine ts $ tail ts) : cs : css

6771 , head ts)

6872

69−inference e@(If e1 e2 e3) =

70− do (a1,c1,t1) <- inference e1

71− (a2,c2,t2) <- inference e2

72− (a3,c3,t3) <- inference e3

73+gen e@(If e1 e2 e3) =

74+ do (a1,c1,t1) <- gen e1

75+ (a2,c2,t2) <- gen e2

76+ (a3,c3,t3) <- gen e3

7377 return ( unionsA [a1,a2,a3]

7478 , Set.unions [c1,c2,c3, Set.fromList [ ctx e1 (t1 :=: bool), ctx e (t2 :=: t3) ] ]

7579 , t2 )

7680

77−inference (Data name es) = inference $ foldl' App (Var name) es

78−inference (Binop op e1 e2) = inference (Var op `App` e1 `App` e2)

79−inference (Access (Var x) y) = inference . Var $ x ++ "." ++ y

80−inference (Range e1 e2) = inference (Var "elmRange" `App` e1 `App` e2)

81+gen (Data name es) = gen $ foldl' App (Var name) es

82+gen (Binop op e1 e2) = gen (Var op `App` e1 `App` e2)

83+gen (Access (Var x) y) = gen . Var $ x ++ "." ++ y

84+gen (Range e1 e2) = gen (Var "elmRange" `App` e1 `App` e2)

8185

82−inference other =

86+gen other =

8387 case other of

8488 IntNum _ -> do t <- beta

8589 return (Map.empty, Set.singleton (ctx other $ t :<: number), t)

@@ -91,8 +95,8 @@ inference other =

9195

9296primitive t = return (Map.empty, Set.empty, t)

9397

94−caseInference tipe (p,e) = do

95− (as,cs,t) <- inference e

98+caseGen tipe (p,e) = do

99+ (as,cs,t) <- gen e

96100 return ( foldr Map.delete as (namesIn p)

97101 , cs

98102 , t)

@@ -103,7 +107,7 @@ namesIn (PData name ps) = concatMap namesIn ps

103107

104108defScheme (Definition name args e) =

105109 do argDict <- mapM (\a -> liftM ((,) a) guid) args

106− (as,cs,t) <- inference e

110+ (as,cs,t) <- gen e

107111 let genCs (arg,x) = do

108112 v <- guid

109113 return . map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [v] arg as

@@ -112,3 +116,52 @@ defScheme (Definition name args e) =

112116 let tipe = foldr (==>) t $ map (VarT . snd) argDict

113117 return ( foldr Map.delete as args

114118 , Forall (map snd argDict) (cs' ++ cs'') tipe)

119+

120+stmtGen (Def name args e) = do

121+ argDict <- mapM (\a -> liftM ((,) a) guid) args

122+ (as,cs,t) <- gen e

123+ let genCs (arg,x) = do

124+ v <- guid

125+ return . map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [v] arg as

126+ cs' <- concat `liftM` mapM genCs argDict

127+ let cs'' = map (\(Context _ c) -> c) (Set.toList cs)

128+ let tipe = foldr (==>) t $ map (VarT . snd) argDict

129+ return ( foldr Map.delete as args

130+ , Set.empty

131+ , [ (name, Forall (map snd argDict) (cs' ++ cs'') tipe) ] )

132+

133+stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'

134+ return (Map.empty, Set.empty, schemes)

135+ where names = map (+ (length xs)) [1..5]

136+ tcs' = map (second . map $ rnm names) tcs

137+ supers t = zipWith (:<:) (map VarT names)

138+ [ number, time, appendable t, comparable, transformable ]

139+ gen' (n,ts) = do

140+ t <- beta

141+ return . (,) n . Forall (xs ++ names) (supers t) $

142+ foldr (==>) (ADT name $ map VarT xs) ts

143+ rnm [a,b,c,d,e] (ADT n []) | n == "Number" = VarT a

144+ | n == "Time" = VarT b

145+ | n == "Appendable" = VarT c

146+ | n == "Comparable" = VarT d

147+ | n == "Transformable" = VarT e

148+ rnm _ t = t

149+

150+stmtGen (ExportEvent js elm tipe) = do

151+ x <- guid

152+ return ( Map.singleton elm [x]

153+ , Set.singleton . ctx (Var elm) $ VarT x :=: tipe

154+ , [] )

155+

156+stmtGen (ImportEvent js base elm tipe) = do

157+ (as,cs,t) <- gen base

158+ return ( as

159+ , Set.insert (ctx (Var elm) (t :=: tipe)) cs

160+ , [ (elm, Forall [] [] tipe) ] )

161+

162+ffiHints (ims,exs) =

163+ map (\(_,_,n,t) -> n -: t) ims ++ map (\(_,n,t) -> n -: t) exs

164+

165+checkFFI dict ims exs = list $ ims' ++ exs'

166+ where ims' = map (\(_,b,n,_)-> Binop "==" (Var n) (App (Var "constant") b)) ims

167+ exs' = map (\(_,n,_) -> Binop "==" (Var n) (Var $ dict n)) exs

elm/src/Types/Unify.hs+2−2

@@ -11,8 +11,8 @@ import Types

1111

1212import Control.DeepSeq (NFData (..), deepseq)

1313

14−unify hints expr = run $ do

15− cs <- constrain hints expr

14+unify hints modul = run $ do

15+ cs <- constrain hints modul

1616 solver cs []

1717

1818eq ctx t1 t2 = Context ctx (t1 :=: t2)