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

Merge pull request #165 from A1kmm/let-type-annotations

Browse source 
Support type annotations in let
This commit is contained in:
Evan Czaplicki 2013-06-05 14:20:14 -07:00
commit 8d13b0b586
15 changed files with 96 additions and 80 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Elm.cabal
View file

@ -65,6 +65,7 @@ Library
Build-depends: base >=4.2 && <5,
containers >= 0.3,
uniplate >= 1.6,
transformers >= 0.2,
mtl >= 2,
deepseq,
@ -119,6 +120,7 @@ Executable elm
Build-depends: base >=4.2 && <5,
containers >= 0.3,
uniplate >= 1.6,
transformers >= 0.2,
mtl >= 2,
deepseq,

15
compiler/Gen/CompileToJS.hs
View file

@ -7,6 +7,7 @@ import Data.List (intercalate,sortBy,inits,foldl')
import qualified Data.Map as Map
import Data.Either (partitionEithers)
import qualified Text.Pandoc as Pan
import Data.Maybe (maybeToList)
import Ast
import Located
@ -82,14 +83,14 @@ getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
op = ("_.$op = "++) . jsObj $ map opPair ops
get' (FnDef x _ _) = Left x
get' (OpDef op _ _ _) = Right op
get s = case s of Definition d -> [ get' d ]
get' (FnDef x _ _) = Just (Left x)
get' (OpDef op _ _ _) = Just (Right op)
get' (TypeAnnotation _ _) = Nothing
get s = case s of Definition d -> maybeToList (get' d)
Datatype _ _ tcs -> map (Left . fst) tcs
ImportEvent _ _ x _ -> [ Left x ]
ExportEvent _ _ _ -> []
TypeAlias _ _ _ -> []
TypeAnnotation _ _ -> []
jsImport (modul, how) =
@ -129,10 +130,10 @@ stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
ImportEvent _ _ _ _ -> 2
Definition (FnDef f [] _) ->
if derename f == "main" then 5 else 4
Definition (TypeAnnotation _ _) -> 0
Definition _ -> 3
ExportEvent _ _ _ -> 6
TypeAlias _ _ _ -> 0
TypeAnnotation _ _ -> 0
class ToJS a where
toJS :: a -> GuidCounter String
@ -148,6 +149,8 @@ instance ToJS Def where
do body <- toJS' e
let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
return (globalAssign ("$op['" ++ op ++ "']") func)
toJS (TypeAnnotation _ _) = return ""
instance ToJS Statement where
toJS stmt =
@ -170,7 +173,6 @@ instance ToJS Statement where
, "e.initEvent('", js, "_' + elm.id, true, true);"
, "e.value = v;"
, "document.dispatchEvent(e); return v; })(", elm, ");" ]
TypeAnnotation _ _ -> return ""
TypeAlias n _ t -> return ""
toJS' :: CExpr -> GuidCounter String
@ -275,6 +277,7 @@ jsLet defs e' = do ds <- jsDefs defs
valueOf (FnDef _ [] _) = 2
valueOf (FnDef _ _ _) = 1
valueOf (OpDef _ _ _ _) = 1
valueOf (TypeAnnotation _ _) = 0
caseToJS span e ps = do
match <- caseToMatch ps

1
compiler/Gen/ExtractNoscript.hs
View file

@ -21,6 +21,7 @@ instance Extract Statement where
instance Extract Def where
extract (FnDef _ _ e) = extract e
extract (OpDef _ _ _ e) = extract e
extract _ = []
instance Extract e => Extract (Located e) where
extract (L _ _ e) = extract e

16
compiler/Model/Ast.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Ast where
import Located
@ -6,6 +6,7 @@ import Data.Char (isDigit, isSymbol)
import Data.List (intercalate)
import Types.Types
import qualified Text.Pandoc as Pandoc
import Data.Data
data Module = Module [String] Exports Imports [Statement]
@ -13,14 +14,14 @@ type Exports = [String]
type Imports = [(String, ImportMethod)]
data ImportMethod = As String | Importing [String] | Hiding [String]
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Data, Typeable)
data Pattern = PData String [Pattern]
| PRecord [String]
| PVar String
| PAnything
deriving (Eq)
deriving (Eq, Data, Typeable)
type CExpr = Located Expr
data Expr = IntNum Int
@ -44,19 +45,19 @@ data Expr = IntNum Int
| Case CExpr [(Pattern,CExpr)]
| Data String [CExpr]
| Markdown Pandoc.Pandoc
deriving (Eq)
deriving (Eq, Data, Typeable)
data Def = FnDef String [String] CExpr
| OpDef String String String CExpr
deriving (Eq)
| TypeAnnotation String Type
deriving (Eq, Data, Typeable)
data Statement = Definition Def
| Datatype String [X] [(String,[Type])]
| TypeAlias String [X] Type
| TypeAnnotation String Type
| ImportEvent String CExpr String Type
| ExportEvent String String Type
deriving (Eq,Show)
deriving (Eq, Show, Data, Typeable)
cons h t = epos h t (Data "Cons" [h,t])
nil = L (Just "[]") NoSpan (Data "Nil" [])
@ -136,6 +137,7 @@ instance Show Def where
FnDef v [] e -> v ++ " = " ++ show e
FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e
OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
TypeAnnotation n t -> n ++ " : " ++ show t
getLambdas (L _ _ (Lambda x e)) = (x:xs,e')
where (xs,e') = getLambdas e

10
compiler/Model/Located.hs
View file

@ -1,16 +1,16 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Located where
import Text.Parsec.Pos
import Data.Data
data SrcPos = Pos Int Int
deriving (Eq,Ord)
deriving (Eq, Ord, Data, Typeable)
data SrcSpan = Span SrcPos SrcPos | NoSpan
deriving (Eq,Ord)
deriving (Eq, Ord, Data, Typeable)
data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord)
data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord, Data, Typeable)
instance Show SrcPos where

8
compiler/Parse/Expr.hs
View file

@ -13,6 +13,7 @@ import qualified Text.Pandoc as Pan
import Parse.Library
import Parse.Patterns
import Parse.Binops
import Parse.Types
import Guid
import Types.Types (Type (VarT), Scheme (Forall))
@ -164,7 +165,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
return . run $ makeLambda pats e
defSet :: IParser [Def]
defSet = concat <$> block (do d <- assignExpr ; whitespace ; return d)
defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
letExpr :: IParser Expr
letExpr = do
@ -207,8 +208,11 @@ assignExpr = withPos $ do
n <- sourceLine <$> getPosition
runAt (1000 * n) $ flattenPatterns fDefs e
def = map Definition <$> assignExpr
anyDef =
((\d -> [d]) <$> typeAnnotation) <|>
assignExpr
def = map Definition <$> anyDef
parseDef str =
case iParse def "" str of

2
compiler/Parse/Parser.hs
View file

@ -15,7 +15,7 @@ import Parse.Foreign
statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
where defs = map ((:[]) <$>) [ foreignDef, datatype, typeAnnotation ]
where defs = map ((:[]) <$>) [ foreignDef, datatype ]
freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
freshLine

2
compiler/Parse/Types.hs
View file

@ -95,7 +95,7 @@ toConstructor start end alias kvs =
rec = map (\a -> (a, [], loc (Var a))) args
typeAnnotation :: IParser Statement
typeAnnotation :: IParser Def
typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
where start = do v <- lowVar <|> parens symOp
whitespace ; hasType ; whitespace ; return v

1
compiler/Transform/LetBoundVars.hs
View file

@ -22,6 +22,7 @@ instance LetBoundVars Statement where
instance LetBoundVars Def where
letBoundVars (FnDef n _ e) = n : letBoundVars e
letBoundVars (OpDef _ _ _ e) = letBoundVars e
letBoundVars _ = []
instance LetBoundVars e => LetBoundVars (Context e) where
letBoundVars (C _ _ e) = letBoundVars e

1
compiler/Transform/Optimize.hs
View file

@ -23,6 +23,7 @@ instance Simplify Statement where
instance Simplify Def where
simp (FnDef func args e) = FnDef func args (simp e)
simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
simp x = x
instance Simplify e => Simplify (Located e) where
simp (L t s e) = L t s (simp e)

5
compiler/Transform/Rename.hs
View file

@ -30,6 +30,8 @@ instance Rename Def where
rename env (FnDef f args e) =
do env' <- extends env args
FnDef (env f) (map env' args) `liftM` rename env' e
rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)
instance Rename Statement where
rename env stmt =
@ -38,7 +40,6 @@ instance Rename Statement where
Datatype name args tcs ->
return $ Datatype name args $ map (first env) tcs
TypeAlias n xs t -> return (TypeAlias n xs t)
TypeAnnotation n t -> return (TypeAnnotation (env n) t)
ImportEvent js base elm tipe ->
do base' <- rename env base
return $ ImportEvent js base' (env elm) tipe
@ -146,4 +147,4 @@ renameLet env defs e = do env' <- extends env $ concatMap getNames defs
defs' <- mapM (rename env') defs
Let defs' `liftM` rename env' e
where getNames (FnDef n _ _) = [n]
getNames (OpDef _ _ _ _) = []
getNames _ = []

