721ce4f · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Continue reorganizing the code-base.

721ce4fevancz13 years ago

Elm.cabal−2

compare with master

unifiedsplit

@@ -65,7 +65,6 @@ Library

66 Build-depends: base >=4.2 && <5,

67 containers >= 0.3,

68− uniplate >= 1.6,

69 transformers >= 0.2,

68 transformers >= 0.2,

70 mtl >= 2,

69 mtl >= 2,

71 deepseq,

70 deepseq,

@@ -118,7 +117,6 @@ Executable elm

118

117

119 Build-depends: base >=4.2 && <5,

118 Build-depends: base >=4.2 && <5,

120 containers >= 0.3,

119 containers >= 0.3,

121− uniplate >= 1.6,

122 transformers >= 0.2,

120 transformers >= 0.2,

123 mtl >= 2,

121 mtl >= 2,

124 deepseq,

122 deepseq,

compiler/Gen/Cases.hs → compiler/Generate/Cases.hsrenamed+23−20

@@ -1,15 +1,16 @@

2−module Cases (caseToMatch, Match (..), Clause (..), matchSubst) where

2+module Generate.Cases (caseToMatch, Match (..), Clause (..), matchSubst) where

4import Control.Arrow (first)

5import Control.Monad (liftM,foldM)

6import Data.List (groupBy,sortBy,lookup)

7import Data.Maybe (fromMaybe)

9−import Ast

9+import Unique

10−import Located

10+import SourceSyntax.Location

11−import Guid

11+import SourceSyntax.Pattern

12+import SourceSyntax.Expression

12−import Substitute

13+import Transform.Substitute

14caseToMatch patterns = do

15caseToMatch patterns = do

15 v <- newVar

16 v <- newVar

@@ -18,17 +19,19 @@ caseToMatch patterns = do

18newVar = do n <- guid

19newVar = do n <- guid

19 return $ "case" ++ show n

20 return $ "case" ++ show n

22+data Match t v

21−data Match = Match String [Clause] Match

23+ = Match String [Clause t v] (Match t v)

22− | Break

24+ | Break

23− | Fail

25+ | Fail

24− | Other CExpr

26+ | Other (LExpr t v)

25− | Seq [Match]

27+ | Seq [Match t v]

26− deriving Show

28+ deriving Show

30+data Clause t v =

28−data Clause = Clause String [String] Match

31+ Clause String [String] (Match t v)

29− deriving Show

32+ deriving Show

31−matchSubst :: [(String,String)] -> Match -> Match

34+matchSubst :: [(String,String)] -> Match t v -> Match t v

32matchSubst _ Break = Break

35matchSubst _ Break = Break

33matchSubst _ Fail = Fail

36matchSubst _ Fail = Fail

34matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

37matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

@@ -45,7 +48,7 @@ isCon _ = False

46isVar p = not (isCon p)

49isVar p = not (isCon p)

48−match :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

51+match :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)

49match [] [] def = return def

52match [] [] def = return def

50match [] [([],e)] Fail = return $ Other e

53match [] [([],e)] Fail = return $ Other e

51match [] [([],e)] Break = return $ Other e

54match [] [([],e)] Break = return $ Other e

@@ -55,14 +58,14 @@ match vs cs def

55 | all isCon cs = matchCon vs cs def

58 | all isCon cs = matchCon vs cs def

56 | otherwise = matchMix vs cs def

59 | otherwise = matchMix vs cs def

58−matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

61+matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)

59matchVar (v:vs) cs def = match vs (map subVar cs) def

62matchVar (v:vs) cs def = match vs (map subVar cs) def

60 where

63 where

61 subVar (p:ps, ce@(L t s e)) =

64 subVar (p:ps, ce@(L t s e)) =

62 let

65 let

63 loc = L t s

66 loc = L t s

64 subOnePattern (PVar x) = subst x (Var v) e

67 subOnePattern (PVar x) = subst x (Var v) e

65− subOnePattern (PAsVar x p) =

68+ subOnePattern (PAlias x p) =

66 subst x (Var v) e

69 subst x (Var v) e

67 subOnePattern PAnything = e

70 subOnePattern PAnything = e

68 subOnePattern (PRecord fs) =

71 subOnePattern (PRecord fs) =

@@ -70,14 +73,14 @@ matchVar (v:vs) cs def = match vs (map subVar cs) def

70 in

73 in

71 (ps, L t s $ subOnePattern p)

74 (ps, L t s $ subOnePattern p)

73−matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

76+matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)

74matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

77matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

75 where css = groupBy (withName (==)) $ sortBy (withName compare) cs

78 where css = groupBy (withName (==)) $ sortBy (withName compare) cs

76 withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2

79 withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2

77 toClause cs = let (PData name _ : _ , _) = head cs in

80 toClause cs = let (PData name _ : _ , _) = head cs in

78 matchClause name (v:vs) cs Break

81 matchClause name (v:vs) cs Break

