Merge branch 'master' into dev

Elm.cabal

@@ -63,6 +63,7 @@ Library
                        Parse.Parse,
                        Parse.Pattern,
                        Parse.Type,
+                       Type.Alias,
                        Type.Constrain.Declaration,
                        Type.Constrain.Expression,
                        Type.Constrain.Literal,
@@ -132,6 +133,7 @@ Executable elm
                        Parse.Parse,
                        Parse.Pattern,
                        Parse.Type,
+                       Type.Alias,
                        Type.Constrain.Declaration,
                        Type.Constrain.Expression,
                        Type.Constrain.Literal,

changelog.txt

@@ -1,4 +1,12 @@
 
+Release 0.9.1
+=============
+
+  * Switch to Tango color scheme, adding a bunch of nice colors
+  * add the greyscale function for easily producing greys
+  * Fix miscellaneous bugs in type checker
+  * Switch name of Matrix2D to Transform2D
+
 Release 0.9
 ===========
 

compiler/Compiler.hs

@@ -31,7 +31,7 @@ import Paths_Elm
 import SourceSyntax.PrettyPrint (pretty, variable)
 import Text.PrettyPrint as P
 import qualified Type.Type as Type
-import qualified Data.Traversable as Traverse
+import qualified Type.Alias as Alias
 
 data Flags =
     Flags { make :: Bool
@@ -146,10 +146,9 @@ buildFile flags moduleNum numModules interfaces filePath =
                     True -> print . pretty $ program modul
                   return modul
         
-        if print_types flags then printTypes metaModule else return ()
+        if print_types flags then printTypes interfaces metaModule else return ()
-        tipes <- Traverse.traverse Type.toSrcType (types metaModule)
         let interface = Canonical.interface name $ ModuleInterface {
-                          iTypes = tipes,
+                          iTypes = types metaModule,
                           iAdts = datatypes metaModule,
                           iAliases = aliases metaModule
                         }
@@ -160,11 +159,11 @@ buildFile flags moduleNum numModules interfaces filePath =
         writeFile (elmo flags filePath) (jsModule metaModule)
         return (name,interface)
 
-printTypes metaModule = do
+printTypes interfaces metaModule = do
   putStrLn ""
+  let rules = Alias.rules interfaces metaModule
   forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
-      pt <- Type.extraPretty t
+      print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)
-      print $ variable n <+> P.text ":" <+> pt
   putStrLn ""
 
 getRuntime :: Flags -> IO FilePath

compiler/Initialize.hs

@@ -11,7 +11,6 @@ import System.FilePath as FP
 import Text.PrettyPrint (Doc)
 
 import SourceSyntax.Everything
-import SourceSyntax.Type
 import qualified Parse.Parse as Parse
 import qualified Metadata.Prelude as Prelude
 import qualified Transform.Check as Check

compiler/SourceSyntax/Module.hs

@@ -12,7 +12,6 @@ import SourceSyntax.Expression (LExpr)
 import SourceSyntax.Declaration
 import SourceSyntax.Type
 import System.FilePath (joinPath)
-import qualified Type.Type as Type
 
 data Module tipe var =
     Module [String] Exports Imports [Declaration tipe var]
