75593c5 · elk · git.iko.soy

git.iko.soy/elk

Change representation of Modules. Now all statements (definitions, datatypes, event imports, and event exports) are treated the same way. This caused lots of changes, but will ultimately improve type checking.

75593c5evancz14 years ago

elm/src/Ast.hs+7−4

compare with master

unifiedsplit

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

6import Types

7import Guid

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

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

11type Exports = [String]

13type Imports = [(String, ImportMethod)]

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

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

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

18−

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

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

21 deriving (Eq)

18 deriving (Eq)

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

44data Definition = Definition String [String] Expr

41data Definition = Definition String [String] Expr

45 deriving (Eq)

42 deriving (Eq)

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+

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

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

48nil = Data "Nil" []

51nil = Data "Nil" []

49list = foldr cons nil

52list = foldr cons nil

elm/src/Compiler.hs+1−1

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

73 code <- readFile file

74 case initialize code of

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

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

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

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

78 case intersect uses imps of

79 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

3import Ast

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

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

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

2module CompileToJS (showErr, jsModule) where

4import Ast

5+import Control.Arrow (first)

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

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

6import Data.Char (isAlpha,isDigit)

7import Data.Char (isAlpha,isDigit)

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

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

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

38 ]

39 ]

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

42+jsModule (Module names exports imports stmts) =

42 tryBlock (tail modNames) $ concat

43 tryBlock (tail modNames) $ concat

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

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

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

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

45 take (length modNames - 1) modNames

46 take (length modNames - 1) modNames

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

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

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

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

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

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

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

50 , 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

51 modName = intercalate "." modNames

53 modName = intercalate "." modNames

52− includes = concatMap jsImport $

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

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

55+ body = stmtsToJS stmts

54− body = jsDefs defs

56+ export = getExports exps stmts

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

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

57 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)

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

59+stripID var

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

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

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

61+ | otherwise = var

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

62+

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

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

68−exportEvent (js,elm,_) =

64+ where pairs = mapMaybe pair $ concatMap get stmts

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

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

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

66+ where y = stripID x

71− , "e.value = v;"

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

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

68+ Datatype _ _ tcs -> map fst tcs

73− ]

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

70+ ExportEvent _ _ _ -> []

71+

75jsImport (modul, how) =

73jsImport (modul, how) =

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

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

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

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

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

91 , "}" ]

89 , "}" ]

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+

120

121+toJS :: Expr -> String

94toJS expr =

122toJS expr =

95 case expr of

123 case expr of

96 IntNum n -> show n

124 IntNum n -> show n

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

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

4import Ast

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

6+extract (Module _ _ _ stmts) =

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

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

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

9+ stmtExtract _ = []

9extract' expr =

11extract' expr =

10 let f = extract' in

12 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

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

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

55 title' = if null title then altTitle else title

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

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

57 last modules

60linkedHtml rtLoc jsLoc modules =

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

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

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

63 last modules

elm/src/Initialize.hs+8−19

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

1module Initialize (initialize) where

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

3import Control.Monad.Error

4import Control.Monad.Error

4import Data.List (lookup)

5import Data.List (lookup)

6import Ast

7import Ast

7import Parser (parseProgram)

8import Parser (parseProgram)

8−import Hints

9+import Hints (hints)

9import Unify

10import Unify

10import Rename

11import Rename

11import Types ((-:))

12import Types ((-:))

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

15initialize str =

16initialize str =

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

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

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

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

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

19+ subs <- unify hints modul

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

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

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

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

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

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

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

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

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

elm/src/Optimize.hs+9−2

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

5import Data.Char (isAlpha)

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

8+optimize (Module name ims exs stmts) =

9− where exp' = simp exp

9+ Module name ims exs (map optimizeStmt stmts)

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

11simp expr =

18simp expr =

12 let f = simp in

19 let f = simp in

13 case expr of

20 case expr of

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

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

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

118 flattenPatterns patterns exp

119

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

120

121

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−--}

127

122

128parseDef str =

123parseDef str =

129 case parse def "" str of

124 case parse def "" str of

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

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

2−module ParseForeign (foreignDefs) where

2+module ParseForeign (foreignDef) where

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

5import Data.Either (partitionEithers)

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

12import Types (signalOf)

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

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

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

16+ importEvent <|> exportEvent

24exportEvent = do

18exportEvent = do

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

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

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

29 tipe <- typeExpr

23 tipe <- typeExpr

30 case tipe of

24 case tipe of

31 ADTPT "Signal" [pt] ->

25 ADTPT "Signal" [pt] ->

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

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

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

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

35importEvent = do

29importEvent = do

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

42 tipe <- typeExpr

36 tipe <- typeExpr

43 case tipe of

37 case tipe of

44 ADTPT "Signal" [pt] ->

38 ADTPT "Signal" [pt] ->

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

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

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

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

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

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

3import Ast

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

5−import Control.Monad (liftM)

5+import Control.Monad (liftM,mapM)

6import Data.Char (isUpper,isLower)

7import Data.Maybe (fromMaybe)