80−matchClause :: String -> [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Clause

83+matchClause :: String -> [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Clause t v)

81matchClause c (v:vs) cs def =

84matchClause c (v:vs) cs def =

82 do vs' <- getVars

85 do vs' <- getVars

83 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def

86 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def

@@ -85,6 +88,6 @@ matchClause c (v:vs) cs def =

85 getVars = let (PData _ ps : _, _) = head cs in

88 getVars = let (PData _ ps : _, _) = head cs in

86 mapM (\_ -> newVar) ps

89 mapM (\_ -> newVar) ps

88−matchMix :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

91+matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> Unique (Match t v)

89matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

92matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

90 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

93 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

compiler/Gen/GenerateHtml.hs → compiler/Generate/Html.hsrenamed+8−8

@@ -1,9 +1,9 @@

1{-# LANGUAGE OverloadedStrings #-}

2−module GenerateHtml (generateHtml,

2+module Generate.Html (generateHtml,

3− createHtml,

3+ createHtml,

4− JSStyle (..),

4+ JSStyle (..),

5− JSSource (..)

5+ JSSource (..)

6− ) where

6+ ) where

8import Data.List (intercalate)

9import Text.Blaze (preEscapedToMarkup)

@@ -17,9 +17,9 @@ import qualified Data.ByteString.Lazy.Char8 as BS

18import Ast

19import Initialize (buildFromSource)

20−import CompileToJS

20+import Generate.JavaScript

21−import ExtractNoscript

21+import Generate.Noscript

22−import Libraries as Libraries

22+import Metadata.Libraries as Libraries

24data JSStyle = Minified | Readable

25data JSSource = Link String | Source JSStyle String

compiler/Gen/CompileToJS.hs → compiler/Generate/JavaScript.hsrenamed+21−18

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

1−module CompileToJS (showErr, jsModule) where

1+module Generate.JavaScript (showErr, jsModule) where

3import Control.Arrow (first,second)

4import Control.Monad (liftM,(<=<),join,ap)

@@ -9,12 +9,9 @@ import Data.Either (partitionEithers)

9import qualified Text.Pandoc as Pan

10import Data.Maybe (maybeToList)

12−import Ast

12+import Unique

13−import Located

14−import Rename (derename)

15−import Cases

13+import Generate.Cases

16−import Guid

14+import SourceSyntax.Everything hiding (parens)

17−import Rename (deprime)

18import Types.Types ( Type(RecordT) )

15import Types.Types ( Type(RecordT) )

20showErr :: String -> String

17showErr :: String -> String

@@ -119,7 +116,7 @@ jsImport (modul, how) =

119

116

120

117

121

118

122−stmtsToJS :: [Statement] -> String

119+stmtsToJS :: [Declaration t v] -> String

123stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)

120stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)

124 return (concat program)

121 return (concat program)

125 where

122 where

@@ -135,9 +132,9 @@ stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)

135 TypeAlias _ _ _ -> 0

132 TypeAlias _ _ _ -> 0

136

133

137class ToJS a where

134class ToJS a where

138− toJS :: a -> GuidCounter String

135+ toJS :: a -> Unique String

139

136

140−instance ToJS Def where

137+instance ToJS (Def t v) where

141 toJS (FnDef x [] e) = assign x `liftM` toJS' e

138 toJS (FnDef x [] e) = assign x `liftM` toJS' e

142 toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e

139 toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e

143 where

140 where

@@ -151,15 +148,15 @@ instance ToJS Def where

151 toJS (TypeAnnotation _ _) = return ""

148 toJS (TypeAnnotation _ _) = return ""

152

149

153

150

154−instance ToJS Statement where

151+instance ToJS (Declaration t v) where

155 toJS stmt =

152 toJS stmt =

156 case stmt of

153 case stmt of

157 Definition d -> toJS d

154 Definition d -> toJS d

158 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs

155 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs

159 where toDef (name,args) =

156 where toDef (name,args) =

160 let vars = map (('a':) . show) [1..length args] in

157 let vars = map (('a':) . show) [1..length args] in

161− Definition . FnDef name vars . notLocated $

158+ Definition . FnDef name vars . none $

162− Data (derename name) (map (notLocated . Var) vars)

159+ Data (derename name) (map (none . Var) vars)

163 ImportEvent js base elm _ ->

160 ImportEvent js base elm _ ->

164 do v <- toJS' base

161 do v <- toJS' base

165 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"

162 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"

@@ -174,7 +171,7 @@ instance ToJS Statement where

174 , "document.dispatchEvent(e); return v; })(", elm, ");" ]

171 , "document.dispatchEvent(e); return v; })(", elm, ");" ]

175 TypeAlias n _ t -> return ""

172 TypeAlias n _ t -> return ""

176

173

177−toJS' :: CExpr -> GuidCounter String

174+toJS' :: LExpr t v -> Unique String

178toJS' (L txt span expr) =

175toJS' (L txt span expr) =

179 case expr of

176 case expr of

180 MultiIf ps -> multiIfToJS span ps

177 MultiIf ps -> multiIfToJS span ps

@@ -200,15 +197,21 @@ makeRecord kvs = record `liftM` collect kvs

200 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs

197 record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs

201

198

202

199

203−instance ToJS Expr where

200+instance ToJS Literal where

204− toJS expr =

201+ toJS lit =

205− case expr of

202+ case lit of

206− Var x -> return $ x

207 Chr c -> return $ quoted [c]

203 Chr c -> return $ quoted [c]

208 Str s -> return $ "_str" ++ parens (quoted s)

204 Str s -> return $ "_str" ++ parens (quoted s)

209 IntNum n -> return $ show n

205 IntNum n -> return $ show n

210 FloatNum n -> return $ show n

206 FloatNum n -> return $ show n

211 Boolean b -> return $ if b then "true" else "false"

207 Boolean b -> return $ if b then "true" else "false"

208+

209+

210+instance ToJS (Expr t v) where

211+ toJS expr =

212+ case expr of

213+ Var x -> return x

214+ Literal lit -> toJS lit

212 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

215 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

213 Access e x -> access x `liftM` toJS' e

216 Access e x -> access x `liftM` toJS' e

214 Remove e x -> remove x `liftM` toJS' e

217 Remove e x -> remove x `liftM` toJS' e

compiler/Gen/ExtractNoscript.hs → compiler/Generate/Noscript.hsrenamed+24−17

@@ -1,24 +1,24 @@

1−module ExtractNoscript (extractNoscript) where

1+module Generate.Noscript (noscript) where

3−import Ast

3+import Data.List (isInfixOf)

4−import Located

4+import SourceSyntax.Everything

5import qualified Text.Pandoc as Pan

7−extractNoscript :: Module -> String

7+noscript :: Module t v -> String

8−extractNoscript modul = concat (extract modul)

8+noscript modul = concat (extract modul)

10class Extract a where

11 extract :: a -> [String]

13−instance Extract Module where

13+instance Extract (Module t v) where

14 extract (Module _ _ _ stmts) =

15 map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)

