ac71ab1 · elk · git.iko.soy

Elm.cabal+2

compare with master

unifiedsplit

@@ -63,6 +63,7 @@ Library

63 Parse.Parse,

64 Parse.Pattern,

65 Parse.Type,

66+ Type.Alias,

66 Type.Constrain.Declaration,

67 Type.Constrain.Declaration,

67 Type.Constrain.Expression,

68 Type.Constrain.Expression,

68 Type.Constrain.Literal,

69 Type.Constrain.Literal,

@@ -132,6 +133,7 @@ Executable elm

132 Parse.Parse,

133 Parse.Parse,

133 Parse.Pattern,

134 Parse.Pattern,

134 Parse.Type,

135 Parse.Type,

136+ Type.Alias,

135 Type.Constrain.Declaration,

137 Type.Constrain.Declaration,

136 Type.Constrain.Expression,

138 Type.Constrain.Expression,

137 Type.Constrain.Literal,

139 Type.Constrain.Literal,

changelog.txt+8

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

1

2+Release 0.9.1

3+=============

4+

5+ * Switch to Tango color scheme, adding a bunch of nice colors

6+ * add the greyscale function for easily producing greys

7+ * Fix miscellaneous bugs in type checker

8+ * Switch name of Matrix2D to Transform2D

9+

2Release 0.9

10Release 0.9

3===========

11===========

4

12

compiler/Compiler.hs+6−7

@@ -31,7 +31,7 @@ import Paths_Elm

31import SourceSyntax.PrettyPrint (pretty, variable)

32import Text.PrettyPrint as P

33import qualified Type.Type as Type

34−import qualified Data.Traversable as Traverse

34+import qualified Type.Alias as Alias

35

36data Flags =

37 Flags { make :: Bool

@@ -146,10 +146,9 @@ buildFile flags moduleNum numModules interfaces filePath =

146 True -> print . pretty $ program modul

147 return modul

148

149− if print_types flags then printTypes metaModule else return ()

149+ if print_types flags then printTypes interfaces metaModule else return ()

150− tipes <- Traverse.traverse Type.toSrcType (types metaModule)

151 let interface = Canonical.interface name $ ModuleInterface {

150 let interface = Canonical.interface name $ ModuleInterface {

152− iTypes = tipes,

151+ iTypes = types metaModule,

153 iAdts = datatypes metaModule,

152 iAdts = datatypes metaModule,

154 iAliases = aliases metaModule

153 iAliases = aliases metaModule

155 }

154 }

@@ -160,11 +159,11 @@ buildFile flags moduleNum numModules interfaces filePath =

160 writeFile (elmo flags filePath) (jsModule metaModule)

159 writeFile (elmo flags filePath) (jsModule metaModule)

161 return (name,interface)

160 return (name,interface)

162

161

163−printTypes metaModule = do

162+printTypes interfaces metaModule = do

164 putStrLn ""

163 putStrLn ""

164+ let rules = Alias.rules interfaces metaModule

165 forM_ (Map.toList $ types metaModule) $ \(n,t) -> do

166− pt <- Type.extraPretty t

167− print $ variable n <+> P.text ":" <+> pt

166+ print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)

168 putStrLn ""

167 putStrLn ""

169

168

170getRuntime :: Flags -> IO FilePath

169getRuntime :: Flags -> IO FilePath

compiler/Initialize.hs−1

@@ -11,7 +11,6 @@ import System.FilePath as FP

11import Text.PrettyPrint (Doc)

12

13import SourceSyntax.Everything

14−import SourceSyntax.Type

15import qualified Parse.Parse as Parse

14import qualified Parse.Parse as Parse

16import qualified Metadata.Prelude as Prelude

15import qualified Metadata.Prelude as Prelude

17import qualified Transform.Check as Check

16import qualified Transform.Check as Check

compiler/SourceSyntax/Module.hs+1−2

@@ -12,7 +12,6 @@ import SourceSyntax.Expression (LExpr)