8import Data.List (lookup)

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

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

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

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

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

56datatype = do

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

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

59 whitespace ; string "=" ; whitespace

60 tcs <- pipeSep1 typeConstructor

61− case getConstraints name args tcs of

61+ case toDatatype name args tcs of

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

62+ Right dt -> return dt

63 Left msg -> fail msg

65beta = liftM VarT guid

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

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

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

68+ where n = length args

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]

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

73−

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

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 ]

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

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

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

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

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

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

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

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

82 Just v -> Right v

75 Just v -> Right v

83 Nothing -> Left $ msg x

76 Nothing -> Left $ msg x

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

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

86 | otherwise = return $ ADT x []

77 | otherwise = return $ ADT x []

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

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

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

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

81+

90toForeignType (LambdaPT t1 t2) =

82toForeignType (LambdaPT t1 t2) =

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

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

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

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

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

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

14import ParseForeign

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

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

19+ <|> def

20+ <?> "datatype or variable definition"

21+

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

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

18 freshLine

23 freshLine

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

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

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

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

22− (d:) <$> many freshDef

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

24program = do

29program = do

25 optional freshLine

30 optional freshLine

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

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

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

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

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

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

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

34+ statements <- defs1

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

31 optional freshLine ; optional spaces ; eof

35 optional freshLine ; optional spaces ; eof

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

36+ return $ Module names exports is statements

34parseProgram source =

38parseProgram source =

35 case parse program "" source of

39 case parse program "" source of

elm/src/Rename.hs+29−11

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

8import Data.Char (isLower)

9import Guid

11−rename :: Expr -> Expr

11+rename :: Module -> Module

12−rename = run . rename' id

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

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

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

15rename' env expr =

33rename' env expr =

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

49 Async e -> Async `liftM` rnm e

67 Async e -> Async `liftM` rnm e

51− Let defs e ->

69+ Let defs e -> renameLet env 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

61 Var x -> return . Var $ env x

71 Var x -> return . Var $ env x

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

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

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

94 re <- rename' env' e

104 re <- rename' env' e

95 return (rp,re)

105 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 @@

2−module Constrain where

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

4import Ast

5import Types

6import Data.List (foldl')

7import qualified Data.Set as Set

8import qualified Data.Map as Map

9+import Control.Arrow (second)

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

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

10import Control.Monad.State (evalState)

11import Control.Monad.State (evalState)

11import Guid

12import Guid

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

14unionA = Map.unionWith (++)

15unionA = Map.unionWith (++)

15unionsA = Map.unionsWith (++)

16unionsA = Map.unionsWith (++)

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

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

18ctx e = Context e

19ctx e = Context e

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

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

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

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

23−constrain hints expr = do

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

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

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

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

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

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

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

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

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

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

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

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

32+

30−inference (Var x) =

33+gen (Var x) =

31 do b <- guid

34 do b <- guid

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

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

36+

33−inference e@(App e1 e2) =

37+gen e@(App e1 e2) =

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

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

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

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

36 b <- beta

40 b <- beta

37 return ( unionA a1 a2

41 return ( unionA a1 a2

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

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

39 , b )

43 , b )

40−inference (Lambda x e) =

44+gen (Lambda x e) =

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

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

42 b <- beta

46 b <- beta

43 v <- guid

47 v <- guid

44 return ( Map.delete x a

48 return ( Map.delete x a

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

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

46 Map.findWithDefault [v] x a

50 Map.findWithDefault [v] x a

47 , LambdaT b t )

51 , LambdaT b t )

48−inference (Let defs e) =

52+gen (Let defs e) =

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

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

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

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

51 let assumptions = unionsA (as:ass)

55 let assumptions = unionsA (as:ass)

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

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

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

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

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

59 , t )

63 , t )

61−inference ce@(Case e cases) =

65+gen ce@(Case e cases) =

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

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

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

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

64 return ( unionsA $ as:ass

68 return ( unionsA $ as:ass

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

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

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

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

67 , head ts)

71 , head ts)

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

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

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

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

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

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

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

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

73 return ( unionsA [a1,a2,a3]

77 return ( unionsA [a1,a2,a3]

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

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

75 , t2 )

79 , t2 )

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

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

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

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

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

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

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

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

82−inference other =

86+gen other =

83 case other of

87 case other of

84 IntNum _ -> do t <- beta

88 IntNum _ -> do t <- beta

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

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

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

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

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

94−caseInference tipe (p,e) = do

98+caseGen tipe (p,e) = do

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

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

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

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

97 , cs

101 , cs

98 , t)

102 , t)

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

103

107

104defScheme (Definition name args e) =

108defScheme (Definition name args e) =

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

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

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

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

107 let genCs (arg,x) = do

111 let genCs (arg,x) = do

108 v <- guid

112 v <- guid

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

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

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

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

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

113 return ( foldr Map.delete as args

117 return ( foldr Map.delete as args

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

118 , 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

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

14−unify hints expr = run $ do

14+unify hints modul = run $ do

15− cs <- constrain hints expr

15+ cs <- constrain hints modul

16 solver cs []

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