17−instance Extract Statement where

17+instance Extract (Declaration t v) where

18 extract (Definition d) = extract d

19 extract _ = []

21−instance Extract Def where

21+instance Extract (Def t v) where

22 extract (FnDef _ _ e) = extract e

23 extract (OpDef _ _ _ e) = extract e

24 extract _ = []

@@ -26,21 +26,24 @@ instance Extract Def where

26instance Extract e => Extract (Located e) where

27 extract (L _ _ e) = extract e

29−instance Extract Expr where

29+instance Extract (Expr t v) where

30 extract expr =

31 let f = extract in

32 case expr of

33− Str s -> [s]

33+ Literal (Str s) -> [s]

34 Binop op e1 e2 -> case (op, f e1, f e2) of

35 ("++", [s1], [s2]) -> [s1 ++ s2]

36 (_ , ss1 , ss2 ) -> ss1 ++ ss2

37 Lambda v e -> f e

38− App (L _ _ (App (L _ _ (Var "link")) src)) txt -> linkExtract src txt

38+ App (L _ _ (App (L _ _ (App (L _ _ (Var func)) w)) h)) src

39+ | "image" `isInfixOf` func -> extractImage src

39− App (L _ _ (App (L _ _ (Var "Text.link")) src)) txt -> linkExtract src txt

40+ App (L _ _ (App (L _ _ (Var func)) src)) txt

41+ | "link" `isInfixOf` func -> extractLink src txt

42+ App (L _ _ (Var func)) e

40− App (L _ _ (Var "header")) e -> tag "h1" e

43+ | "header" `isInfixOf` func -> tag "h1" e

41− App (L _ _ (Var "bold")) e -> tag "b" e

44+ | "bold" `isInfixOf` func -> tag "b" e

42− App (L _ _ (Var "italic")) e -> tag "i" e

45+ | "italic" `isInfixOf` func -> tag "i" e

43− App (L _ _ (Var "monospace")) e -> tag "code" e

46+ | "monospace" `isInfixOf` func -> tag "code" e

44 App e1 e2 -> f e1 ++ f e2

47 App e1 e2 -> f e1 ++ f e2

45 Let defs e -> concatMap extract defs ++ f e

48 Let defs e -> concatMap extract defs ++ f e

46 Var _ -> []

49 Var _ -> []

@@ -50,10 +53,14 @@ instance Extract Expr where

50 Markdown doc -> [ Pan.writeHtmlString Pan.def doc ]

53 Markdown doc -> [ Pan.writeHtmlString Pan.def doc ]

51 _ -> []

54 _ -> []

53−linkExtract src txt =

56+extractLink src txt =

54 case (extract src, extract txt) of

57 case (extract src, extract txt) of

55 ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]

58 ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]

56 ( ss1, ss2) -> ss1 ++ ss2

59 ( ss1, ss2) -> ss1 ++ ss2

61+extractImage src =

62+ case extract src of

63+ [s] -> ["<img src=\"" ++ s ++ "\">"]

64+ ss -> ss

59tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)

66tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)

compiler/Initialize.hs+7−9

@@ -5,35 +5,33 @@ import Control.Monad.Error

5import Data.List (lookup,nub)

6import qualified Data.Map as Map

8−import Ast

8+import SourceSyntax.Everything

9−import Data.Either (lefts,rights)

10import Data.List (intercalate,partition)

9import Data.List (intercalate,partition)

11import Parse.Parser (parseProgram, parseDependencies)

10import Parse.Parser (parseProgram, parseDependencies)

12−import Rename

13−import qualified Libraries as Libs

11+import qualified Metadata.Libraries as Libs

14import Types.Types ((-:))

12import Types.Types ((-:))

15import Types.Hints (hints)

13import Types.Hints (hints)

16import Types.Unify (unify)

14import Types.Unify (unify)

17import Types.Alias (dealias, mistakes)

15import Types.Alias (dealias, mistakes)

18−import Optimize

16+import Transform.Optimize

19import System.Exit

17import System.Exit

20import System.FilePath

18import System.FilePath

22−checkMistakes :: Module -> Either String Module

20+checkMistakes :: Module t v -> Either String (Module t v)

23checkMistakes modul@(Module name ex im stmts) =

21checkMistakes modul@(Module name ex im stmts) =

24 case mistakes stmts of

22 case mistakes stmts of

25 m:ms -> Left (unlines (m:ms))

23 m:ms -> Left (unlines (m:ms))

26 [] -> return modul

24 [] -> return modul

28−checkTypes :: Module -> Either String Module

26+checkTypes :: Module t v -> Either String (Module t v)

29checkTypes modul =

27checkTypes modul =

30 do subs <- unify hints modul

28 do subs <- unify hints modul

31 subs `seq` return (optimize (renameModule modul))

29 subs `seq` return (optimize (renameModule modul))

33−check :: Module -> Either String Module

31+check :: Module t v -> Either String (Module t v)

34check = checkMistakes >=> checkTypes

32check = checkMistakes >=> checkTypes

36−buildFromSource :: Bool -> String -> Either String Module

34+buildFromSource :: Bool -> String -> Either String (Module t v)

37buildFromSource noPrelude src =

35buildFromSource noPrelude src =

38 let add = if noPrelude then id else Libs.addPrelude in

36 let add = if noPrelude then id else Libs.addPrelude in

39 (check . add) =<< (parseProgram src)

37 (check . add) =<< (parseProgram src)

compiler/Transform/Optimize.hs+60−57

@@ -1,10 +1,9 @@

1−module Optimize (optimize) where

1+module Transform.Optimize (optimize) where

3−import Ast

3+import SourceSyntax.Everything

4−import Located

5import Control.Arrow (second, (***))

4import Control.Arrow (second, (***))

6import Data.Char (isAlpha)

5import Data.Char (isAlpha)

7−import Substitute

6+import Transform.Substitute

9optimize (Module name ims exs stmts) =

8optimize (Module name ims exs stmts) =