1
compiler/Transform/Substitute.hs
View file

@ -22,6 +22,7 @@ subst old new expr =
Let defs e -> Let (map substDef defs) (f e)
where substDef (FnDef name vs e) = FnDef name vs (f e)
substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)
substDef x = x
Var x -> if x == old then new else expr
Case e cases -> Case (f e) $ map (second f) cases
Data name es -> Data name (map f es)

95
compiler/Types/Alias.hs
View file

@ -1,13 +1,16 @@
{-# LANGUAGE PatternGuards #-}
module Types.Alias (dealias, get, mistakes) where
import Ast
import Located
import Control.Arrow (second)
import Data.List (group,sort)
import Data.Maybe (mapMaybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Types.Substitutions (subst)
import Types.Types
import Data.Generics.Uniplate.Data
builtins :: [(String,([X],Type))]
builtins =
@ -48,68 +51,59 @@ mistakes :: [Statement] -> [String]
mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
badKinds :: [Statement] -> [String]
badKinds stmts = map msg (concatMap badS stmts)
badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]
where
msg x = "Type Error: Type alias '" ++ x ++
"' was given the wrong number of arguments."
badT :: Type -> [String]
badT t =
case t of
ADT name ts ->
case Map.lookup name (get stmts) of
Just (xs,t) | length xs == length ts -> []
| otherwise -> [name]
Nothing -> concatMap badT ts
LambdaT t u -> badT t ++ badT u
RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))
_ -> []
badT (ADT name ts)
| Just (xs, _) <- Map.lookup name (get stmts),
length xs /= length ts = [name]
badT _ = []
badS :: Statement -> [String]
badS s =
case s of
Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)
ExportEvent _ _ tipe -> badT tipe
ImportEvent _ _ _ tipe -> badT tipe
TypeAnnotation _ tipe -> badT tipe
TypeAlias _ _ tipe -> badT tipe
Definition _ -> []
annotation :: Statement -> [String]
annotation :: Def -> Maybe String
annotation s =
case s of
TypeAnnotation name _ -> [name]
_ -> []
TypeAnnotation name _ -> Just name
_ -> Nothing
definition :: Statement -> [String]
definition :: Def -> Maybe String
definition s =
case s of
Definition d -> [defName d]
_ -> []
FnDef name _ _ -> Just name
OpDef name _ _ _ -> Just name
_ -> Nothing
defName :: Def -> String
defName d =
case d of
FnDef n _ _ -> n
OpDef n _ _ _ -> n
checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]
checkTopLevelAndLets stmts fcheck =
fcheck "at top-level" topLevelDefs ++
concatMap (fcheck "in let binding") allLetDefs
where
topLevelDefs = mapMaybe maybeDef stmts
maybeDef (Definition d) = Just d
maybeDef _ = Nothing
allLetDefs = [defList | Let defList _ <- universeBi stmts]
dups :: [Statement] -> [String]
dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)
where
dup :: (Statement -> [String]) -> [String]
dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts
dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
let
dup :: (Def -> Maybe String) -> [String]
dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs
msg = "Syntax Error: There can only be one "
defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."
annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."
annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."
in
map defMsg (dup definition) ++ map annMsg (dup annotation)
badOrder :: [Statement] -> [String]
badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)
where
badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
let
msg x = "Syntax Error: The type annotation for '" ++ x ++
"' must be directly above its definition."
as = sort $ concatMap annotation stmts
ds = sort $ concatMap definition stmts
"' must be directly above its definition in " ++ ctxt ++ "."
as = sort $ mapMaybe annotation defs
ds = sort $ mapMaybe definition defs
expectedPairs :: [String] -> [String] -> [String]
expectedPairs as ds =
@ -120,11 +114,14 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP
GT -> expectedPairs (x:xs) ys
( _ , _ ) -> []
actualPairs :: [Statement] -> [String]
actualPairs :: [Def] -> [String]
actualPairs stmts =
case stmts of
TypeAnnotation n _ : Definition d : rest ->
(if n == defName d then [n] else []) ++ actualPairs rest
TypeAnnotation n _ : rest@(d : _) ->
(if Just n == definition d
then [n]
else []
) ++ actualPairs rest
t:s:rest -> actualPairs (s:rest)
_ -> []
@ -136,4 +133,6 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP
EQ -> missings es as
GT -> a : missings (e:es) as
( [] , _ ) -> actual
( _ , [] ) -> expected
( _ , [] ) -> expected
in
map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)

