diff --git a/Elm.cabal b/Elm.cabal index 5da29ff..1a327dd 100644 --- a/Elm.cabal +++ b/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, diff --git a/changelog.txt b/changelog.txt index a126de1..5c9afb1 100644 --- a/changelog.txt +++ b/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 =========== diff --git a/compiler/Compiler.hs b/compiler/Compiler.hs index ac31882..49e738e 100644 --- a/compiler/Compiler.hs +++ b/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 () - tipes <- Traverse.traverse Type.toSrcType (types metaModule) + if print_types flags then printTypes interfaces metaModule else return () 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 ":" <+> pt + print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t) putStrLn "" getRuntime :: Flags -> IO FilePath diff --git a/compiler/Initialize.hs b/compiler/Initialize.hs index ff2eb71..8a392b5 100644 --- a/compiler/Initialize.hs +++ b/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 diff --git a/compiler/SourceSyntax/Module.hs b/compiler/SourceSyntax/Module.hs index 195bdd7..79b6672 100644 --- a/compiler/SourceSyntax/Module.hs +++ b/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])]) ], diff --git a/compiler/SourceSyntax/Type.hs b/compiler/SourceSyntax/Type.hs index cf04581..635f156 100644 --- a/compiler/SourceSyntax/Type.hs +++ b/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 diff --git a/compiler/Type/Alias.hs b/compiler/Type/Alias.hs new file mode 100644 index 0000000..1c0c0e7 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/compiler/Type/ExtraChecks.hs b/compiler/Type/ExtraChecks.hs index f1cc6c0..97be0b2 100644 --- a/compiler/Type/ExtraChecks.hs +++ b/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 env = - case mainCheck env of - Left errs -> return $ Left errs - Right env -> occursCheck env +extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type)) +extraChecks rules env = do + eitherEnv <- occursCheck env + case eitherEnv of + 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 - | P.render (pretty Never var) `elem` ["Element","Signal Element"] -> Right env + Just tipe + | 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 diff --git a/compiler/Type/Inference.hs b/compiler/Type/Inference.hs index 8b38a6a..ea60419 100644 --- a/compiler/Type/Inference.hs +++ b/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 - if null errors - then extraChecks $ Map.difference (TS.sSavedEnv state) header - else Left `fmap` sequence (reverse errors) - + let rules = Alias.rules interfaces modul + case TS.sErrors state of + errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors)) + [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header) diff --git a/compiler/Type/State.hs b/compiler/Type/State.hs index ca2ee52..756ba48 100644 --- a/compiler/Type/State.hs +++ b/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) diff --git a/libraries/Color.elm b/libraries/Color.elm index b27c2e8..dcad7ce 100644 --- a/libraries/Color.elm +++ b/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 -grey = Color 211 215 207 -darkGrey = Color 186 189 182 +lightGrey = Color 238 238 236 1 +grey = Color 211 215 207 1 +darkGrey = Color 186 189 182 1 -lightGray = Color 238 238 236 -gray = Color 211 215 207 -darkGray = Color 186 189 182 +lightGray = Color 238 238 236 1 +gray = Color 211 215 207 1 +darkGray = Color 186 189 182 1 -lightCharcoal = Color 136 138 133 -charcoal = Color 85 87 83 -darkCharcoal = Color 46 52 54 +lightCharcoal = Color 136 138 133 1 +charcoal = Color 85 87 83 1 +darkCharcoal = Color 46 52 54 1 grayscale : Float -> Color grayscale p = hsv 0 0 (1-p) diff --git a/libraries/Graphics/Collage.elm b/libraries/Graphics/Collage.elm index f0f4aed..979957c 100644 --- a/libraries/Graphics/Collage.elm +++ b/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) diff --git a/libraries/Graphics/Input.elm b/libraries/Graphics/Input.elm index 8ac65cb..ad69a3a 100644 --- a/libraries/Graphics/Input.elm +++ b/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 Color (Color) +import Graphics.Element (Element) import Maybe (Maybe) import JavaScript (JSString)