10 Module name ims exs (map optimizeStmt stmts)

9 Module name ims exs (map optimizeStmt stmts)

@@ -15,12 +14,12 @@ optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'

15class Simplify a where

14class Simplify a where

16 simp :: a -> a

15 simp :: a -> a

18−instance Simplify Statement where

17+instance Simplify (Declaration t v) where

19 simp (Definition def) = Definition (simp def)

18 simp (Definition def) = Definition (simp def)

20 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t

19 simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t

21 simp stmt = stmt

20 simp stmt = stmt

23−instance Simplify Def where

22+instance Simplify (Def t v) where

24 simp (FnDef func args e) = FnDef func args (simp e)

23 simp (FnDef func args e) = FnDef func args (simp e)

25 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)

24 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)

26 simp x = x

25 simp x = x

@@ -28,12 +27,12 @@ instance Simplify Def where

28instance Simplify e => Simplify (Located e) where

27instance Simplify e => Simplify (Located e) where

29 simp (L t s e) = L t s (simp e)

28 simp (L t s e) = L t s (simp e)

31−instance Simplify Expr where

30+instance Simplify (Expr t v) where

32 simp expr =

31 simp expr =

33 let f = simp in

32 let f = simp in

34 case expr of

33 case expr of

35 Range e1 e2 -> Range (f e1) (f e2)

34 Range e1 e2 -> Range (f e1) (f e2)

36− Binop op e1 e2 -> simp_binop op (f e1) (f e2)

35+ Binop op e1 e2 -> binop op (f e1) (f e2)

37 Lambda x e -> Lambda x (f e)

36 Lambda x e -> Lambda x (f e)

38 Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)

37 Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)

39 App (L t s (Lambda x e1)) e2 ->

38 App (L t s (Lambda x e1)) e2 ->

@@ -51,41 +50,43 @@ instance Simplify Expr where

51clipBranches [] = []

50clipBranches [] = []

52clipBranches (e:es) =

51clipBranches (e:es) =

53 case e of

52 case e of

54− (L _ _ (Boolean True), _) -> [e]

53+ (L _ _ (Literal (Boolean True)), _) -> [e]

55 _ -> e : clipBranches es

54 _ -> e : clipBranches es

58isValue e =

57isValue e =

59− case e of { IntNum _ -> True

58+ case e of

60− ; FloatNum _ -> True

59+ Literal _ -> True

61− ; Chr _ -> True

62− ; Str _ -> True

63− ; Boolean _ -> True

64− ; Var _ -> True

60+ Var _ -> True

65− ; Data _ _ -> True

61+ Data _ _ -> True

66− ; _ -> False }

62+ _ -> False

68−simp_binop = binop

70binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =

65binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =

71− let c1 = L t1 s1 in

66+ let c1 = L t1 s1

72− let c2 = L t2 s2 in

67+ c2 = L t2 s2

68+ int = Literal . IntNum

69+ str = Literal . Str

70+ bool = Literal . Boolean

71+ in

73 case (op, e1, e2) of

72 case (op, e1, e2) of

74− (_, IntNum n, IntNum m) -> case op of

73+ (_, Literal (IntNum n), Literal (IntNum m)) ->

75− { "+" -> IntNum $ (+) n m

74+ case op of

76− ; "-" -> IntNum $ (-) n m

75+ { "+" -> int $ (+) n m

77− ; "*" -> IntNum $ (*) n m

76+ ; "-" -> int $ (-) n m

78− ; "^" -> IntNum $ n ^ m

77+ ; "*" -> int $ (*) n m

78+ ; "^" -> int $ n ^ m

79− ; "div" -> IntNum $ div n m

79+ ; "div" -> int $ div n m

80− ; "mod" -> IntNum $ mod n m

80+ ; "mod" -> int $ mod n m

81− ; "<" -> Boolean $ n < m

81+ ; "rem" -> int $ rem n m

82− ; ">" -> Boolean $ n < m

82+ ; "<" -> bool $ n < m

83− ; "<=" -> Boolean $ n <= m

83+ ; ">" -> bool $ n < m

84− ; ">=" -> Boolean $ n >= m

84+ ; "<=" -> bool $ n <= m

85− ; "==" -> Boolean $ n == m

85+ ; ">=" -> bool $ n >= m

86− ; "/=" -> Boolean $ n /= m

86+ ; "==" -> bool $ n == m

87+ ; "/=" -> bool $ n /= m

87− ; _ -> Binop op ce1 ce2 }

88+ ; _ -> Binop op ce1 ce2 }

88−

