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

Add Expressions for ports to check and validate types nicely

Browse source
This commit is contained in:
Evan Czaplicki 2014-01-04 11:39:38 +01:00
parent defb47db75
commit 7cf5a564e5
11 changed files with 110 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Elm.cabal
View file

@ -228,7 +228,8 @@ Executable elm-doc
pandoc >= 1.10,
parsec >= 3.1.1,
pretty,
text
text,
union-find
Test-Suite test-elm
Type: exitcode-stdio-1.0

39
compiler/Generate/JavaScript.hs
View file

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -W #-}
module Generate.JavaScript (generate) where
import Control.Arrow (first,(***))
@ -24,8 +25,8 @@ split = go []
where
go vars str =
case break (=='.') str of
(x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
| otherwise -> go (vars ++ [x]) rest
(x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
| otherwise -> go (vars ++ [x]) rest
(x,[]) -> vars ++ [x]
var name = Id () name
@ -37,7 +38,11 @@ function args stmts = FuncExpr () Nothing (map var args) stmts
call = CallExpr ()
string = StringLit ()
dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
dotSep vars =
case vars of
x:xs -> foldl (DotRef ()) (ref x) (map var xs)
[] -> error "dotSep must be called on a non-empty list of variables"
obj = dotSep . split
varDecl :: String -> Expression () -> VarDecl ()
@ -191,6 +196,14 @@ expression (L span expr) =
pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
md = pad ++ MD.toHtml doc ++ pad
PortIn name _ _ handler ->
do handler' <- expression handler
return $ obj "_N.portIn" `call` [ string name, handler' ]
PortOut name _ signal ->
do signal' <- expression signal
return $ obj "_N.portOut" `call` [ string name, signal' ]
definition :: Def -> State Int [Statement ()]
definition (Definition pattern expr@(L span _) _) = do
expr' <- expression expr
@ -208,8 +221,7 @@ definition (Definition pattern expr@(L span _) _) = do
return [ VarDeclStmt () (assign "$" : map setField fields) ]
PData name patterns | vars /= Nothing ->
case vars of
Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
where
vars = getVars patterns
getVars patterns =
@ -299,8 +311,6 @@ generate unsafeModule =
, [ internalImports (List.intercalate "." (names modul)) ]
, concatMap jsImport (imports modul)
, checkInPorts (recvPorts modul)
, map inPort (recvPorts modul)
, map outPort (sendPorts modul)
, [ assign ["_op"] (ObjectLit () []) ]
, concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
, [ jsExports ]
@ -330,21 +340,11 @@ generate unsafeModule =
Nothing -> tail . init $ List.inits path
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
checkInPorts ports =
[ ExprStmt () $ obj "_N.checkPorts" `call` [ref "$moduleName", names] ]
[ ExprStmt () $ obj "_N.portCheck" `call` [ref "$moduleName", names] ]
where
names = ArrayLit () [ string name | (name, _, _) <- ports ]
inPort (name, expr, _) =
assign [name] $ obj "_N.inPort" `call` [ dotSep ["_elm","ports_in",name]
, evalState (expression expr) 0 ]
outPort (name, expr, _) =
let signal = evalState (expression expr) 0 in
assign ["_elm","ports_out",name] signal
binop span op e1 e2 =
case op of
"Basics.." ->
@ -371,9 +371,6 @@ binop span op e1 e2 =
L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
_ -> es ++ [e]
js1 = expression e1
js2 = expression e2
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
| otherwise = dotSep parts
where

35
compiler/SourceSyntax/Expression.hs
View file

@ -1,13 +1,14 @@
{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Expression where
import Data.List (intercalate)
import SourceSyntax.PrettyPrint
import Text.PrettyPrint as P
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.Location as Location
import qualified SourceSyntax.Pattern as Pattern
import qualified SourceSyntax.Type as Type
import qualified SourceSyntax.Type as SrcType
import qualified SourceSyntax.Literal as Literal
import qualified Type.Type as Type
{-| This is a located expression. -}
type LExpr' def = Location.Located (Expr' def)
@ -45,7 +46,9 @@ data Expr' def
| Modify (LExpr' def) [(String, LExpr' def)]
| Record [(String, LExpr' def)]
| Markdown String String [LExpr' def]
deriving (Eq)
-- for type checking and code gen only
| PortIn String SrcType.Type Type.Type (LExpr' def)
| PortOut String SrcType.Type (LExpr' def)
type ParseExpr = Expr' ParseDef
type LParseExpr = LExpr' ParseDef
@ -57,23 +60,26 @@ separately, and other checks will make sure they can be combined.
-}
data ParseDef
= Def Pattern.Pattern LParseExpr
| TypeAnnotation String Type.Type
deriving (Eq, Show)
| TypeAnnotation String SrcType.Type
deriving (Show)
{-| After checking that type annotations and definitions are all
valid, they can be combined.
-}
data Def
= Definition Pattern.Pattern (LExpr' Def) (Maybe Type.Type)
deriving (Eq, Show)
data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)
deriving (Show)
tuple :: [LExpr' def] -> Expr' def
tuple es = Data ("_Tuple" ++ show (length es)) es
delist :: LExpr' def -> [LExpr' def]
delist (Location.L _ (Data "::" [h,t])) = h : delist t
delist _ = []
saveEnvName :: String
saveEnvName = "_save_the_environment!!!"
dummyLet :: Pretty def => [def] -> LExpr' def
dummyLet defs =
Location.none $ Let defs (Location.none $ Var saveEnvName)
@ -105,7 +111,7 @@ instance Pretty def => Pretty (Expr' def) where
P.hang pexpr 2 (P.vcat (map pretty' pats))
where
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e
pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
Data "[]" [] -> P.text "[]"
Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
@ -121,7 +127,7 @@ instance Pretty def => Pretty (Expr' def) where
4
(commaSep $ map field fs)
where
field (x,e) = variable x <+> P.text "<-" <+> pretty e
field (k,v) = variable k <+> P.text "<-" <+> pretty v
Record fs ->
P.braces $ P.nest 2 (commaSep $ map field fs)
@ -130,6 +136,10 @@ instance Pretty def => Pretty (Expr' def) where
Markdown _ _ _ -> P.text "[markdown| ... |]"
PortIn _ _ _ handler -> pretty handler
PortOut _ _ signal -> pretty signal
instance Pretty ParseDef where
pretty def =
case def of
@ -147,11 +157,13 @@ instance Pretty Def where
Nothing -> P.empty
Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
collectApps :: LExpr' def -> [LExpr' def]
collectApps lexpr@(Location.L _ expr) =
case expr of
App a b -> collectApps a ++ [b]
_ -> [lexpr]
collectLambdas :: LExpr' def -> ([Doc], LExpr' def)
collectLambdas lexpr@(Location.L _ expr) =
case expr of
Lambda pattern body ->
@ -159,6 +171,7 @@ collectLambdas lexpr@(Location.L _ expr) =
in (pretty pattern : ps, body')
_ -> ([], lexpr)
prettyParens :: (Pretty def) => LExpr' def -> Doc
prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
where
needed =
@ -169,5 +182,5 @@ prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
MultiIf _ -> True
Let _ _ -> True
Case _ _ -> True
Data name (x:xs) -> name /= "::"
Data name (_:_) -> name /= "::"
_ -> False

12
compiler/Transform/Canonicalize.hs
View file

@ -1,4 +1,4 @@
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -W #-}
module Transform.Canonicalize (interface, metadataModule) where
import Control.Arrow ((***))
@ -117,6 +117,7 @@ rename env (L s expr) =
let rnm = rename env
throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
format = Either.either throw return
renameType' env = renameType (format . replace "variable" env)
in
L s <$>
case expr of
@ -156,7 +157,7 @@ rename env (L s expr) =
<*> rename env' body
<*> case mtipe of
Nothing -> return Nothing
Just tipe -> Just <$> renameType (format . replace "variable" env') tipe
Just tipe -> Just <$> renameType' env' tipe
Var x -> Var <$> format (replace "variable" env x)
@ -171,6 +172,13 @@ rename env (L s expr) =
Markdown uid md es -> Markdown uid md <$> mapM rnm es
PortIn name st tt handler ->
do st' <- renameType' env st
handler' <- rnm handler
return $ PortIn name st' tt handler'
PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
renamePattern :: Env -> P.Pattern -> Either String P.Pattern
renamePattern env pattern =

3
compiler/Transform/Expression.hs
View file

@ -28,4 +28,5 @@ crawl transform = go
Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
Markdown uid md es -> Markdown uid md <$> mapM go es
Let defs body -> Let <$> transform defs <*> go body
PortIn name st tt handler -> PortIn name st tt <$> go handler
PortOut name st signal -> PortOut name st <$> go signal

2
compiler/Transform/SafeNames.hs
View file

@ -49,6 +49,8 @@ expression (L loc expr) =
Modify r fs -> Modify (f r) (map (var *** f) fs)
Record fs -> Record (map (var *** f) fs)
Markdown uid md es -> Markdown uid md (map f es)
PortIn name st tt handler -> PortIn name st tt (f handler)
PortOut name st signal -> PortOut name st (f signal)
definition :: Def -> Def
definition (Definition p e t) =

4
compiler/Transform/SortDefinitions.hs
View file

@ -83,6 +83,10 @@ reorder (L s expr) =
Markdown uid md es -> Markdown uid md <$> mapM reorder es
PortOut name st signal -> PortOut name st <$> reorder signal
PortIn name st tt handler -> PortIn name st tt <$> reorder handler
-- Actually do some reordering
Let defs body ->
do body' <- reorder body

4
compiler/Transform/Substitute.hs
View file

@ -37,4 +37,6 @@ subst old new expr =
Modify r fs -> Modify (f r) (map (second f) fs)
Record fs -> Record (map (second f) fs)
Literal _ -> expr
Markdown uid md es -> Markdown uid md (map f es)
Markdown uid md es -> Markdown uid md (map f es)
PortIn name st tt handler -> PortIn name st tt (f handler)
PortOut name st signal -> PortOut name st (f signal)

7
compiler/Type/Constrain/Declaration.hs
View file

@ -45,9 +45,10 @@ toDefs decl =
Port port ->
case port of
Send name expr tipe -> [ definition name expr tipe ]
Recv _ _ _ -> -- [ definition name ]
error "not sure how to generate constraints for recv yet"
Send name expr@(L.L s _) tipe ->
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
Recv name expr@(L.L s _) tipe ->
[ definition name (L.L s $ E.PortIn name tipe undefined expr) tipe ]
-- no constraints are needed for fixity declarations
Fixity _ _ _ -> []

11
compiler/Type/Constrain/Expression.hs
View file

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -W #-}
module Type.Constrain.Expression where
import qualified Data.List as List
@ -145,6 +146,16 @@ constrain env (L span expr) tipe =
(clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
(c1 /\ c))
PortIn _ _ tt handler ->
exists $ \t1 ->
exists $ \t2 ->
exists $ \tHandler -> do
cHandler <- constrain env handler tHandler
return $ and [ cHandler, tHandler === (t1 ==> t2), tt === t2 ]
PortOut _ _ signal ->
constrain env signal tipe
constrainDef env info (Definition pattern expr maybeTipe) =
let qs = [] -- should come from the def, but I'm not sure what would live there...
(schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

34
libraries/Native/Utils.js
View file

@ -207,7 +207,7 @@ Elm.Native.Utils.make = function(elm) {
return Tuple2(posx, posy);
}
function checkPorts(moduleName, ports) {
function portCheck(moduleName, ports) {
var expected = {};
for (var i = ports.length; i--; ) {
expected[ports[i]] = 1;
@ -224,13 +224,37 @@ Elm.Native.Utils.make = function(elm) {
if (result < 0) extra.push(key);
}
if (missing.length > 0) {
throw new Error("Module " + moduleName + " requires inputs for these ports: " + missing.join(', '));
throw new Error("Module " + moduleName +
" requires inputs for these ports: " + missing.join(', '));
}
if (extra.length > 0) {
throw new Error("Module " + moduleName + " has been given ports that do not exist: " + extra.join(', '));
throw new Error("Module " + moduleName +
" has been given ports that do not exist: " + extra.join(', '));
}
}
function portOut(name, signal) {
var handlers = []
function subscribe(handler) {
handlers.push(handler);
}
function unsubscribe(handler) {
handlers.pop(handlers.indexOf(handler));
}
Signal.lift(function(v) {
var len = handlers.length;
for (var i = 0; i < len; ++i) {
handlers[i](v);
}
}, signal);
elm.ports_out[name] = { subscribe:subscribe, unsubscribe:unsubscribe };
return signal;
}
function portIn(name, handler) {
var port = elm.ports_in[name];
throw new Error('need to decide on Elm.input definition.');
}
return elm.Native.Utils.values = {
eq:eq,
cmp:cmp,
@ -251,6 +275,8 @@ Elm.Native.Utils.make = function(elm) {
htmlHeight: F2(htmlHeight),
getXY: getXY,
toFloat: function(x) { return +x; },
checkPorts: checkPorts
portCheck: portCheck,
portOut: portOut,
portIn: portIn
};
};