@@ -30,7 +29,7 @@ data MetadataModule t v = MetadataModule {
     exports   :: [String],
     imports   :: [(String, ImportMethod)],
     program   :: LExpr t v,
-    types     :: Map.Map String Type.Variable,
+    types     :: Map.Map String Type,
     fixities  :: [(Assoc, Int, String)],
     aliases   :: [(String, [String], Type)],
     datatypes :: [ (String, [String], [(String,[Type])]) ],

compiler/SourceSyntax/Type.hs

@@ -41,8 +41,11 @@ instance Pretty Type where
           | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
           | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
       EmptyRecord -> P.braces P.empty
-      Record fields ext -> P.braces $ P.hang (pretty ext <+> P.text "|") 4 prettyFields
+      Record _ _ -> P.braces $ case ext of
+                                 EmptyRecord -> prettyFields
+                                 _ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields
           where
+            (fields, ext) = collectRecords tipe
             prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
             prettyFields = commaSep . map prettyField $ fields
 
@@ -52,11 +55,19 @@ collectLambdas tipe =
     Lambda arg body -> pretty arg : collectLambdas body
     _ -> [pretty tipe]
 
+collectRecords = go []
+  where
+    go fields tipe =
+        case tipe of
+          Record fs ext -> go (fs ++ fields) ext
+          _ -> (fields, tipe)
+
 prettyParens tipe = parensIf needed (pretty tipe)
   where
     needed =
       case tipe of
         Lambda _ _ -> True
+        Data "_List" [_] -> False
         Data _ [] -> False
         Data _ _ -> True
         _ -> False

compiler/Type/Alias.hs

@@ -0,0 +1,119 @@
+module Type.Alias (realias, rules, canonicalRealias, Rules) where
+
+import Control.Applicative ((<$>),(<*>))
+import Control.Monad
+import Control.Arrow (second)
+import Data.Map ((!))
+import qualified Data.Map as Map
+import qualified Data.List as List
+import SourceSyntax.Type
+import SourceSyntax.Module
+
+type Rules = ([(String,[String],Type)], Type -> Type)
+
+rules interfaces metaModule = (collect interfaces metaModule, localizer metaModule)
+
+collect interfaces metaModule = filter (not . isPrimitive) rawAliases
+  where
+    rawAliases = aliases metaModule ++ concatMap iAliases (Map.elems interfaces)
+
+    isPrimitive (_,_,tipe) =
+        case tipe of
+          Data _ [] -> True
+          _ -> False
+
+localizer metaModule = go
+  where
+    go tipe = 
+        case tipe of
+          Var _ -> tipe
+          EmptyRecord -> tipe
+          Lambda t1 t2 -> Lambda (go t1) (go t2)
+          Data name ts -> Data (localize name) (map go ts)
+          Record fs ext -> Record (map (second go) fs) (go ext)
+
+    byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d) Map.empty (imports metaModule)
+
+    separate name =
+        case List.elemIndices '.' name of
+          [] -> ("",name)
+          is -> let i = last is in
+                (take i name, drop (i+1) name)
+
+    shortest = List.minimumBy (\a b -> compare (length a) (length b))
+
+    localize name = shortest (name : concatMap (localize' value) methods)
+        where (modul, value) = separate name
+              methods = Map.findWithDefault [] modul byMethod
+
+    localize' name method =
+        case method of
+          As modul -> [modul ++ "." ++ name]
+          Hiding xs | name `notElem` xs -> [name]
+          Importing xs | name `elem` xs -> [name]
+          _ -> []
+
+realias :: Rules -> Type -> Type
+realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)
+
+canonicalRealias :: [(String,[String],Type)] -> Type -> Type
+canonicalRealias aliases tipe =
+    case concatMap tryRealias aliases of
+      [tipe''] -> f tipe''
+      _ -> if tipe == tipe' then tipe else f tipe'
+  where
+    tryRealias (name, args, t) =
+        case diff t tipe of
+          Nothing -> []
+          Just kvs ->
+              let holes = collectFields kvs
+                  hasArgs = List.sort args == Map.keys holes
+                  isConsistent = all allEqual (Map.elems holes)
+              in  case hasArgs && isConsistent of
+                    False -> []
+                    True -> [Data name $ map (\arg -> head (holes ! arg)) args]
+
+    f = canonicalRealias aliases
+    tipe' =
+        case tipe of
+          Var _ -> tipe
+          EmptyRecord -> tipe
+          Lambda t1 t2 -> Lambda (f t1) (f t2)
+          Data name ts -> Data name (map f ts)
+          Record fs ext -> Record (map (second f) fs) (f ext)
+
+allEqual [] = True
+allEqual (x:xs) = all (==x) xs
+
+diff :: Type -> Type -> Maybe [(String,Type)]
+diff general specific =
+    case (general, specific) of
+      (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2
+      (Var x, t) -> Just [(x,t)]
+      (Data gname gts, Data sname sts)
+          | gname == sname && length gts == length sts ->
+              concat <$> zipWithM diff gts sts
+      (EmptyRecord, EmptyRecord) -> Just []
+      (Record _ _, Record _ _) ->
+          let (gfs,gext) = collectRecords general
+              (sfs,sext) = collectRecords specific
+              gfields = collectFields gfs
+              sfields = collectFields sfs
+
+              overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
+              isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)
+          in
+              case isAligned of
+                False -> Nothing
+                True -> let remaining = Map.difference sfields gfields
+                            sext' = if Map.null remaining then sext else
+                                        Record (flattenFields remaining) sext
+                            matchMap = Map.intersectionWith (zipWith diff) gfields sfields
+                        in  concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))
+      (_,_) -> Nothing
+
+collectFields fields =
+    foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields
+
+flattenFields fields =
+    concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)