89+ {--

89 -- flip order to move lone integers to the left

90 -- flip order to move lone integers to the left

90 ("+", _, IntNum n) -> binop "+" ce2 ce1

91 ("+", _, IntNum n) -> binop "+" ce2 ce1

91 ("*", _, IntNum n) -> binop "*" ce2 ce1

92 ("*", _, IntNum n) -> binop "*" ce2 ce1

@@ -95,47 +96,49 @@ binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =

95 binop "+" (c1 $ IntNum (n+m)) ce

96 binop "+" (c1 $ IntNum (n+m)) ce

96 ("+", Binop "+" (L _ _ (IntNum n)) ce1'

97 ("+", Binop "+" (L _ _ (IntNum n)) ce1'

97 , Binop "+" (L _ _ (IntNum m)) ce2') ->

98 , Binop "+" (L _ _ (IntNum m)) ce2') ->

98− binop "+" (notLocated $ IntNum (n+m)) (notLocated $ Binop "+" ce1' ce2')

99+ binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')

100

100 ("*", IntNum 0, _) -> e1

101 ("*", IntNum 0, _) -> e1

101 ("*", IntNum 1, _) -> e2

102 ("*", IntNum 1, _) -> e2

102 ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->

103 ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->

103− binop "*" (notLocated $ IntNum (n*m)) ce

104+ binop "*" (none $ IntNum (n*m)) ce

104 ("*", Binop "*" (L _ _ (IntNum n)) ce1'

105 ("*", Binop "*" (L _ _ (IntNum n)) ce1'

105 , Binop "*" (L _ _ (IntNum m)) ce2') ->

106 , Binop "*" (L _ _ (IntNum m)) ce2') ->

106− binop "*" (notLocated $ IntNum (n*m)) (notLocated $ Binop "*" ce1' ce2')

107+ binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')

107

108

108 ("-", _, IntNum 0) -> e1

109 ("-", _, IntNum 0) -> e1

109 ("/", _, IntNum 1) -> e1

110 ("/", _, IntNum 1) -> e1

110 ("div", _, IntNum 1) -> e1

111 ("div", _, IntNum 1) -> e1

111−

112+--}

112− (_, Boolean n, Boolean m) -> case op of "&&" -> Boolean $ n && m

113+ (_, Literal (Boolean n), Literal (Boolean m)) ->

113− "||" -> Boolean $ n || m

114+ case op of

115+ "&&" -> bool $ n && m

116+ "||" -> bool $ n || m

114− _ -> Binop op ce1 ce2

117+ _ -> Binop op ce1 ce2

115−

118+

116− ("&&", Boolean True, _) -> e2

119+ ("&&", Literal (Boolean True), _) -> e2

117− ("&&", Boolean False, _) -> Boolean False

120+ ("&&", Literal (Boolean False), _) -> bool False

118− ("||", Boolean True, _) -> Boolean True

121+ ("||", Literal (Boolean True), _) -> bool True

119− ("||", Boolean False, _) -> e2

122+ ("||", Literal (Boolean False), _) -> e2

120

123

121 ("::", _, _) -> let (L _ _ e) = cons ce1 ce2 in e

124 ("::", _, _) -> let (L _ _ e) = cons ce1 ce2 in e

122

125

123− ("++", Str s1, Str s2) -> Str $ s1 ++ s2

126+ ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2

124− ("++", Str s1, Binop "++" (L _ _ (Str s2)) ce) ->

127+ ("++", Literal (Str s1), Binop "++" (L _ _ (Literal (Str s2))) ce) ->

125− Binop "++" (c1 $ Str $ s1 ++ s2) ce

128+ Binop "++" (c1 . str $ s1 ++ s2) ce

126− ("++", Binop "++" e (L _ _ (Str s1)), Str s2) ->

129+ ("++", Binop "++" e (L _ _ (Literal (Str s1))), Literal (Str s2)) ->

127− Binop "++" e (c1 $ Str $ s1 ++ s2)

130+ Binop "++" e (c1 . str $ s1 ++ s2)

128

131

129 ("++", Data "Nil" [], _) -> e2

132 ("++", Data "Nil" [], _) -> e2

130 ("++", _, Data "Nil" []) -> e1

133 ("++", _, Data "Nil" []) -> e1

131− ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, notLocated $ binop "++" t ce2]

134+ ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, none $ binop "++" t ce2]

132

135

133 ("|>", _, _) -> App ce2 ce1

136 ("|>", _, _) -> App ce2 ce1

134 ("<|", _, _) -> App ce1 ce2

137 ("<|", _, _) -> App ce1 ce2

135 (".", _, _) ->

138 (".", _, _) ->

136− Lambda "x" (notLocated $

139+ Lambda "x" (none $

137− App ce1 (notLocated $ App ce2 (notLocated $ Var "x")))

140+ App ce1 (none $ App ce2 (none $ Var "x")))

138

141

139 _ | isAlpha (head op) || '_' == head op ->

142 _ | isAlpha (head op) || '_' == head op ->

140− App (notLocated $ App (notLocated $ Var op) ce1) ce2

143+ App (none $ App (none $ Var op) ce1) ce2

141− | otherwise -> Binop op ce1 ce2

144+ | otherwise -> Binop op ce1 ce2

compiler/Transform/Substitute.hs+4−4

@@ -1,10 +1,10 @@

1−module Substitute (subst) where

1+module Transform.Substitute (subst) where

3−import Ast

3+import SourceSyntax.Expression

4−import Located

4+import SourceSyntax.Location

5import Control.Arrow (second, (***))

7−subst :: String -> Expr -> Expr -> Expr

7+subst :: String -> Expr t v -> Expr t v -> Expr t v

8subst old new expr =

9 let f (L t s e) = L t s (subst old new e) in

10 case expr of

compiler/Types/Alias.hs+59−54

@@ -1,16 +1,15 @@

1{-# LANGUAGE PatternGuards #-}

2module Types.Alias (dealias, get, mistakes) where

4−import Ast

4+import SourceSyntax.Everything

5−import Located

6import Control.Arrow (second)

5import Control.Arrow (second)

7import Data.List (group,sort)

6import Data.List (group,sort)

8−import Data.Maybe (mapMaybe)

9import qualified Data.Map as Map

7import qualified Data.Map as Map

10import qualified Data.Set as Set

8import qualified Data.Set as Set

11import Types.Substitutions (subst)

9import Types.Substitutions (subst)

12import Types.Types

10import Types.Types

13import Data.Generics.Uniplate.Data

11import Data.Generics.Uniplate.Data

12+import Data.Data

15builtins :: [(String,([X],Type))]

14builtins :: [(String,([X],Type))]

16builtins =

15builtins =

@@ -30,7 +29,7 @@ builtins =

30 ("LineStyle", ([], makeRecord line))

29 ("LineStyle", ([], makeRecord line))

31 ]

30 ]

33−get :: [Statement] -> Map.Map String ([X],Type)

32+get :: [Declaration t v] -> Map.Map String ([X],Type)

34get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)

33get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)

35 where getAlias stmt = case stmt of

34 where getAlias stmt = case stmt of

36 TypeAlias alias xs t -> [(alias, (xs,t))]

35 TypeAlias alias xs t -> [(alias, (xs,t))]

@@ -47,63 +46,74 @@ dealias aliases t =

47 RecordT r t -> RecordT (Map.map (map f) r) (f t)

46 RecordT r t -> RecordT (Map.map (map f) r) (f t)