12import SourceSyntax.Declaration

13import SourceSyntax.Type

14import System.FilePath (joinPath)

15−import qualified Type.Type as Type

16

15

17data Module tipe var =

16data Module tipe var =

18 Module [String] Exports Imports [Declaration tipe var]

17 Module [String] Exports Imports [Declaration tipe var]

@@ -30,7 +29,7 @@ data MetadataModule t v = MetadataModule {

30 exports :: [String],

29 exports :: [String],

31 imports :: [(String, ImportMethod)],

30 imports :: [(String, ImportMethod)],

32 program :: LExpr t v,

31 program :: LExpr t v,

33− types :: Map.Map String Type.Variable,

32+ types :: Map.Map String Type,

34 fixities :: [(Assoc, Int, String)],

33 fixities :: [(Assoc, Int, String)],

35 aliases :: [(String, [String], Type)],

34 aliases :: [(String, [String], Type)],

36 datatypes :: [ (String, [String], [(String,[Type])]) ],

35 datatypes :: [ (String, [String], [(String,[Type])]) ],

compiler/SourceSyntax/Type.hs+12−1

@@ -41,8 +41,11 @@ instance Pretty Type where

41 | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

42 | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

43 EmptyRecord -> P.braces P.empty

44+ Record _ _ -> P.braces $ case ext of

45+ EmptyRecord -> prettyFields

44− Record fields ext -> P.braces $ P.hang (pretty ext <+> P.text "|") 4 prettyFields

46+ _ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields

45 where

47 where

48+ (fields, ext) = collectRecords tipe

46 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

49 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

47 prettyFields = commaSep . map prettyField $ fields

50 prettyFields = commaSep . map prettyField $ fields

48

51

@@ -52,11 +55,19 @@ collectLambdas tipe =

52 Lambda arg body -> pretty arg : collectLambdas body

55 Lambda arg body -> pretty arg : collectLambdas body

53 _ -> [pretty tipe]

56 _ -> [pretty tipe]

54

57

58+collectRecords = go []

59+ where

60+ go fields tipe =

61+ case tipe of

62+ Record fs ext -> go (fs ++ fields) ext

63+ _ -> (fields, tipe)

64+

55prettyParens tipe = parensIf needed (pretty tipe)

65prettyParens tipe = parensIf needed (pretty tipe)

56 where

66 where

57 needed =

67 needed =

58 case tipe of

68 case tipe of

59 Lambda _ _ -> True

69 Lambda _ _ -> True

70+ Data "_List" [_] -> False

60 Data _ [] -> False

71 Data _ [] -> False

61 Data _ _ -> True

72 Data _ _ -> True

62 _ -> False

73 _ -> False

compiler/Type/Alias.hsnew file+119

@@ -0,0 +1,119 @@

1+module Type.Alias (realias, rules, canonicalRealias, Rules) where

2+

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

4+import Control.Monad

5+import Control.Arrow (second)

6+import Data.Map ((!))

7+import qualified Data.Map as Map

8+import qualified Data.List as List

9+import SourceSyntax.Type

10+import SourceSyntax.Module

11+

12+type Rules = ([(String,[String],Type)], Type -> Type)

13+

14+rules interfaces metaModule = (collect interfaces metaModule, localizer metaModule)

15+

16+collect interfaces metaModule = filter (not . isPrimitive) rawAliases

17+ where

18+ rawAliases = aliases metaModule ++ concatMap iAliases (Map.elems interfaces)

19+

20+ isPrimitive (_,_,tipe) =

21+ case tipe of

22+ Data _ [] -> True

23+ _ -> False

24+

25+localizer metaModule = go

26+ where

27+ go tipe =

28+ case tipe of

29+ Var _ -> tipe

30+ EmptyRecord -> tipe

31+ Lambda t1 t2 -> Lambda (go t1) (go t2)

32+ Data name ts -> Data (localize name) (map go ts)

33+ Record fs ext -> Record (map (second go) fs) (go ext)

34+

35+ byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d) Map.empty (imports metaModule)