compiler/Type/ExtraChecks.hs

@@ -6,26 +6,38 @@ module Type.ExtraChecks (extraChecks) where
 import Control.Applicative ((<$>),(<*>))
 import qualified Data.Map as Map
 import qualified Data.UnionFind.IO as UF
-import Type.Type ( Variable, structure, Term1(..) )
+import Type.Type ( Variable, structure, Term1(..), toSrcType )
 import Type.State (Env)
-import Type.PrettyPrint ( pretty, ParensWhen(Never) )
+import qualified Type.Alias as Alias
 import Text.PrettyPrint as P
+import SourceSyntax.PrettyPrint (pretty)
+import SourceSyntax.Type (Type)
+import qualified Data.Traversable as Traverse
 
-extraChecks :: Env -> IO (Either [P.Doc] Env)
+extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))
-extraChecks env = 
+extraChecks rules env = do
-    case mainCheck env of
+  eitherEnv <- occursCheck env
-      Left errs -> return $ Left errs
+  case eitherEnv of
-      Right env -> occursCheck env
+    Left errs -> return $ Left errs
+    Right env' ->
+        mainCheck rules <$> Traverse.traverse toSrcType env'
            
-mainCheck :: Env -> Either [P.Doc] Env
+
-mainCheck env =
+mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
+mainCheck rules env =
+    let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in
     case Map.lookup "main" env of
       Nothing -> Right env
-      Just var
+      Just tipe
-        | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env
+        | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->
+            Right env
         | otherwise ->
             Left [ P.vcat [ P.text "Type Error:"
-                          , P.text "'main' must be an Element or a (Signal Element)\n" ] ]
+                          , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"
+                          , P.text "Instead 'main' has type:\n"
+                          , P.nest 4 . pretty $ Alias.realias rules tipe
+                          , P.text " " ]
+                 ]
 
 occursCheck :: Env -> IO (Either [P.Doc] Env)
 occursCheck env = do

compiler/Type/Inference.hs

@@ -12,18 +12,19 @@ import SourceSyntax.Module as Module
 import qualified SourceSyntax.Expression as Expr
 import SourceSyntax.Location (Located, noneNoDocs)
 import SourceSyntax.PrettyPrint
+import SourceSyntax.Type (Type)
 import Text.PrettyPrint
 import qualified Type.State as TS
 import Type.ExtraChecks (extraChecks)
 import Control.Monad.State
 import Control.Arrow (second)
-import Transform.SortDefinitions as Sort
+import qualified Type.Alias as Alias
 
 import System.IO.Unsafe  -- Possible to switch over to the ST monad instead of
                          -- the IO monad. I don't think that'd be worthwhile.
 
 
-infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
+infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)
 infer interfaces modul = unsafePerformIO $ do
   env <- Env.initialEnvironment
              (datatypes modul ++ concatMap iAdts (Map.elems interfaces))
@@ -45,8 +46,7 @@ infer interfaces modul = unsafePerformIO $ do
   constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
 
   state <- execStateT (Solve.solve constraint) TS.initialState
-  let errors = TS.sErrors state
+  let rules = Alias.rules interfaces modul
-  if null errors
+  case TS.sErrors state of
-      then extraChecks $ Map.difference (TS.sSavedEnv state) header
+    errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
-      else Left `fmap` sequence (reverse errors)
+    [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)
-