48 _ -> t

47 _ -> t

50−mistakes :: [Statement] -> [String]

49+mistakes :: [Declaration t v] -> [String]

51mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts

50mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts

53−badKinds :: [Statement] -> [String]

52+badKinds :: [Declaration t v] -> [String]

54−badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]

53+badKinds stmts = map msg (concatMap badS stmts)

55 where

54 where

56 msg x = "Type Error: Type alias '" ++ x ++

55 msg x = "Type Error: Type alias '" ++ x ++

57 "' was given the wrong number of arguments."

56 "' was given the wrong number of arguments."

59 badT :: Type -> [String]

58 badT :: Type -> [String]

59+ badT t =

60+ case t of

60− badT (ADT name ts)

61+ ADT name ts ->

61− | Just (xs, _) <- Map.lookup name (get stmts),

62+ case Map.lookup name (get stmts) of

62− length xs /= length ts = [name]

63+ Just (xs,t) | length xs == length ts -> []

63− badT _ = []

64+ | otherwise -> [name]

64−

65+ Nothing -> concatMap badT ts

66+ LambdaT t u -> badT t ++ badT u

67+ RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))

68+ _ -> []

69+

70+ badS :: Declaration t v -> [String]

71+ badS s =

72+ case s of

73+ Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)

74+ ExportEvent _ _ tipe -> badT tipe

75+ ImportEvent _ _ _ tipe -> badT tipe

76+ TypeAlias _ _ tipe -> badT tipe

77+ Definition d ->

78+ case d of

79+ TypeAnnotation _ tipe -> badT tipe

80+ _ -> []

81+

65−annotation :: Def -> Maybe String

82+annotation :: Declaration t v -> [String]

66annotation s =

83annotation s =

67 case s of

84 case s of

68− TypeAnnotation name _ -> Just name

85+ Definition (TypeAnnotation name _) -> [name]

69− _ -> Nothing

86+ _ -> []

71−definition :: Def -> Maybe String

88+definition :: Declaration t v -> [String]

72definition s =

89definition s =

73 case s of

90 case s of

74− FnDef name _ _ -> Just name

75− OpDef name _ _ _ -> Just name

76− _ -> Nothing

77−

78−checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]

79−checkTopLevelAndLets stmts fcheck =

80− fcheck "at top-level" topLevelDefs ++

81− concatMap (fcheck "in let binding") allLetDefs

82− where

83− topLevelDefs = mapMaybe maybeDef stmts

84− maybeDef (Definition d) = Just d

91+ Definition d -> [defName d]

85− maybeDef _ = Nothing

92+ _ -> []

86− allLetDefs = [defList | Let defList _ <- universeBi stmts]

88−dups :: [Statement] -> [String]

94+defName :: Def t v -> String

89−dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

95+defName d =

90− let

96+ case d of

97+ FnDef n _ _ -> n

98+ OpDef n _ _ _ -> n

99+

100+dups :: [Declaration t v] -> [String]

101+dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)

102+ where

91− dup :: (Def -> Maybe String) -> [String]

103+ --dup :: (Declaration t v -> [String]) -> [String]

92− dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs

104+ dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts

105

94 msg = "Syntax Error: There can only be one "

106 msg = "Syntax Error: There can only be one "

95− defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."

107+ defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."

96− annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."

108+ annMsg x = msg ++ "type annotation for '" ++ x ++ "'."

97− in

109+

98− map defMsg (dup definition) ++ map annMsg (dup annotation)

99−

100−badOrder :: [Statement] -> [String]

110+badOrder :: [Declaration t v] -> [String]

101−badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

111+badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)

102− let

112+ where

103 msg x = "Syntax Error: The type annotation for '" ++ x ++

113 msg x = "Syntax Error: The type annotation for '" ++ x ++

104− "' must be directly above its definition in " ++ ctxt ++ "."

114+ "' must be directly above its definition."

105− as = sort $ mapMaybe annotation defs

115+ as = sort $ concatMap annotation stmts

106− ds = sort $ mapMaybe definition defs

116+ ds = sort $ concatMap definition stmts

107

117

108 expectedPairs :: [String] -> [String] -> [String]

118 expectedPairs :: [String] -> [String] -> [String]

109 expectedPairs as ds =

119 expectedPairs as ds =

@@ -114,14 +124,11 @@ badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

114 GT -> expectedPairs (x:xs) ys

124 GT -> expectedPairs (x:xs) ys

115 ( _ , _ ) -> []

125 ( _ , _ ) -> []

116

126

117− actualPairs :: [Def] -> [String]

127+ --actualPairs :: [Declaration t v] -> [String]

118 actualPairs stmts =

128 actualPairs stmts =

119 case stmts of

129 case stmts of

120− TypeAnnotation n _ : rest@(d : _) ->

130+ Definition (TypeAnnotation n _) : Definition d : rest ->

121− (if Just n == definition d

122− then [n]

123− else []

124− ) ++ actualPairs rest

131+ (if n == defName d then [n] else []) ++ actualPairs rest

125 t:s:rest -> actualPairs (s:rest)

132 t:s:rest -> actualPairs (s:rest)

126 _ -> []

133 _ -> []

127

134

@@ -133,6 +140,4 @@ badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->

133 EQ -> missings es as

140 EQ -> missings es as

134 GT -> a : missings (e:es) as

141 GT -> a : missings (e:es) as

135 ( [] , _ ) -> actual

142 ( [] , _ ) -> actual

136− ( _ , [] ) -> expected

143+ ( _ , [] ) -> expected

137− in

138− map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)

compiler/Types/Constrain.hs+23−23

@@ -9,9 +9,8 @@ import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)

9import qualified Data.Map as Map

10import qualified Data.Set as Set

12−import Ast

12+import SourceSyntax.Everything

13−import Located

13+import Unique

14−import Guid

16import Types.Types

15import Types.Types

17import qualified Types.Substitutions as Subs

16import qualified Types.Substitutions as Subs