8
compiler/Types/Constrain.hs
View file

@ -128,6 +128,7 @@ gen (L _ span expr) =
let assumptions = unionsA (as:ass)
getName d = case d of FnDef f _ _ -> f
OpDef op _ _ _ -> op
TypeAnnotation n _ -> n
names = map getName defs
genCs name s = do
v <- guid
@ -286,6 +287,9 @@ defScheme def = do (as,cs,hint) <- defGen def
defGen def = case def of
FnDef f args e -> defGenHelp f args e
OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
TypeAnnotation name tipe -> do
schm <- Subs.generalize [] =<< Subs.superize name tipe
return (Map.empty, Set.empty, (name, schm))
defGenHelp name args e = do
argDict <- mapM (\a -> liftM ((,) a) guid) args
@ -325,8 +329,4 @@ stmtGen stmt =
, Set.insert (L txt span (signalOf t :=: tipe)) cs
, Map.singleton elm (Forall [] [] tipe) )
TypeAnnotation name tipe ->
do schm <- Subs.generalize [] =<< Subs.superize name tipe
return (Map.empty, Set.empty, Map.singleton name schm)
TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)

9
compiler/Types/Types.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Types.Types where
import Located
@ -6,6 +6,7 @@ import Data.Char (isDigit)
import Data.List (intercalate,isPrefixOf)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Data
type X = Int
@ -15,14 +16,14 @@ data Type = LambdaT Type Type
| EmptyRecord
| RecordT (Map.Map String [Type]) Type
| Super (Set.Set Type)
deriving (Eq, Ord)
deriving (Eq, Ord, Data, Typeable)
data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show)
data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show, Data, Typeable)
data Constraint = Type :=: Type
| Type :<: Type
| X :<<: Scheme
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Show, Data, Typeable)
recordT :: [(String,Type)] -> Map.Map String [Type]
recordT fields =