compiler/Type/State.hs

@@ -11,6 +11,8 @@ import qualified Data.Traversable as Traversable
 import Text.PrettyPrint as P
 import SourceSyntax.PrettyPrint
 import SourceSyntax.Location
+import qualified SourceSyntax.Type as Src
+import qualified Type.Alias as Alias
 
 -- Pool
 -- Holds a bunch of variables
@@ -32,7 +34,7 @@ data SolverState = SS {
     sSavedEnv :: Env,
     sPool :: Pool,
     sMark :: Int,
-    sErrors :: [IO P.Doc]
+    sErrors :: [Alias.Rules -> IO P.Doc]
 }
 
 initialState = SS {
@@ -47,9 +49,19 @@ modifyEnv  f = modify $ \state -> state { sEnv = f (sEnv state) }
 modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
 
 addError span message t1 t2 =
-    modify $ \state -> state { sErrors = err : sErrors state }
+    modify $ \state -> state { sErrors = makeError : sErrors state }
   where
-    err = makeError <$> extraPretty t1 <*> extraPretty t2
+    makeError rules = do
+      let prettiest = pretty . Alias.realias rules
+      t1' <- prettiest <$> toSrcType t1
+      t2' <- prettiest <$> toSrcType t2
+      return . P.vcat $
+         [ P.text $ "Type error" ++ location ++ ":"
+         , P.vcat . map P.text . lines $ if null message then defaultMessage else message
+         , P.text src
+         , P.text "   Expected Type:" <+> t1'
+         , P.text "     Actual Type:" <+> t2' <> P.text "\n"
+         ]
 
     location = case span of
                  NoSpan msg -> ""
@@ -66,13 +78,6 @@ addError span message t1 t2 =
 
     defaultMessage = "Something weird is happening with this value:"
 
-    makeError pt1 pt2 =
-        P.vcat [ P.text $ "Type error" ++ location ++ ":"
-               , P.vcat . map P.text . lines $ if null message then defaultMessage else message
-               , P.text src
-               , P.text "   Expected Type:" <+> pt1
-               , P.text "     Actual Type:" <+> pt2 <> P.text "\n"
-               ]
 
 switchToPool pool = modifyPool (\_ -> pool)
 

libraries/Color.elm

@@ -46,17 +46,17 @@ darkRed  = Color 164  0  0 1
 black = Color  0   0   0  1
 white = Color 255 255 255 1
 
-lightGrey = Color 238 238 236
+lightGrey = Color 238 238 236 1
-grey      = Color 211 215 207
+grey      = Color 211 215 207 1
-darkGrey  = Color 186 189 182
+darkGrey  = Color 186 189 182 1
 
-lightGray = Color 238 238 236
+lightGray = Color 238 238 236 1
-gray      = Color 211 215 207
+gray      = Color 211 215 207 1
-darkGray  = Color 186 189 182
+darkGray  = Color 186 189 182 1
 
-lightCharcoal = Color 136 138 133
+lightCharcoal = Color 136 138 133 1
-charcoal      = Color  85  87  83
+charcoal      = Color  85  87  83 1
-darkCharcoal  = Color  46  52  54
+darkCharcoal  = Color  46  52  54 1
 
 grayscale : Float -> Color
 grayscale p = hsv 0 0 (1-p)

libraries/Graphics/Collage.elm

@@ -6,7 +6,7 @@ import List
 import Either (Either, Left, Right)
 import Transform2D (Transform2D, identity)
 import Native.Graphics.Collage
-import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
+import Graphics.Element (Element)
 import Color (Color, black, Gradient)
 import Maybe (Maybe)
 import JavaScript (JSString)

libraries/Graphics/Input.elm

@@ -5,8 +5,7 @@ import Basics (String)
 import Signal (Signal,lift,dropRepeats)
 import Native.Graphics.Input
 import List
-import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
+import Graphics.Element (Element)
-import Color (Color)
 import Maybe (Maybe)
 import JavaScript (JSString)