36+

37+ separate name =

38+ case List.elemIndices '.' name of

39+ [] -> ("",name)

40+ is -> let i = last is in

41+ (take i name, drop (i+1) name)

42+

43+ shortest = List.minimumBy (\a b -> compare (length a) (length b))

44+

45+ localize name = shortest (name : concatMap (localize' value) methods)

46+ where (modul, value) = separate name

47+ methods = Map.findWithDefault [] modul byMethod

48+

49+ localize' name method =

50+ case method of

51+ As modul -> [modul ++ "." ++ name]

52+ Hiding xs | name `notElem` xs -> [name]

53+ Importing xs | name `elem` xs -> [name]

54+ _ -> []

55+

56+realias :: Rules -> Type -> Type

57+realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

58+

59+canonicalRealias :: [(String,[String],Type)] -> Type -> Type

60+canonicalRealias aliases tipe =

61+ case concatMap tryRealias aliases of

62+ [tipe''] -> f tipe''

63+ _ -> if tipe == tipe' then tipe else f tipe'

64+ where

65+ tryRealias (name, args, t) =

66+ case diff t tipe of

67+ Nothing -> []

68+ Just kvs ->

69+ let holes = collectFields kvs

70+ hasArgs = List.sort args == Map.keys holes

71+ isConsistent = all allEqual (Map.elems holes)

72+ in case hasArgs && isConsistent of

73+ False -> []

74+ True -> [Data name $ map (\arg -> head (holes ! arg)) args]

75+

76+ f = canonicalRealias aliases

77+ tipe' =

78+ case tipe of

79+ Var _ -> tipe

80+ EmptyRecord -> tipe

81+ Lambda t1 t2 -> Lambda (f t1) (f t2)

82+ Data name ts -> Data name (map f ts)

83+ Record fs ext -> Record (map (second f) fs) (f ext)

84+

85+allEqual [] = True

86+allEqual (x:xs) = all (==x) xs

87+

88+diff :: Type -> Type -> Maybe [(String,Type)]

89+diff general specific =

90+ case (general, specific) of

91+ (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2

92+ (Var x, t) -> Just [(x,t)]

93+ (Data gname gts, Data sname sts)

94+ | gname == sname && length gts == length sts ->

95+ concat <$> zipWithM diff gts sts

96+ (EmptyRecord, EmptyRecord) -> Just []

97+ (Record _ _, Record _ _) ->

98+ let (gfs,gext) = collectRecords general

99+ (sfs,sext) = collectRecords specific

100+ gfields = collectFields gfs

101+ sfields = collectFields sfs

102+

103+ overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

104+ isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)

105+ in

106+ case isAligned of

107+ False -> Nothing

108+ True -> let remaining = Map.difference sfields gfields

109+ sext' = if Map.null remaining then sext else

110+ Record (flattenFields remaining) sext

111+ matchMap = Map.intersectionWith (zipWith diff) gfields sfields

112+ in concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))

113+ (_,_) -> Nothing

114+

115+collectFields fields =

116+ foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields

117+

118+flattenFields fields =

119+ concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)

compiler/Type/ExtraChecks.hs+24−12

@@ -6,26 +6,38 @@ module Type.ExtraChecks (extraChecks) where

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

7import qualified Data.Map as Map

8import qualified Data.UnionFind.IO as UF

9−import Type.Type ( Variable, structure, Term1(..) )

9+import Type.Type ( Variable, structure, Term1(..), toSrcType )

10import Type.State (Env)

11−import Type.PrettyPrint ( pretty, ParensWhen(Never) )

11+import qualified Type.Alias as Alias

12import Text.PrettyPrint as P

13+import SourceSyntax.PrettyPrint (pretty)

14+import SourceSyntax.Type (Type)