@@ -55,7 +54,7 @@ findAmbiguous hints assumptions continue =

55 _ -> continue

54 _ -> continue

57mergeSchemes :: [Map.Map String Scheme]

56mergeSchemes :: [Map.Map String Scheme]

58− -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)

57+ -> Unique (TVarMap, Constraints, Map.Map String Scheme)

59mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs

58mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs

60 return (Map.unions ass, concat css, Map.unions sss)

59 return (Map.unions ass, concat css, Map.unions sss)

61 where

60 where

@@ -73,7 +72,7 @@ mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs

74--constrain :: Map.Map String Scheme

73--constrain :: Map.Map String Scheme

75-- -> Module

74-- -> Module

76−-- -> GuidCounter (Either String Constraints)

75+-- -> Unique (Either String Constraints)

77constrain typeHints (Module _ _ imports stmts) = do

76constrain typeHints (Module _ _ imports stmts) = do

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

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

79 aliasHints <- getAliases imports `liftM` typeHints

78 aliasHints <- getAliases imports `liftM` typeHints

@@ -98,7 +97,7 @@ type Constraints = [Located Constraint]

99loc e span = L (Just $ show e) span

98loc e span = L (Just $ show e) span

100

101−gen :: CExpr -> GuidCounter (TVarMap, Constraints, Type)

100+gen :: LExpr t v -> Unique (TVarMap, Constraints, Type)

102gen (L _ span expr) =

101gen (L _ span expr) =

103 let loc' = L (Just $ show expr) span in

102 let loc' = L (Just $ show expr) span in

104 case expr of

103 case expr of

@@ -145,14 +144,14 @@ gen (L _ span expr) =

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

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

146 return ( unionsA $ as:ass

145 return ( unionsA $ as:ass

147 , let cases' = map snd cases

146 , let cases' = map snd cases

148− locs = zipWith epos cases' (tail cases')

147+ locs = zipWith merge cases' (tail cases')

149 csts = zipWith (:=:) ts (tail ts)

148 csts = zipWith (:=:) ts (tail ts)

150 cs' = zipWith ($) locs csts

149 cs' = zipWith ($) locs csts

151 in concat $ cs' : cs : css

150 in concat $ cs' : cs : css

152 , head ts)

151 , head ts)

153

152

154 Data name es ->

153 Data name es ->

155− gen $ foldl' (\f x -> epos f x $ App f x) (loc' $ Var name) es

154+ gen $ foldl' (\f x -> merge f x $ App f x) (loc' $ Var name) es

156

155

157 Binop op e1 e2 ->

156 Binop op e1 e2 ->

158 gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)

157 gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)

@@ -215,22 +214,23 @@ gen (L _ span expr) =

215 , c1 ++ c2 ++ [ L t s (t1 :=: bool) ]

214 , c1 ++ c2 ++ [ L t s (t1 :=: bool) ]

216 , t2 )

215 , t2 )

217

216

218− IntNum _ -> do t <- beta

219− return (Map.empty, [loc' $ t :<: number], t)

220−

221− FloatNum _ -> primitive float

222− Chr _ -> primitive char

223− Str _ -> primitive string

224− Boolean _ -> primitive bool

225 Markdown _ -> primitive element

217 Markdown _ -> primitive element

218+ Literal lit ->

219+ case lit of

220+ IntNum _ -> do t <- beta

221+ return (Map.empty, [loc' $ t :<: number], t)

222+ FloatNum _ -> primitive float

223+ Chr _ -> primitive char

224+ Str _ -> primitive string

225+ Boolean _ -> primitive bool

226

227

228−primitive :: Type -> GuidCounter (TVarMap, Constraints, Type)

228+primitive :: Type -> Unique (TVarMap, Constraints, Type)

229primitive t = return (Map.empty, [], t)

230

231caseGen :: Type

232− -> (Pattern, CExpr)

232+ -> (Pattern, LExpr t v)

233− -> GuidCounter (TVarMap, Constraints, Type)

233+ -> Unique (TVarMap, Constraints, Type)

234caseGen tipe (p, ce@(L _ span e)) = do

235 (as ,cs ,t) <- gen ce

236 (as',cs',_) <- patternGen (loc p span) tipe as p

@@ -240,7 +240,7 @@ patternGen :: (Constraint -> Located Constraint)

240 -> Type -- Type of e in `case e of ...`

241 -> TVarMap

242 -> Pattern

243− -> GuidCounter (TVarMap, Constraints, Type)

243+ -> Unique (TVarMap, Constraints, Type)

244patternGen loc tipe as pattern =

245 case pattern of

246 PAnything -> do b <- beta ; return ( as, [], b )

@@ -250,7 +250,7 @@ patternGen loc tipe as pattern =

250 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)

251 return ( Map.delete v as, loc (b :=: tipe) : cs, b )

252

253− PAsVar v p -> do

253+ PAlias v p -> do

254 b <- beta

255 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)

256 (as', cs', tipe') <- patternGen loc b as p

@@ -279,7 +279,7 @@ patternGen loc tipe as pattern =

279 , t )

280

281

282−defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)

282+defScheme :: Def t v -> Unique (Map.Map String [X], Scheme)

283defScheme def = do (as,cs,hint) <- defGen def

284 return ( as, snd hint )

285

@@ -305,8 +305,8 @@ defGenHelp name args e = do

305 return ( as', [], (name, scheme) )

306

307

308−stmtGen :: Statement

308+stmtGen :: Declaration t v

309− -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)

309+ -> Unique (TVarMap, Constraints, Map.Map String Scheme)

310stmtGen stmt =

311 case stmt of

312 Definition def -> do (as,cs,hint) <- defGen def

compiler/Types/Hints.hs+6−6

@@ -4,14 +4,14 @@ import Control.Arrow (first)

4import Control.Monad (liftM)

5import Data.Maybe (catMaybes)

6import qualified Data.Map as Map

7−import Guid

7+import Unique

8−import qualified Libraries as Libs

8+import qualified Metadata.Libraries as Libs

9−import Parse.Library (iParse)

9+import Parse.Helpers (iParse)

10−import Parse.Types

10+import Parse.Type

11import qualified Types.Substitutions as Subs

12import Types.Types

14−hints :: GuidCounter [(String, Scheme)]

14+hints :: Unique [(String, Scheme)]

15hints = liftM catMaybes (mapM toScheme values)

16 where

17 values :: [(String, String)]

@@ -20,7 +20,7 @@ hints = liftM catMaybes (mapM toScheme values)

20 addPrefixes :: [(String,[(String, String)])] -> [(String, String)]

21 addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)

