yogsototh/elm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into dev

Browse source
This commit is contained in:
Evan Czaplicki 2013-08-21 20:06:20 -07:00
commit ac71ab1fd8
13 changed files with 205 additions and 52 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Elm.cabal
View file

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

8
changelog.txt
View file

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

13
compiler/Compiler.hs
View file

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

1
compiler/Initialize.hs
View file

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

3
compiler/SourceSyntax/Module.hs
View file

@ -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])]) ],

13
compiler/SourceSyntax/Type.hs
View file

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

119
compiler/Type/Alias.hs Normal file
View file

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

36
compiler/Type/ExtraChecks.hs
View file

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

14
compiler/Type/Inference.hs
View file

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

25
compiler/Type/State.hs
View file

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

18
libraries/Color.elm
View file

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

2
libraries/Graphics/Collage.elm
View file

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

3
libraries/Graphics/Input.elm
View file

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