15+import qualified Data.Traversable as Traverse

13

16

14−extraChecks :: Env -> IO (Either [P.Doc] Env)

17+extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))

15−extraChecks env =

18+extraChecks rules env = do

16− case mainCheck env of

19+ eitherEnv <- occursCheck env

20+ case eitherEnv of

17− Left errs -> return $ Left errs

21+ Left errs -> return $ Left errs

18− Right env -> occursCheck env

22+ Right env' ->

23+ mainCheck rules <$> Traverse.traverse toSrcType env'

24+

19

25

20−mainCheck :: Env -> Either [P.Doc] Env

26+mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)

21−mainCheck env =

27+mainCheck rules env =

28+ let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in

22 case Map.lookup "main" env of

29 case Map.lookup "main" env of

23 Nothing -> Right env

30 Nothing -> Right env

24− Just var

31+ Just tipe

25− | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env

32+ | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->

33+ Right env

26 | otherwise ->

34 | otherwise ->

27 Left [ P.vcat [ P.text "Type Error:"

35 Left [ P.vcat [ P.text "Type Error:"

28− , P.text "'main' must be an Element or a (Signal Element)\n" ] ]

36+ , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"

37+ , P.text "Instead 'main' has type:\n"

38+ , P.nest 4 . pretty $ Alias.realias rules tipe

39+ , P.text " " ]

40+ ]

29

41

30occursCheck :: Env -> IO (Either [P.Doc] Env)

42occursCheck :: Env -> IO (Either [P.Doc] Env)

31occursCheck env = do

43occursCheck env = do

compiler/Type/Inference.hs+7−7

@@ -12,18 +12,19 @@ import SourceSyntax.Module as Module

12import qualified SourceSyntax.Expression as Expr

13import SourceSyntax.Location (Located, noneNoDocs)

14import SourceSyntax.PrettyPrint

15+import SourceSyntax.Type (Type)

15import Text.PrettyPrint

16import Text.PrettyPrint

16import qualified Type.State as TS

17import qualified Type.State as TS

17import Type.ExtraChecks (extraChecks)

18import Type.ExtraChecks (extraChecks)

18import Control.Monad.State

19import Control.Monad.State

19import Control.Arrow (second)

20import Control.Arrow (second)

20−import Transform.SortDefinitions as Sort

21+import qualified Type.Alias as Alias

21

22

22import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

23import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

23 -- the IO monad. I don't think that'd be worthwhile.

24 -- the IO monad. I don't think that'd be worthwhile.

24

25

26

26−infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)

27+infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)

27infer interfaces modul = unsafePerformIO $ do

28infer interfaces modul = unsafePerformIO $ do

28 env <- Env.initialEnvironment

29 env <- Env.initialEnvironment

29 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

30 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

@@ -45,8 +46,7 @@ infer interfaces modul = unsafePerformIO $ do

45 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)

46 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)

46

47

47 state <- execStateT (Solve.solve constraint) TS.initialState

48 state <- execStateT (Solve.solve constraint) TS.initialState

49+ let rules = Alias.rules interfaces modul

48− let errors = TS.sErrors state

50+ case TS.sErrors state of

49− if null errors

51+ errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

50− then extraChecks $ Map.difference (TS.sSavedEnv state) header

52+ [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)

51− else Left `fmap` sequence (reverse errors)

52−

compiler/Type/State.hs+15−10

@@ -11,6 +11,8 @@ import qualified Data.Traversable as Traversable

11import Text.PrettyPrint as P

12import SourceSyntax.PrettyPrint

13import SourceSyntax.Location

14+import qualified SourceSyntax.Type as Src

15+import qualified Type.Alias as Alias

14

16

15-- Pool

17-- Pool

16-- Holds a bunch of variables

18-- Holds a bunch of variables