23− toScheme :: (String, String) -> GuidCounter (Maybe (String, Scheme))

23+ toScheme :: (String, String) -> Unique (Maybe (String, Scheme))

24 toScheme (name, 't':'y':'p':'e':' ':_) = return Nothing

25 toScheme (name, 'd':'a':'t':'a':' ':_) = return Nothing

26 toScheme (name, tipeString) =

compiler/Types/Solver.hs+6−6

@@ -1,7 +1,7 @@

2module Types.Solver (solver) where

4−import Located

4+import SourceSyntax.Everything

5import Control.Arrow (second)

6import Control.Monad (liftM)

7import Data.Either (lefts,rights)

@@ -9,7 +9,7 @@ import Data.List (foldl')

9import Data.Maybe (isJust)

10import qualified Data.Set as Set

11import qualified Data.Map as Map

12−import Guid

12+import Unique

13import Types.Types

14import Types.Substitutions

15import Types.Alias (dealias)

@@ -22,7 +22,7 @@ isSolved ss c = False

23type Aliases = Map.Map String ([X],Type)

25−crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)

25+crush :: Aliases -> Scheme -> Unique (Either String Scheme)

26crush aliases forall@(Forall xs cs t) =

27 do subs <- solver aliases Map.empty cs

28 return $ do ss' <- subs

@@ -68,11 +68,11 @@ recordConstraints eq fs t fs' t' =

68 Map.difference fs' fs

69 ]

70 where constrain :: Map.Map String [Type] -> Map.Map String [Type]

71− -> GuidCounter [Located Constraint]

71+ -> Unique [Located Constraint]

72 constrain as bs = liftM concat . sequence . Map.elems $

73 Map.intersectionWithKey (zipper []) as bs

74 zipper :: [Located Constraint] -> String -> [Type] -> [Type]

75− -> GuidCounter [Located Constraint]

75+ -> Unique [Located Constraint]

76 zipper cs k xs ys =

77 case (xs,ys) of

78 (a:as, b:bs) -> zipper (eq a b : cs) k as bs

@@ -87,7 +87,7 @@ recordConstraints eq fs t fs' t' =

87solver :: Aliases

88 -> Map.Map X Type

89 -> [Located Constraint]

90− -> GuidCounter (Either String (Map.Map X Type))

90+ -> Unique (Either String (Map.Map X Type))

91solver _ subs [] = return $ Right subs

92solver aliases subs (L txt span c : cs) =

93 let loc = L txt span

compiler/Types/Substitutions.hs+6−7

@@ -7,14 +7,13 @@ module Types.Substitutions (subst,

7 generalize,

8 superize) where

10−import Ast

10+import SourceSyntax.Everything

11−import Located

12import Control.Monad (liftM, liftM2)

11import Control.Monad (liftM, liftM2)

13import Control.Monad.State (runState, State, get, put)

12import Control.Monad.State (runState, State, get, put)

14import Data.List (nub)

13import Data.List (nub)

15import qualified Data.Set as Set

14import qualified Data.Set as Set

16import qualified Data.Map as Map

15import qualified Data.Map as Map

17−import Guid

16+import Unique

18import Types.Types

17import Types.Types

20class Subst a where

19class Subst a where

@@ -78,18 +77,18 @@ instance FreeVars a => FreeVars [a] where

79occurs x t = x `elem` freeVars t

78occurs x t = x `elem` freeVars t

81−concretize :: Scheme -> GuidCounter (Type, [Located Constraint])

80+concretize :: Scheme -> Unique (Type, [Located Constraint])

82concretize (Forall xs cs t) = do

81concretize (Forall xs cs t) = do

83 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs

82 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs

84 return (subst ss t, subst ss cs)

83 return (subst ss t, subst ss cs)

86−rescheme :: Scheme -> GuidCounter Scheme

85+rescheme :: Scheme -> Unique Scheme

87rescheme (Forall xs cs t) = do

86rescheme (Forall xs cs t) = do

88 xs' <- mapM (const guid) xs

87 xs' <- mapM (const guid) xs

89 let ss = zip xs (map VarT xs')

88 let ss = zip xs (map VarT xs')

90 return $ Forall xs' (subst ss cs) (subst ss t)

89 return $ Forall xs' (subst ss cs) (subst ss t)

92−generalize :: [X] -> Scheme -> GuidCounter Scheme

91+generalize :: [X] -> Scheme -> Unique Scheme

93generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

92generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

94 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs

93 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs

95 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

94 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

@@ -97,7 +96,7 @@ generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

97newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }

96newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }

98 deriving (Monad)

97 deriving (Monad)

100−superize :: String -> Type -> GuidCounter Scheme

99+superize :: String -> Type -> Unique Scheme

101superize name tipe =

100superize name tipe =

102 do constraints <- liftM concat $

101 do constraints <- liftM concat $

103 sequence [ mapM (<: nmbr) (nub ns)

102 sequence [ mapM (<: nmbr) (nub ns)

compiler/Types/Unify.hs+2−2

@@ -4,8 +4,8 @@ module Types.Unify (unify) where

4import Control.Monad (liftM)

5import qualified Data.Map as Map

7−import Ast

7+import SourceSyntax.Module

8−import Guid

8+import Unique

9import qualified Types.Constrain as Constrain

10import qualified Types.Solver as Solver

11import qualified Types.Alias as Alias