@@ -32,7 +34,7 @@ data SolverState = SS {

32 sSavedEnv :: Env,

34 sSavedEnv :: Env,

33 sPool :: Pool,

35 sPool :: Pool,

34 sMark :: Int,

36 sMark :: Int,

35− sErrors :: [IO P.Doc]

37+ sErrors :: [Alias.Rules -> IO P.Doc]

36}

38}

37

39

38initialState = SS {

40initialState = SS {

@@ -47,9 +49,19 @@ modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

47modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

49modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

48

50

49addError span message t1 t2 =

51addError span message t1 t2 =

50− modify $ \state -> state { sErrors = err : sErrors state }

52+ modify $ \state -> state { sErrors = makeError : sErrors state }

51 where

53 where

52− err = makeError <$> extraPretty t1 <*> extraPretty t2

54+ makeError rules = do

55+ let prettiest = pretty . Alias.realias rules

56+ t1' <- prettiest <$> toSrcType t1

57+ t2' <- prettiest <$> toSrcType t2

58+ return . P.vcat $

59+ [ P.text $ "Type error" ++ location ++ ":"

60+ , P.vcat . map P.text . lines $ if null message then defaultMessage else message

61+ , P.text src

62+ , P.text " Expected Type:" <+> t1'

63+ , P.text " Actual Type:" <+> t2' <> P.text "\n"

64+ ]

53

65

54 location = case span of

66 location = case span of

55 NoSpan msg -> ""

67 NoSpan msg -> ""

@@ -66,13 +78,6 @@ addError span message t1 t2 =

66

78

67 defaultMessage = "Something weird is happening with this value:"

79 defaultMessage = "Something weird is happening with this value:"

68

80

69− makeError pt1 pt2 =

70− P.vcat [ P.text $ "Type error" ++ location ++ ":"

71− , P.vcat . map P.text . lines $ if null message then defaultMessage else message

72− , P.text src

73− , P.text " Expected Type:" <+> pt1

74− , P.text " Actual Type:" <+> pt2 <> P.text "\n"

75− ]

76

81

77switchToPool pool = modifyPool (\_ -> pool)

82switchToPool pool = modifyPool (\_ -> pool)

78

83

libraries/Color.elm+9−9

@@ -46,17 +46,17 @@ darkRed = Color 164 0 0 1

46black = Color 0 0 0 1

47white = Color 255 255 255 1

48

49−lightGrey = Color 238 238 236

49+lightGrey = Color 238 238 236 1

50−grey = Color 211 215 207

50+grey = Color 211 215 207 1

51−darkGrey = Color 186 189 182

51+darkGrey = Color 186 189 182 1

52

53−lightGray = Color 238 238 236

53+lightGray = Color 238 238 236 1

54−gray = Color 211 215 207

54+gray = Color 211 215 207 1

55−darkGray = Color 186 189 182

55+darkGray = Color 186 189 182 1

56

57−lightCharcoal = Color 136 138 133

57+lightCharcoal = Color 136 138 133 1

58−charcoal = Color 85 87 83

58+charcoal = Color 85 87 83 1

59−darkCharcoal = Color 46 52 54

59+darkCharcoal = Color 46 52 54 1

60

61grayscale : Float -> Color

62grayscale p = hsv 0 0 (1-p)

libraries/Graphics/Collage.elm+1−1

@@ -6,7 +6,7 @@ import List

6import Either (Either, Left, Right)

7import Transform2D (Transform2D, identity)

8import Native.Graphics.Collage

9−import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

9+import Graphics.Element (Element)

10import Color (Color, black, Gradient)

11import Maybe (Maybe)

12import JavaScript (JSString)

libraries/Graphics/Input.elm+1−2

@@ -5,8 +5,7 @@ import Basics (String)

5import Signal (Signal,lift,dropRepeats)

6import Native.Graphics.Input

7import List

8−import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

8+import Graphics.Element (Element)

9−import Color (Color)

10import Maybe (Maybe)

9import Maybe (Maybe)

11import JavaScript (JSString)

10import JavaScript (JSString)

12

11