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

Merge branch 'dev'

Browse source
This commit is contained in:
Evan Czaplicki 2014-03-21 15:29:14 -07:00
commit b65bf8ccc9
94 changed files with 2475 additions and 1934 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
Elm.cabal
View file

@ -1,5 +1,5 @@
Name: Elm
Version: 0.11
Version: 0.12
Synopsis: The Elm language module.
Description: Elm aims to make client-side web-development more pleasant.
It is a statically/strongly typed, functional reactive
@ -14,7 +14,7 @@ License-file: LICENSE
Author: Evan Czaplicki
Maintainer: info@elm-lang.org
Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
Category: Compiler, Language
@ -37,19 +37,19 @@ Library
Elm.Internal.Utils,
Elm.Internal.Version
Hs-Source-Dirs: compiler
other-modules: SourceSyntax.Declaration,
other-modules: SourceSyntax.Annotation,
SourceSyntax.Declaration,
SourceSyntax.Expression,
SourceSyntax.Helpers,
SourceSyntax.Literal,
SourceSyntax.Location,
SourceSyntax.Module,
SourceSyntax.Pattern,
SourceSyntax.PrettyPrint,
SourceSyntax.Type,
SourceSyntax.Variable,
Generate.JavaScript,
Generate.JavaScript.Helpers,
Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown,
Generate.Html,
Generate.Cases,
@ -97,7 +97,7 @@ Library
Build-depends: aeson,
base >=4.2 && <5,
binary >= 0.6.4.0,
blaze-html == 0.5.* || == 0.6.*,
blaze-html >= 0.5 && < 0.8,
blaze-markup,
bytestring,
cmdargs,
@ -119,19 +119,19 @@ Executable elm
Main-is: Compiler.hs
ghc-options: -threaded -O2
Hs-Source-Dirs: compiler
other-modules: SourceSyntax.Declaration,
other-modules: SourceSyntax.Annotation,
SourceSyntax.Declaration,
SourceSyntax.Expression,
SourceSyntax.Helpers,
SourceSyntax.Literal,
SourceSyntax.Location,
SourceSyntax.Module,
SourceSyntax.Pattern,
SourceSyntax.PrettyPrint,
SourceSyntax.Type,
SourceSyntax.Variable,
Generate.JavaScript,
Generate.JavaScript.Helpers,
Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown,
Generate.Html,
Generate.Cases,
@ -179,8 +179,8 @@ Executable elm
Build-depends: aeson,
base >=4.2 && <5,
binary >= 0.6.4.0,
blaze-html == 0.5.* || == 0.6.*,
blaze-markup == 0.5.1.*,
blaze-html >= 0.5 && < 0.8,
blaze-markup,
bytestring,
cmdargs,
containers >= 0.3,
@ -200,15 +200,16 @@ Executable elm
Executable elm-doc
Main-is: Docs.hs
Hs-Source-Dirs: compiler
other-modules: SourceSyntax.Declaration,
other-modules: SourceSyntax.Annotation,
SourceSyntax.Declaration,
SourceSyntax.Expression,
SourceSyntax.Helpers,
SourceSyntax.Literal,
SourceSyntax.Location,
SourceSyntax.Module,
SourceSyntax.Pattern,
SourceSyntax.PrettyPrint,
SourceSyntax.Type,
SourceSyntax.Variable,
Parse.Binop,
Parse.Declaration,
Parse.Expression,

3
Setup.hs
View file

@ -148,7 +148,8 @@ buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()
buildRuntime lbi elmos = do
createDirectoryIfMissing True (rtsDir lbi)
let rts' = rts lbi
writeFile rts' "var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
writeFile rts' "'use strict';\n\
\var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
\var ElmRuntime = {}; ElmRuntime.Render = {};\n"
mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
mapM_ (appendTo rts') elmos

34
changelog.txt → changelog.md
View file

@ -1,10 +1,38 @@
## 0.12
#### Breaking Changes:
* Overhaul Graphics.Input library (inspired by Spiros Eliopoulos and Jeff Smitts)
* Overhaul Text library to accomodate new Graphics.Input.Field
library and make the API more consistent overall
* Overhaul Regex library (inspired by Attila Gazso)
* Change syntax for "import open List" to "import List (..)"
* Improved JSON format for types generated by elm-doc
* Remove problematic Mouse.isClicked signal
* Revise the semantics of keepWhen and dropWhen to only update when
the filtered signal changes (thanks Max New and Janis Voigtländer)
#### Improvements:
* Add Graphics.Input.Field for customizable text fields
* Add Trampoline library (thanks to @maxsnew and @timthelion)
* Add Debug library (inspired by @timthelion)
* Drastically improved performance on markdown parsing (thanks to @Dandandan)
* Add Date.fromTime function
* Use pointer-events to detect hovers on layered elements (thanks to @Xashili)
* Fix bugs in Bitwise library
* Fix bug when exporting Maybe values through ports
## 0.11
* Lazy and Lazy.Stream (thanks to Max New)
* sortBy, sortWith (thanks to Max Goldstein)
* Ports, a new FFI that is more general and much nicer to use
* Basic compiler tests (thanks to Max New)
## 0.10.1
* sort, sortBy, sortWith (thanks to Max Goldstein)
* elm-repl
* Markdown interpolation
* Bitwise library
* Regex library
* Improve Transform2D library (thanks to Michael Søndergaard)

52
compiler/Build/Dependencies.hs
View file

@ -29,10 +29,7 @@ getSortedDependencies srcDirs builtIns root =
result <- runErrorT $ readAllDeps allSrcDirs builtIns root
case result of
Right deps -> sortDeps deps
Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
where msg = "\nYou may need to create a " ++
Path.dependencyFile ++
" file if you\nare trying to use a 3rd party library."
Left err -> failure err
extraDependencies :: IO (Maybe [FilePath])
extraDependencies =
@ -75,20 +72,22 @@ sortDeps depends =
msg = "A cyclical module dependency or was detected in:\n"
readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
readAllDeps srcDirs builtIns root =
do let ifaces = (Set.fromList . Map.keys) builtIns
State.evalStateT (go ifaces root) Set.empty
readAllDeps srcDirs rawBuiltIns filePath =
State.evalStateT (go Nothing filePath) Set.empty
where
go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
go builtIns root = do
root' <- lift $ findSrcFile srcDirs root
(name, deps) <- lift $ readDeps root'
builtIns :: Set.Set String
builtIns = Set.fromList $ Map.keys rawBuiltIns
go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
go parentModuleName filePath = do
filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
(moduleName, deps) <- lift $ readDeps filePath'
seen <- State.get
let realDeps = Set.difference (Set.fromList deps) builtIns
newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
State.put (Set.insert name (Set.union newDeps seen))
rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
State.put (Set.insert moduleName (Set.union newDeps seen))
rest <- mapM (go (Just moduleName) . toFilePath) (Set.toList newDeps)
return ((makeRelative "." filePath', moduleName, Set.toList realDeps) : concat rest)
readDeps :: FilePath -> ErrorT String IO (String, [String])
readDeps path = do
@ -98,15 +97,10 @@ readDeps path = do
where msg = "Error resolving dependencies in " ++ path ++ ":\n"
Right o -> return o
findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
findSrcFile dirs path = foldr tryDir notFound dirs
findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
findSrcFile parentModuleName dirs path =
foldr tryDir notFound dirs
where
notFound = throwError $ unlines
[ "Could not find file: " ++ path
, " If it is not in the root directory of your project, use"
, " --src-dir to declare additional locations for source files."
, " If it is part of a 3rd party library, it needs to be declared"
, " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
tryDir dir next = do
let path' = dir </> path
exists <- liftIO $ doesFileExist path'
@ -114,6 +108,20 @@ findSrcFile dirs path = foldr tryDir notFound dirs
then return path'
else next
parentModuleName' =
case parentModuleName of
Just name -> "module '" ++ name ++ "'"
Nothing -> "the main module"
notFound = throwError $ unlines
[ "When finding the imports declared in " ++ parentModuleName' ++ ", could not find file: " ++ path
, " If you created this module, but it is in a subdirectory that does not"
, " exactly match the module name, you may need to use the --src-dir flag."
, ""
, " If it is part of a 3rd party library, it needs to be declared"
, " as a dependency in your project's " ++ Path.dependencyFile ++ " file."
]
isNative :: String -> Bool
isNative name = List.isPrefixOf "Native." name

3
compiler/Build/Source.hs
View file

@ -2,7 +2,6 @@
module Build.Source (build) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.FilePath as FP
import Text.PrettyPrint (Doc)
@ -33,7 +32,7 @@ build noPrelude interfaces source =
let exports'
| null exs =
let get = Set.toList . Pattern.boundVars in
let get = Pattern.boundVarList in
concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
[ name | TypeAlias name _ (Type.Record _ _) <- decls ]

14
compiler/Build/Utils.hs
View file

@ -1,8 +1,11 @@
{-# OPTIONS_GHC -W #-}
module Build.Utils where
import System.Directory (doesFileExist)
import System.Environment (getEnv)
import System.FilePath ((</>), replaceExtension)
import qualified Build.Flags as Flag
import qualified Paths_Elm as This
buildPath :: Flag.Flags -> FilePath -> String -> FilePath
buildPath flags filePath ext =
@ -19,3 +22,14 @@ elmo flags filePath =
elmi :: Flag.Flags -> FilePath -> FilePath
elmi flags filePath =
cachePath flags filePath "elmi"
-- |The absolute path to a data file
getDataFile :: FilePath -> IO FilePath
getDataFile name = do
path <- This.getDataFileName name
exists <- doesFileExist path
if exists
then return path
else do
env <- getEnv "ELM_HOME"
return (env </> name)

58
compiler/Docs.hs
View file

@ -8,6 +8,7 @@ import System.Exit
import System.IO
import Control.Applicative ((<$>))
import Control.Arrow (second)
import Data.Aeson
import Data.Aeson.Encode.Pretty
import qualified Data.List as List
@ -15,8 +16,8 @@ import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BS
import qualified Data.Text as Text
import SourceSyntax.Helpers (isSymbol)
import SourceSyntax.Type (Type(..))
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.Type as T
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Declaration as D
@ -30,20 +31,24 @@ data Flags = Flags
{ files :: [FilePath] }
deriving (Data,Typeable,Show,Eq)
defaultFlags :: Flags
defaultFlags = Flags
{ files = def &= args &= typ "FILES"
} &= help "Generate documentation for Elm"
&= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
main :: IO ()
main = do
flags <- cmdArgs defaultFlags
mapM parseFile (files flags)
mapM_ parseFile (files flags)
config :: Config
config = Config { confIndent = 2, confCompare = keyOrder keys }
where
keys = ["name","document","comment","raw","aliases","datatypes"
keys = ["tag","name","document","comment","raw","aliases","datatypes"
,"values","typeVariables","type","constructors"]
parseFile :: FilePath -> IO ()
parseFile path = do
source <- readFile path
case iParse docs source of
@ -69,6 +74,7 @@ docComment = do
let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
return $ dropWhile (==' ') (reverse reversed)
moduleDocs :: IParser (String, [String], String)
moduleDocs = do
optional freshLine
(names,exports) <- moduleDef
@ -121,7 +127,7 @@ collect infixes types aliases adts things =
where
nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
addDefaultInfix name pairs
| all isSymbol name = addInfix (D.L, 9 :: Int) pairs
| all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
| otherwise = pairs
customOps = Map.intersectionWith addInfix infixes types
@ -138,7 +144,7 @@ collect infixes types aliases adts things =
let fields = ["typeVariables" .= vars, "type" .= tipe ]
in collect infixes types (insert name fields aliases) adts rest
D.Datatype name vars ctors ->
let tipe = Data name (map Var vars)
let tipe = T.Data name (map T.Var vars)
fields = ["typeVariables" .= vars
, "constructors" .= map (ctorToJson tipe) ctors ]
in collect infixes types aliases (insert name fields adts) rest
@ -147,17 +153,35 @@ collect infixes types aliases adts things =
obj name fields =
[ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
instance ToJSON Type where
toJSON tipe =
case tipe of
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
Var x -> toJSON x
Data name ts -> toJSON (toJSON name : map toJSON ts)
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
where fields' = case ext of
Nothing -> fields
Just x -> ("_", Var x) : fields
instance ToJSON T.Type where
toJSON tipe =
object $
case tipe of
T.Lambda _ _ ->
let tipes = T.collectLambdas tipe in
[ "tag" .= ("function" :: Text.Text)
, "args" .= toJSON (init tipes)
, "result" .= toJSON (last tipes)
]
T.Var x ->
[ "tag" .= ("var" :: Text.Text)
, "name" .= toJSON x
]
T.Data name ts ->
[ "tag" .= ("adt" :: Text.Text)
, "name" .= toJSON name
, "args" .= map toJSON ts
]
T.Record fields ext ->
[ "tag" .= ("record" :: Text.Text)
, "fields" .= toJSON (map (toJSON . second toJSON) fields)
, "extension" .= toJSON ext
]
ctorToJson :: T.Type -> (String, [T.Type]) -> Value
ctorToJson tipe (ctor, tipes) =
object [ "name" .= ctor
, "type" .= foldr Lambda tipe tipes ]
, "type" .= foldr T.Lambda tipe tipes ]

9
compiler/Elm/Internal/Paths.hs
View file

@ -1,7 +1,8 @@
{-# OPTIONS_GHC -Wall #-}
module Elm.Internal.Paths where
import System.IO.Unsafe
import qualified Paths_Elm as This
import Build.Utils (getDataFile)
import System.IO.Unsafe (unsafePerformIO)
-- |Name of directory for all of a project's dependencies.
dependencyDirectory :: FilePath
@ -15,9 +16,9 @@ dependencyFile = "elm_dependencies.json"
{-# NOINLINE runtime #-}
-- |The absolute path to Elm's runtime system.
runtime :: FilePath
runtime = unsafePerformIO $ This.getDataFileName "elm-runtime.js"
runtime = unsafePerformIO $ getDataFile "elm-runtime.js"
{-# NOINLINE docs #-}
-- |The absolute path to Elm's core library documentation.
docs :: FilePath
docs = unsafePerformIO $ This.getDataFileName "docs.json"
docs = unsafePerformIO $ getDataFile "docs.json"

61
compiler/Generate/Cases.hs
View file

@ -6,14 +6,15 @@ import Control.Monad.State
import Data.List (groupBy,sortBy)
import Data.Maybe (fromMaybe)
import SourceSyntax.Location
import SourceSyntax.Literal
import SourceSyntax.Pattern
import SourceSyntax.Annotation
import SourceSyntax.Expression
import SourceSyntax.Literal
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as V
import Transform.Substitute
toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
toMatch patterns = do
v <- newVar
(,) v <$> match [v] (map (first (:[])) patterns) Fail
@ -27,7 +28,7 @@ data Match
= Match String [Clause] Match
| Break
| Fail
| Other LExpr
| Other Expr
| Seq [Match]
deriving Show
@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
matchSubst _ Break = Break
matchSubst _ Fail = Fail
matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
matchSubst pairs (Other (L s e)) =
Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
matchSubst pairs (Other (A a e)) =
Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
matchSubst pairs (Match n cs m) =
Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
where varSubst v = fromMaybe v (lookup v pairs)
@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
isCon (p:_, _) =
case p of
PData _ _ -> True
PLiteral _ -> True
_ -> False
P.Data _ _ -> True
P.Literal _ -> True
_ -> False
isVar p = not (isCon p)
match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
match [] [] def = return def
match [] [([],e)] Fail = return $ Other e
match [] [([],e)] Break = return $ Other e
@ -67,46 +68,46 @@ match vs@(v:_) cs def
where
cs' = map (dealias v) cs
dealias v c@(p:ps, L s e) =
dealias v c@(p:ps, A a e) =
case p of
PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)
_ -> c
matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
matchVar (v:vs) cs def = match vs (map subVar cs) def
where
subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)
subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
where
subOnePattern pattern e =
case pattern of
PVar x -> subst x (Var v) e
PAnything -> e
PRecord fs ->
foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
P.Var x -> subst x (rawVar v) e
P.Anything -> e
P.Record fs ->
foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
where
css = groupBy eq (sortBy cmp cs)
cmp (p1:_,_) (p2:_,_) =
case (p1,p2) of
(PData n1 _, PData n2 _) -> compare n1 n2
(P.Data n1 _, P.Data n2 _) -> compare n1 n2
_ -> compare p1 p2
eq (p1:_,_) (p2:_,_) =
case (p1,p2) of
(PData n1 _, PData n2 _) -> n1 == n2
(P.Data n1 _, P.Data n2 _) -> n1 == n2
_ -> p1 == p2
toClause cs =
case head cs of
(PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
(PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
(P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
(P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
matchClause :: Either String Literal
-> [String]
-> [([Pattern],LExpr)]
-> [([P.Pattern],Expr)]
-> Match
-> State Int Clause
matchClause c (_:vs) cs def =
@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
flatten (p:ps, e) =
case p of
PData _ ps' -> (ps' ++ ps, e)
PLiteral _ -> (ps, e)
P.Data _ ps' -> (ps' ++ ps, e)
P.Literal _ -> (ps, e)
getVars =
case head cs of
(PData _ ps : _, _) -> forM ps (const newVar)
(PLiteral _ : _, _) -> return []
(P.Data _ ps : _, _) -> forM ps (const newVar)
(P.Literal _ : _, _) -> return []
matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

117
compiler/Generate/JavaScript.hs
View file

@ -1,25 +1,27 @@
{-# OPTIONS_GHC -W #-}
module Generate.JavaScript (generate) where
import Control.Arrow (first,(***))
import Control.Applicative ((<$>),(<*>))
import Control.Arrow (first,(***))
import Control.Monad.State
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Language.ECMAScript3.PrettyPrint
import Language.ECMAScript3.Syntax
import Generate.JavaScript.Helpers
import qualified Generate.Cases as Case
import qualified Generate.JavaScript.Ports as Port
import qualified Generate.Markdown as MD
import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Helpers as Help
import SourceSyntax.Literal
import SourceSyntax.Pattern as Pattern
import SourceSyntax.Location
import SourceSyntax.Expression
import SourceSyntax.Module
import Language.ECMAScript3.Syntax
import Language.ECMAScript3.PrettyPrint
import qualified SourceSyntax.Pattern as P
import SourceSyntax.PrettyPrint (renderPretty)
import qualified SourceSyntax.Variable as V
import qualified Transform.SafeNames as MakeSafe
varDecl :: String -> Expression () -> VarDecl ()
@ -50,10 +52,10 @@ literal lit =
FloatNum n -> NumLit () n
Boolean b -> BoolLit () b
expression :: LExpr -> State Int (Expression ())
expression (L span expr) =
expression :: Expr -> State Int (Expression ())
expression (A region expr) =
case expr of
Var x -> return $ ref x
Var (V.Raw x) -> return $ obj x
Literal lit -> return $ literal lit
Range lo hi ->
@ -85,17 +87,16 @@ expression (L span expr) =
do fields' <- forM fields $ \(f,e) -> do
(,) f <$> expression e
let fieldMap = List.foldl' combine Map.empty fields'
return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
where
combine r (k,v) = Map.insertWith (++) k [v] r
prop = PropId () . var
hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
Map.toList . Map.filter (not . null) $ Map.map tail fs
visible fs = map (first prop) . Map.toList $ Map.map head fs
Binop op e1 e2 -> binop span op e1 e2
Binop op e1 e2 -> binop region op e1 e2
Lambda p e@(L s _) ->
Lambda p e@(A ann _) ->
do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
body' <- expression body
return $ case length args < 2 || length args > 9 of
@ -104,13 +105,14 @@ expression (L span expr) =
where
depattern (args, body) pattern =
case pattern of
PVar x -> return (args ++ [x], body)
P.Var x -> return (args ++ [x], body)
_ -> do arg <- Case.newVar
return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
return ( args ++ [arg]
, A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
(patterns, innerBody) = collect [p] e
collect patterns lexpr@(L _ expr) =
collect patterns lexpr@(A _ expr) =
case expr of
Lambda p e -> collect (p:patterns) e
_ -> (patterns, lexpr)
@ -127,7 +129,7 @@ expression (L span expr) =
(func, args) = getArgs e1 [e2]
getArgs func args =
case func of
(L _ (App f arg)) -> getArgs f (arg : args)
(A _ (App f arg)) -> getArgs f (arg : args)
_ -> (func, args)
Let defs e ->
@ -139,9 +141,9 @@ expression (L span expr) =
MultiIf branches ->
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
return $ case last branches of
(L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
(L _ (Literal (Boolean True)), _) -> safeIfs branches'
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
(A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
(A _ (Literal (Boolean True)), _) -> safeIfs branches'
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
where
safeIfs branches = ifs (init branches) (snd (last branches))
ifs branches finally = foldr iff finally branches
@ -151,10 +153,12 @@ expression (L span expr) =
do (tempVar,initialMatch) <- Case.toMatch cases
(revisedMatch, stmt) <-
case e of
L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
_ -> do e' <- expression e
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
match' <- match span revisedMatch
A _ (Var (V.Raw x)) ->
return (Case.matchSubst [(tempVar,x)] initialMatch, [])
_ ->
do e' <- expression e
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
match' <- match region revisedMatch
return (function [] (stmt ++ match') `call` [])
ExplicitList es ->
@ -184,28 +188,28 @@ expression (L span expr) =
[ string name, Port.outgoing tipe, value' ]
definition :: Def -> State Int [Statement ()]
definition (Definition pattern expr@(L span _) _) = do
definition (Definition pattern expr@(A region _) _) = do
expr' <- expression expr
let assign x = varDecl x expr'
case pattern of
PVar x
P.Var x
| Help.isOp x ->
let op = LBracket () (ref "_op") (string x) in
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
| otherwise ->
return [ VarDeclStmt () [ assign x ] ]
PRecord fields ->
P.Record fields ->
let setField f = varDecl f (dotSep ["$",f]) in
return [ VarDeclStmt () (assign "$" : map setField fields) ]
PData name patterns | vars /= Nothing ->
P.Data name patterns | vars /= Nothing ->
return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
where
vars = getVars patterns
getVars patterns =
case patterns of
PVar x : rest -> (x:) `fmap` getVars rest
P.Var x : rest -> (x:) `fmap` getVars rest
[] -> Just []
_ -> Nothing
@ -216,41 +220,45 @@ definition (Definition pattern expr@(L span _) _) = do
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
_ ->
do defs' <- concat <$> mapM toDef vars
return (VarDeclStmt () [assign "$"] : defs')
where
vars = Set.toList $ Pattern.boundVars pattern
mkVar = L span . Var
toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
in definition $ Definition (PVar y) expr Nothing
vars = P.boundVarList pattern
mkVar = A region . rawVar
toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
in definition $ Definition (P.Var y) expr Nothing
match :: SrcSpan -> Case.Match -> State Int [Statement ()]
match span mtch =
match :: Region -> Case.Match -> State Int [Statement ()]
match region mtch =
case mtch of
Case.Match name clauses mtch' ->
do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
mtch'' <- match span mtch'
do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
mtch'' <- match region mtch'
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
where
isLiteral p = case p of
Case.Clause (Right _) _ _ -> True
_ -> False
access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
access name
| any isLiteral clauses = obj name
| otherwise = dotSep (split name ++ ["ctor"])
format isChars e
| or isChars = InfixExpr () OpAdd e (string "")
| otherwise = e
Case.Fail ->
return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
Case.Break -> return [BreakStmt () Nothing]
Case.Other e ->
do e' <- expression e
return [ ret e' ]
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
where
dropEnd acc [] = acc
dropEnd acc (m:ms) =
@ -258,9 +266,9 @@ match span mtch =
Case.Other _ -> acc ++ [m]
_ -> dropEnd (acc ++ [m]) ms
clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
clause span variable (Case.Clause value vars mtch) =
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
clause region variable (Case.Clause value vars mtch) =
(,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
where
vars' = map (\n -> variable ++ "._" ++ show n) [0..]
(isChar, pattern) =
@ -273,8 +281,8 @@ clause span variable (Case.Clause value vars mtch) =
[] -> name
is -> drop (last is + 1) name
flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
flattenLets defs lexpr@(L _ expr) =
flattenLets :: [Def] -> Expr -> ([Def], Expr)
flattenLets defs lexpr@(A _ expr) =
case expr of
Let ds body -> flattenLets (defs ++ ds) body
_ -> (defs, lexpr)
@ -288,7 +296,8 @@ generate unsafeModule =
thisModule = dotSep ("_elm" : names modul ++ ["values"])
programStmts =
concat
[ setup (Just "_elm") (names modul ++ ["values"])
[ [ ExprStmt () $ string "use strict" ]
, setup (Just "_elm") (names modul ++ ["values"])
, [ IfSingleStmt () thisModule (ret thisModule) ]
, [ internalImports (List.intercalate "." (names modul)) ]
, concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
@ -301,7 +310,7 @@ generate unsafeModule =
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
where
exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
entry x = (PropId () (var x), ref x)
entry x = (prop x, ref x)
assign path expr =
case path of
@ -311,7 +320,7 @@ generate unsafeModule =
jsImport modul = setup Nothing path ++ [ include ]
where
path = split modul
path = Help.splitDots modul
include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
setup namespace path = map create paths
@ -321,8 +330,8 @@ generate unsafeModule =
Nothing -> tail . init $ List.inits path
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
binop span op e1 e2 =
binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
binop region op e1 e2 =
case op of
"Basics.." ->
do es <- mapM expression (e1 : collect [] e2)
@ -335,7 +344,7 @@ binop span op e1 e2 =
do e1' <- expression e1
e2' <- expression e2
return $ obj "_L.append" `call` [e1', e2']
"::" -> expression (L span (Data "::" [e1,e2]))
"::" -> expression (A region (Data "::" [e1,e2]))
_ ->
do e1' <- expression e1
e2' <- expression e2
@ -345,13 +354,13 @@ binop span op e1 e2 =
where
collect es e =
case e of
L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
_ -> es ++ [e]
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
| otherwise = dotSep parts
where
parts = split op
parts = Help.splitDots op
operator = last parts
opDict = Map.fromList (infixOps ++ specialOps)

38
compiler/Generate/JavaScript/Ports.hs
View file

@ -32,7 +32,7 @@ incoming tipe =
inc :: Type -> Expression () -> Expression ()
inc tipe x =
case tipe of
case tipe of
Lambda _ _ -> error "functions should not be allowed through input ports"
Var _ -> error "type variables should not be allowed through input ports"
Data ctor []
@ -58,22 +58,26 @@ inc tipe x =
where
array = DotRef () x (var "map") <| incoming t
Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
Data ctor ts
| Help.isTuple ctor -> check x JSArray tuple
where
tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
tuple = ObjectLit () $ (prop "ctor", string ctor) : values
values = zipWith convert [0..] ts
convert n t = ( PropId () $ var ('_':show n)
convert n t = ( prop ('_':show n)
, inc t (BracketRef () x (IntLit () n)))
Data _ _ -> error "bad ADT got to port generation code"
Data _ _ ->
error "bad ADT got to port generation code"
Record _ (Just _) -> error "bad record got to port generation code"
Record _ (Just _) ->
error "bad record got to port generation code"
Record fields Nothing -> check x (JSObject (map fst fields)) object
Record fields Nothing ->
check x (JSObject (map fst fields)) object
where
object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
keys = map convert fields
convert (f,t) = (PropId () (var f), inc t (DotRef () x (var f)))
convert (f,t) = (prop f, inc t (DotRef () x (var f)))
outgoing tipe =
case tipe of
@ -109,19 +113,21 @@ out tipe x =
| ctor == "Maybe.Maybe" ->
CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
(NullLit ())
(DotRef () x (var "_0"))
(out t (DotRef () x (var "_0")))
| ctor == "_List" ->
DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
Data ctor ts | Help.isTuple ctor ->
ArrayLit () $ zipWith convert [0..] ts
where
convert n t = out t $ DotRef () x $ var ('_':show n)
Data ctor ts
| Help.isTuple ctor ->
let convert n t = out t $ DotRef () x $ var ('_':show n)
in ArrayLit () $ zipWith convert [0..] ts
Data _ _ -> error "bad ADT got to port generation code"
Data _ _ ->
error "bad ADT got to port generation code"
Record _ (Just _) -> error "bad record got to port generation code"
Record _ (Just _) ->
error "bad record got to port generation code"
Record fields Nothing ->
ObjectLit () keys

68
compiler/Generate/Noscript.hs
View file

@ -1,68 +0,0 @@
module Generate.Noscript (noscript) where
import Data.List (isInfixOf)
import qualified SourceSyntax.Declaration as D
import SourceSyntax.Expression
import SourceSyntax.Literal
import SourceSyntax.Location
import SourceSyntax.Module
import qualified Generate.Markdown as MD
noscript :: Extract def => Module def -> String
noscript modul = concat (extract modul)
class Extract a where
extract :: a -> [String]
instance Extract def => Extract (Module def) where
extract (Module _ _ _ stmts) =
map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
instance Extract def => Extract (D.Declaration' port def) where
extract (D.Definition d) = extract d
extract _ = []
instance Extract Def where
extract (Definition _ e _) = extract e
instance Extract e => Extract (Located e) where
extract (L _ e) = extract e
instance Extract def => Extract (Expr' def) where
extract expr =
let f = extract in
case expr of
Literal (Str s) -> [s]
Binop op e1 e2 -> case (op, f e1, f e2) of
("++", [s1], [s2]) -> [s1 ++ s2]
(_ , ss1 , ss2 ) -> ss1 ++ ss2
Lambda v e -> f e
App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src
| "image" `isInfixOf` func -> extractImage src
App (L _ (App (L _ (Var func)) src)) txt
| "link" `isInfixOf` func -> extractLink src txt
App (L _ (Var func)) e
| "header" `isInfixOf` func -> tag "h1" e
| "bold" `isInfixOf` func -> tag "b" e
| "italic" `isInfixOf` func -> tag "i" e
| "monospace" `isInfixOf` func -> tag "code" e
App e1 e2 -> f e1 ++ f e2
Let defs e -> concatMap extract defs ++ f e
Var _ -> []
Case e cases -> concatMap (f . snd) cases
Data _ es -> concatMap f es
MultiIf es -> concatMap (f . snd) es
Markdown _ md _ -> [ MD.toHtml md ]
_ -> []
extractLink src txt =
case (extract src, extract txt) of
([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
( ss1, ss2) -> ss1 ++ ss2
extractImage src =
case extract src of
[s] -> ["<img src=\"" ++ s ++ "\">"]
ss -> ss
tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)

14
compiler/Metadata/Prelude.hs
View file

@ -3,11 +3,11 @@ module Metadata.Prelude (interfaces, add) where
import qualified Data.Map as Map
import qualified Control.Exception as E
import qualified Paths_Elm as Path
import System.Exit
import System.IO
import SourceSyntax.Module
import qualified Build.Interface as Interface
import Build.Utils (getDataFile)
add :: Bool -> Module def -> Module def
add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
@ -20,18 +20,18 @@ add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) d
Just _ -> []
prelude :: [(String, ImportMethod)]
prelude = string : text ++ map (\n -> (n, Hiding [])) modules
prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules
where
text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
string = ("String", As "String")
modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
, "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]
string = map ((,) "String") [ As "String", Importing ["show"] ]
modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"
, "Graphics.Element", "Graphics.Collage", "Native.Ports" ]
interfaces :: Bool -> IO Interfaces
interfaces noPrelude =
if noPrelude
then return $ Map.empty
else safeReadDocs =<< Path.getDataFileName "interfaces.data"
then return Map.empty
else safeReadDocs =<< getDataFile "interfaces.data"
safeReadDocs :: FilePath -> IO Interfaces
safeReadDocs name =

33
compiler/Parse/Binop.hs
View file

@ -1,10 +1,11 @@
{-# OPTIONS_GHC -W #-}
module Parse.Binop (binops, OpTable) where
import Control.Applicative ((<$>))
import Data.List (intercalate)
import qualified Data.List as List
import qualified Data.Map as Map
import SourceSyntax.Location (merge)
import SourceSyntax.Annotation (merge)
import qualified SourceSyntax.Expression as E
import SourceSyntax.Declaration (Assoc(..))
import Text.Parsec
@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
opAssoc :: OpTable -> String -> Assoc
opAssoc table op = snd $ Map.findWithDefault (9,L) op table
hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool
hasLevel table n (op,_) = opLevel table op == n
binops :: IParser E.LParseExpr
-> IParser E.LParseExpr
binops :: IParser E.ParseExpr
-> IParser E.ParseExpr
-> IParser String
-> IParser E.LParseExpr
-> IParser E.ParseExpr
binops term last anyOp =
do e <- term
table <- getState
@ -38,9 +39,9 @@ binops term last anyOp =
split :: OpTable
-> Int
-> E.LParseExpr
-> [(String, E.LParseExpr)]
-> IParser E.LParseExpr
-> E.ParseExpr
-> [(String, E.ParseExpr)]
-> IParser E.ParseExpr
split _ _ e [] = return e
split table n e eops = do
assoc <- getAssoc table n eops
@ -49,26 +50,26 @@ split table n e eops = do
case assoc of R -> joinR es ops
_ -> joinL es ops
splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
-> [IParser E.LParseExpr]
splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
-> [IParser E.ParseExpr]
splitLevel table n e eops =
case break (hasLevel table n) eops of
(lops, (op,e'):rops) ->
(lops, (_op,e'):rops) ->
split table (n+1) e lops : splitLevel table n e' rops
(lops, []) -> [ split table (n+1) e lops ]
joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
joinL [e] [] = return e
joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
joinR [e] [] = return e
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
return (merge a e (E.Binop op a e))
joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc
getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc
getAssoc table n eops
| all (==L) assocs = return L
| all (==R) assocs = return R
@ -79,5 +80,5 @@ getAssoc table n eops
assocs = map (opAssoc table . fst) levelOps
msg problem =
concat [ "Conflicting " ++ problem ++ " for binary operators ("
, intercalate ", " (map fst eops), "). "
, List.intercalate ", " (map fst eops), "). "
, "Consider adding parentheses to disambiguate." ]

137
compiler/Parse/Expression.hs
View file

@ -5,45 +5,45 @@ import Data.List (foldl')
import Text.Parsec hiding (newline,spaces)
import Text.Parsec.Indent
import Parse.Binop
import Parse.Helpers
import Parse.Literal
import qualified Parse.Pattern as Pattern
import qualified Parse.Type as Type
import Parse.Binop
import Parse.Literal
import SourceSyntax.Location as Location
import SourceSyntax.Pattern hiding (tuple,list)
import qualified SourceSyntax.Literal as Literal
import SourceSyntax.Annotation as Annotation
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Literal as L
import SourceSyntax.Expression
-------- Basic Terms --------
varTerm :: IParser ParseExpr
varTerm :: IParser ParseExpr'
varTerm = toVar <$> var <?> "variable"
toVar :: String -> ParseExpr
toVar v = case v of "True" -> Literal (Literal.Boolean True)
"False" -> Literal (Literal.Boolean False)
_ -> Var v
toVar :: String -> ParseExpr'
toVar v = case v of "True" -> Literal (L.Boolean True)
"False" -> Literal (L.Boolean False)
_ -> rawVar v
accessor :: IParser ParseExpr
accessor :: IParser ParseExpr'
accessor = do
(start, lbl, end) <- located (try (string "." >> rLabel))
let loc e = Location.at start end e
return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
let loc e = Annotation.at start end e
return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
negative :: IParser ParseExpr
negative :: IParser ParseExpr'
negative = do
(start, nTerm, end) <-
located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
let loc e = Location.at start end e
return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
let loc e = Annotation.at start end e
return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
-------- Complex Terms --------
listTerm :: IParser ParseExpr
listTerm :: IParser ParseExpr'
listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
where
range = do
@ -60,92 +60,93 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
span uid index =
"<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
interpolation uid md exprs = do
interpolation uid exprs = do
try (string "{{")
e <- padded expr
string "}}"
return (md ++ span uid (length exprs), exprs ++ [e])
return (span uid (length exprs), exprs ++ [e])
parensTerm :: IParser LParseExpr
parensTerm :: IParser ParseExpr
parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
where
opFn = do
(start, op, end) <- located anyOp
let loc = Location.at start end
return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
Binop op (loc $ Var "x") (loc $ Var "y")
let loc = Annotation.at start end
return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
Binop op (loc $ rawVar "x") (loc $ rawVar "y")
tupleFn = do
let comma = char ',' <?> "comma ','"
(start, commas, end) <- located (comma >> many (whitespace >> comma))
let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
loc = Location.at start end
loc = Annotation.at start end
return $ foldr (\x e -> loc $ Lambda x e)
(loc . tuple $ map (loc . Var) vars) (map PVar vars)
(loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
parened = do
(start, es, end) <- located (commaSep expr)
return $ case es of
[e] -> e
_ -> Location.at start end (tuple es)
_ -> Annotation.at start end (tuple es)
recordTerm :: IParser LParseExpr
recordTerm :: IParser ParseExpr
recordTerm = brackets $ choice [ misc, addLocation record ]
where field = do
label <- rLabel
patterns <- spacePrefix Pattern.term
padded equals
body <- expr
return (label, makeFunction patterns body)
where
field = do
label <- rLabel
patterns <- spacePrefix Pattern.term
padded equals
body <- expr
return (label, makeFunction patterns body)
record = Record <$> commaSep field
record = Record <$> commaSep field
change = do
lbl <- rLabel
padded (string "<-")
(,) lbl <$> expr
change = do
lbl <- rLabel
padded (string "<-")
(,) lbl <$> expr
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
insert r = addLocation $ do
string "|" >> whitespace
Insert r <$> rLabel <*> (padded equals >> expr)
insert r = addLocation $ do
string "|" >> whitespace
Insert r <$> rLabel <*> (padded equals >> expr)
modify r = addLocation
(string "|" >> whitespace >> Modify r <$> commaSep1 change)
modify r =
addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
misc = try $ do
record <- addLocation (Var <$> rLabel)
opt <- padded (optionMaybe (remove record))
case opt of
Just e -> try (insert e) <|> return e
Nothing -> try (insert record) <|> try (modify record)
misc = try $ do
record <- addLocation (rawVar <$> rLabel)
opt <- padded (optionMaybe (remove record))
case opt of
Just e -> try (insert e) <|> return e
Nothing -> try (insert record) <|> try (modify record)
term :: IParser LParseExpr
term :: IParser ParseExpr
term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
<?> "basic term (4, x, 'c', etc.)"
-------- Applications --------
appExpr :: IParser LParseExpr
appExpr :: IParser ParseExpr
appExpr = do
t <- term
ts <- constrainedSpacePrefix term $ \str ->
if null str then notFollowedBy (char '-') else return ()
return $ case ts of
[] -> t
_ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
_ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
-------- Normal Expressions --------
binaryExpr :: IParser LParseExpr
binaryExpr :: IParser ParseExpr
binaryExpr = binops appExpr lastExpr anyOp
where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr
ifExpr :: IParser ParseExpr
ifExpr :: IParser ParseExpr'
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
where
normal = do
@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
elseBranch <- expr
return $ MultiIf [(bool, thenBranch),
(Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
(Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
multiIf = MultiIf <$> spaceSep1 iff
where iff = do string "|" ; whitespace
b <- expr ; padded arrow
(,) b <$> expr
lambdaExpr :: IParser LParseExpr
lambdaExpr :: IParser ParseExpr
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
whitespace
args <- spaceSep1 Pattern.term
@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
defSet :: IParser [ParseDef]
defSet = block (do d <- def ; whitespace ; return d)
letExpr :: IParser ParseExpr
letExpr :: IParser ParseExpr'
letExpr = do
reserved "let" ; whitespace
defs <- defSet
padded (reserved "in")
Let defs <$> expr
caseExpr :: IParser ParseExpr
caseExpr :: IParser ParseExpr'
caseExpr = do
reserved "case"; e <- padded expr; reserved "of"; whitespace
Case e <$> (with <|> without)
@ -189,35 +190,35 @@ caseExpr = do
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
without = block (do c <- case_ ; whitespace ; return c)
expr :: IParser LParseExpr
expr :: IParser ParseExpr
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr
<|> binaryExpr
<?> "an expression"
defStart :: IParser [Pattern]
defStart :: IParser [P.Pattern]
defStart =
choice [ do p1 <- try Pattern.term
infics p1 <|> func p1
, func =<< (PVar <$> parens symOp)
, func =<< (P.Var <$> parens symOp)
, (:[]) <$> Pattern.expr
] <?> "the definition of a variable (x = ...)"
where
func pattern =
case pattern of
PVar _ -> (pattern:) <$> spacePrefix Pattern.term
P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
_ -> do try (lookAhead (whitespace >> string "="))
return [pattern]
infics p1 = do
o:p <- try (whitespace >> anyOp)
p2 <- (whitespace >> Pattern.term)
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
else [ PVar (o:p), p1, p2 ]
return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
else [ P.Var (o:p), p1, p2 ]
makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
makeFunction args body@(L s _) =
foldr (\arg body' -> L s $ Lambda arg body') body args
makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
makeFunction args body@(A ann _) =
foldr (\arg body' -> A ann $ Lambda arg body') body args
definition :: IParser ParseDef
definition = withPos $ do

42
compiler/Parse/Helpers.hs
View file

@ -12,11 +12,12 @@ import Text.Parsec hiding (newline,spaces,State)
import Text.Parsec.Indent
import qualified Text.Parsec.Token as T
import SourceSyntax.Helpers as Help
import SourceSyntax.Location as Location
import SourceSyntax.Expression
import SourceSyntax.PrettyPrint
import SourceSyntax.Annotation as Annotation
import SourceSyntax.Declaration (Assoc)
import SourceSyntax.Expression
import SourceSyntax.Helpers as Help
import SourceSyntax.PrettyPrint
import SourceSyntax.Variable as Variable
reserveds = [ "if", "then", "else"
, "case", "of"
@ -168,7 +169,8 @@ betwixt a b c = do char a ; out <- c
char b <?> "closing '" ++ [b] ++ "'" ; return out
surround a z name p = do
char a ; v <- padded p
char a
v <- padded p
char z <?> unwords ["closing", name, show z]
return v
@ -181,10 +183,10 @@ parens = surround '(' ')' "paren"
brackets :: IParser a -> IParser a
brackets = surround '{' '}' "bracket"
addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
addLocation expr = do
(start, e, end) <- located expr
return (Location.at start end e)
return (Annotation.at start end e)
located :: IParser a -> IParser (SourcePos, a, SourcePos)
located p = do
@ -193,10 +195,10 @@ located p = do
end <- getPosition
return (start, e, end)
accessible :: IParser LParseExpr -> IParser LParseExpr
accessible :: IParser ParseExpr -> IParser ParseExpr
accessible expr = do
start <- getPosition
ce@(L _ e) <- expr
ce@(A _ e) <- expr
let rest f = do
let dot = char '.' >> notFollowedBy (char '.')
access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@ -205,10 +207,12 @@ accessible expr = do
Just _ -> accessible $ do
v <- var <?> "field access (e.g. List.map)"
end <- getPosition
return (Location.at start end (f v))
case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
| otherwise -> rest (Access ce)
_ -> rest (Access ce)
return (Annotation.at start end (f v))
case e of
Var (Variable.Raw (c:cs))
| isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
| otherwise -> rest (Access ce)
_ -> rest (Access ce)
spaces :: IParser String
@ -268,7 +272,7 @@ ignoreUntil end = go
ignore p = const () <$> p
filler = choice [ try (ignore chr) <|> ignore str
, ignore multiComment
, ignore (markdown (\_ _ -> mzero))
, ignore (markdown (\_ -> mzero))
, ignore anyChar
]
go = choice [ Just <$> end
@ -301,15 +305,15 @@ anyUntilPos pos = go
True -> return []
False -> (:) <$> anyChar <*> go
markdown :: (String -> [a] -> IParser (String, [a])) -> IParser (String, [a])
markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])
markdown interpolation = try (string "[markdown|") >> closeMarkdown (++ "") []
where
closeMarkdown md stuff =
choice [ do try (string "|]")
return (md, stuff)
, uncurry closeMarkdown =<< interpolation md stuff
return (md "", stuff)
, (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff
, do c <- anyChar
closeMarkdown (md ++ [c]) stuff
closeMarkdown (md . ([c]++)) stuff
]
--str :: IParser String

42
compiler/Parse/Literal.hs
View file

@ -1,4 +1,4 @@
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# OPTIONS_GHC -W #-}
module Parse.Literal (literal) where
import Control.Applicative ((<$>))
@ -7,16 +7,34 @@ import Parse.Helpers
import SourceSyntax.Literal
literal :: IParser Literal
literal = num <|> (Str <$> str) <|> (Chr <$> chr)
literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"
num :: IParser Literal
num = fmap toLit (preNum <?> "number")
where toLit n | '.' `elem` n = FloatNum (read n)
| otherwise = IntNum (read n)
preNum = concat <$> sequence [ option "" minus, many1 digit, option "" postNum ]
postNum = do try $ lookAhead (string "." >> digit)
string "."
('.':) <$> many1 digit
minus = try $ do string "-"
lookAhead digit
return "-"
num = toLit <$> (number <?> "number")
where
toLit n
| any (`elem` ".eE") n = FloatNum (read n)
| otherwise = IntNum (read n)
number = concat <$> sequence
[ option "" minus
, many1 digit
, option "" decimals
, option "" exponent ]
minus = try $ do
string "-"
lookAhead digit
return "-"
decimals = do
try $ lookAhead (string "." >> digit)
string "."
n <- many1 digit
return ('.' : n)
exponent = do
string "e" <|> string "E"
op <- option "" (string "+" <|> string "-")
n <- many1 digit
return ('e' : op ++ n)

25
compiler/Parse/Module.hs
View file

@ -8,7 +8,7 @@ import Parse.Helpers
import SourceSyntax.Module (ImportMethod(..), Imports)
varList :: IParser [String]
varList = parens $ commaSep1 (var <|> parens symOp)
varList = commaSep1 (var <|> parens symOp)
getModuleName :: String -> Maybe String
getModuleName source =
@ -27,7 +27,7 @@ moduleDef = do
whitespace
names <- dotSep1 capVar <?> "name of module"
whitespace
exports <- option [] varList
exports <- option [] (parens varList)
whitespace <?> "reserved word 'where'"
reserved "where"
return (names, exports)
@ -38,17 +38,22 @@ imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
import' :: IParser (String, ImportMethod)
import' =
do reserved "import"
whitespace
open <- optionMaybe (reserved "open")
whitespace
name <- intercalate "." <$> dotSep1 capVar
case open of
Just _ -> return (name, Hiding [])
Nothing -> let how = try (whitespace >> (as' <|> importing'))
in (,) name <$> option (As name) how
(,) name <$> option (As name) method
where
method :: IParser ImportMethod
method = try $ do whitespace
as' <|> importing'
as' :: IParser ImportMethod
as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
as' = do
reserved "as"
whitespace
As <$> capVar <?> "alias for module"
importing' :: IParser ImportMethod
importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
importing' =
parens (choice [ const (Hiding []) <$> string ".."
, Importing <$> varList
] <?> "listing of imported values (x,y,z)")

56
compiler/Parse/Pattern.hs
View file

@ -3,57 +3,59 @@ module Parse.Pattern (term, expr) where
import Control.Applicative ((<$>))
import Data.Char (isUpper)
import Data.List (intercalate)
import qualified Data.List as List
import Text.Parsec hiding (newline,spaces,State)
import Parse.Helpers
import Parse.Literal
import SourceSyntax.Literal
import SourceSyntax.Pattern hiding (tuple, list)
import qualified SourceSyntax.Pattern as Pattern
import qualified SourceSyntax.Pattern as P
basic :: IParser Pattern
basic :: IParser P.Pattern
basic = choice
[ char '_' >> return PAnything
[ char '_' >> return P.Anything
, do v <- var
return $ case v of
"True" -> PLiteral (Boolean True)
"False" -> PLiteral (Boolean False)
c:_ | isUpper c -> PData v []
_ -> PVar v
, PLiteral <$> literal
"True" -> P.Literal (Boolean True)
"False" -> P.Literal (Boolean False)
c:_ | isUpper c -> P.Data v []
_ -> P.Var v
, P.Literal <$> literal
]
asPattern :: Pattern -> IParser Pattern
asPattern :: P.Pattern -> IParser P.Pattern
asPattern pattern = do
var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
return $ case var of
Just v -> PAlias v pattern
Just v -> P.Alias v pattern
Nothing -> pattern
record :: IParser Pattern
record = PRecord <$> brackets (commaSep1 lowVar)
record :: IParser P.Pattern
record = P.Record <$> brackets (commaSep1 lowVar)
tuple :: IParser Pattern
tuple = do ps <- parens (commaSep expr)
return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
tuple :: IParser P.Pattern
tuple = do
ps <- parens (commaSep expr)
return $ case ps of
[p] -> p
_ -> P.tuple ps
list :: IParser Pattern
list = Pattern.list <$> braces (commaSep expr)
list :: IParser P.Pattern
list = P.list <$> braces (commaSep expr)
term :: IParser Pattern
term :: IParser P.Pattern
term =
(choice [ record, tuple, list, basic ]) <?> "pattern"
patternConstructor :: IParser Pattern
patternConstructor :: IParser P.Pattern
patternConstructor = do
v <- intercalate "." <$> dotSep1 capVar
v <- List.intercalate "." <$> dotSep1 capVar
case v of
"True" -> return $ PLiteral (Boolean True)
"False" -> return $ PLiteral (Boolean False)
_ -> PData v <$> spacePrefix term
"True" -> return $ P.Literal (Boolean True)
"False" -> return $ P.Literal (Boolean False)
_ -> P.Data v <$> spacePrefix term
expr :: IParser Pattern
expr :: IParser P.Pattern
expr = do
patterns <- consSep1 (patternConstructor <|> term)
asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
asPattern (foldr1 P.cons patterns) <?> "pattern"

74
compiler/SourceSyntax/Annotation.hs Normal file
View file

@ -0,0 +1,74 @@
{-# OPTIONS_GHC -W #-}
module SourceSyntax.Annotation where
import qualified Text.Parsec.Pos as Parsec
import qualified Text.PrettyPrint as P
import SourceSyntax.PrettyPrint
data Annotated annotation expr = A annotation expr
deriving (Show)
data Region
= Span Position Position P.Doc
| None P.Doc
deriving (Show)
data Position = Position
{ line :: Int
, column :: Int
} deriving (Show)
type Located expr = Annotated Region expr
none e = A (None (pretty e)) e
noneNoDocs e = A (None P.empty) e
at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr
-> Annotated Region expr
at start end e =
A (Span (position start) (position end) (pretty e)) e
where
position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
merge (A s1 _) (A s2 _) e =
A (span (pretty e)) e
where
span = case (s1,s2) of
(Span start _ _, Span _ end _) -> Span start end
(Span start end _, _) -> Span start end
(_, Span start end _) -> Span start end
(_, _) -> None
mergeOldDocs (A s1 _) (A s2 _) e =
A span e
where
span = case (s1,s2) of
(Span start _ d1, Span _ end d2) ->
Span start end (P.vcat [d1, P.text "\n", d2])
(Span _ _ _, _) -> s1
(_, Span _ _ _) -> s2
(_, _) -> None P.empty
sameAs :: Annotated a expr -> expr' -> Annotated a expr'
sameAs (A annotation _) expr = A annotation expr
getRegionDocs region =
case region of
Span _ _ doc -> doc
None doc -> doc
instance Pretty Region where
pretty span =
case span of
None _ -> P.empty
Span start end _ ->
P.text $
case line start == line end of
False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
True -> "on line " ++ show (line end) ++ ", column " ++
show (column start) ++ " to " ++ show (column end)
instance Pretty e => Pretty (Annotated a e) where
pretty (A _ e) = pretty e

4
compiler/SourceSyntax/Declaration.hs
View file

@ -20,11 +20,11 @@ data Assoc = L | N | R
data ParsePort
= PPAnnotation String T.Type
| PPDef String Expr.LParseExpr
| PPDef String Expr.ParseExpr
deriving (Show)
data Port
= Out String Expr.LExpr T.Type
= Out String Expr.Expr T.Type
| In String T.Type
deriving (Show)

150
compiler/SourceSyntax/Expression.hs
View file

@ -11,49 +11,54 @@ module SourceSyntax.Expression where
import SourceSyntax.PrettyPrint
import Text.PrettyPrint as P
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.Location as Location
import qualified SourceSyntax.Annotation as Annotation
import qualified SourceSyntax.Pattern as Pattern
import qualified SourceSyntax.Type as SrcType
import qualified SourceSyntax.Literal as Literal
import qualified SourceSyntax.Variable as Variable
---- GENERAL AST ----
{-| This is a located expression, meaning it is tagged with info about where it
came from in the source code. Expr' is defined in terms of LExpr' so that the
location information does not need to be an extra field on every constructor.
-}
type LExpr' def = Location.Located (Expr' def)
{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
"type holes" that allow us to enrich the AST with additional information as we
move through the compilation process. The type holes let us show these
structural changes in the types. The only type hole right now is:
move through the compilation process. The type holes are used to represent:
def: Parsing allows two kinds of definitions (type annotations or definitions),
but later checks will see that they are well formed and combine them.
ann: Annotations for arbitrary expressions. Allows you to add information
to the AST like position in source code or inferred types.
def: Definition style. The source syntax separates type annotations and
definitions, but after parsing we check that they are well formed and
collapse them.
var: Representation of variables. Starts as strings, but is later enriched
with information about what module a variable came from.
-}
data Expr' def
type GeneralExpr annotation definition variable =
Annotation.Annotated annotation (GeneralExpr' annotation definition variable)
data GeneralExpr' ann def var
= Literal Literal.Literal
| Var String
| Range (LExpr' def) (LExpr' def)
| ExplicitList [LExpr' def]
| Binop String (LExpr' def) (LExpr' def)
| Lambda Pattern.Pattern (LExpr' def)
| App (LExpr' def) (LExpr' def)
| MultiIf [(LExpr' def,LExpr' def)]
| Let [def] (LExpr' def)
| Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
| Data String [LExpr' def]
| Access (LExpr' def) String
| Remove (LExpr' def) String
| Insert (LExpr' def) String (LExpr' def)
| Modify (LExpr' def) [(String, LExpr' def)]
| Record [(String, LExpr' def)]
| Markdown String String [LExpr' def]
| Var var
| Range (GeneralExpr ann def var) (GeneralExpr ann def var)
| ExplicitList [GeneralExpr ann def var]
| Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
| Lambda Pattern.Pattern (GeneralExpr ann def var)
| App (GeneralExpr ann def var) (GeneralExpr ann def var)
| MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
| Let [def] (GeneralExpr ann def var)
| Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
| Data String [GeneralExpr ann def var]
| Access (GeneralExpr ann def var) String
| Remove (GeneralExpr ann def var) String
| Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
| Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
| Record [(String, GeneralExpr ann def var)]
| Markdown String String [GeneralExpr ann def var]
-- for type checking and code gen only
| PortIn String SrcType.Type
| PortOut String SrcType.Type (LExpr' def)
| PortOut String SrcType.Type (GeneralExpr ann def var)
deriving (Show)
---- SPECIALIZED ASTs ----
@ -62,81 +67,100 @@ data Expr' def
annotations and definitions, which is how they appear in source code and how
they are parsed.
-}
type ParseExpr = Expr' ParseDef
type LParseExpr = LExpr' ParseDef
type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
data ParseDef
= Def Pattern.Pattern LParseExpr
= Def Pattern.Pattern ParseExpr
| TypeAnnotation String SrcType.Type
deriving (Show)
deriving (Show)
{-| "Normal" expressions. When the compiler checks that type annotations and
ports are all paired with definitions in the appropriate order, it collapses
them into a Def that is easier to work with in later phases of compilation.
-}
type LExpr = LExpr' Def
type Expr = Expr' Def
type Expr = GeneralExpr Annotation.Region Def Variable.Raw
type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw
data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)
deriving (Show)
---- UTILITIES ----
tuple :: [LExpr' def] -> Expr' def
rawVar :: String -> GeneralExpr' ann def Variable.Raw
rawVar x = Var (Variable.Raw x)
tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var
tuple es = Data ("_Tuple" ++ show (length es)) es
delist :: LExpr' def -> [LExpr' def]
delist (Location.L _ (Data "::" [h,t])) = h : delist t
delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
delist _ = []
saveEnvName :: String
saveEnvName = "_save_the_environment!!!"
dummyLet :: Pretty def => [def] -> LExpr' def
dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
dummyLet defs =
Location.none $ Let defs (Location.none $ Var saveEnvName)
Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)
instance Pretty def => Show (Expr' def) where
show = render . pretty
instance Pretty def => Pretty (Expr' def) where
instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
pretty expr =
case expr of
Literal lit -> pretty lit
Var x -> variable x
Var x -> pretty x
Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
ExplicitList es -> P.brackets (commaCat (map pretty es))
Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->
P.text "-" <> prettyParens e
Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
where op' = if Help.isOp op then op else "`" ++ op ++ "`"
where
op' = if Help.isOp op then op else "`" ++ op ++ "`"
Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
where
(ps,body) = collectLambdas (Location.none $ Lambda p e)
(ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
args = P.sep (map Pattern.prettyParens ps)
App _ _ -> P.hang func 2 (P.sep args)
where func:args = map prettyParens (collectApps (Location.none expr))
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
where
func:args = map prettyParens (collectApps (Annotation.A undefined expr))
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
where
iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
Let defs e ->
P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
, P.text "in" <+> pretty e ]
Case e pats ->
P.hang pexpr 2 (P.vcat (map pretty' pats))
where
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
Data "[]" [] -> P.text "[]"
Data name es
| Help.isTuple name -> P.parens (commaCat (map pretty es))
| otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
Access e x -> prettyParens e <> P.text "." <> variable x
Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
Insert (Location.L _ (Remove e y)) x v ->
P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
Insert (Annotation.A _ (Remove e y)) x v ->
P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
, variable x, P.equals, pretty v ]
Insert e x v ->
P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
@ -175,21 +199,23 @@ 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) =
collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
collectApps annExpr@(Annotation.A _ expr) =
case expr of
App a b -> collectApps a ++ [b]
_ -> [lexpr]
_ -> [annExpr]
collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
collectLambdas lexpr@(Location.L _ expr) =
collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
collectLambdas lexpr@(Annotation.A _ expr) =
case expr of
Lambda pattern body -> (pattern : ps, body')
where (ps, body') = collectLambdas body
Lambda pattern body ->
let (ps, body') = collectLambdas body
in (pattern : ps, body')
_ -> ([], lexpr)
prettyParens :: (Pretty def) => LExpr' def -> Doc
prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
where
needed =
case expr of

9
compiler/SourceSyntax/Helpers.hs
View file

@ -3,6 +3,15 @@ module SourceSyntax.Helpers where
import qualified Data.Char as Char
splitDots :: String -> [String]
splitDots = go []
where
go vars str =
case break (=='.') str of
(x,_:rest) | isOp x -> vars ++ [x ++ '.' : rest]
| otherwise -> go (vars ++ [x]) rest
(x,[]) -> vars ++ [x]
brkt :: String -> String
brkt s = "{ " ++ s ++ " }"

58
compiler/SourceSyntax/Location.hs
View file

@ -1,58 +0,0 @@
module SourceSyntax.Location where
import Text.PrettyPrint
import SourceSyntax.PrettyPrint
import qualified Text.Parsec.Pos as Parsec
data SrcPos = Pos { line :: Int, column :: Int }
deriving (Eq, Ord)
data SrcSpan = Span SrcPos SrcPos String | NoSpan String
deriving (Eq, Ord)
data Located e = L SrcSpan e
deriving (Eq, Ord)
none e = L (NoSpan (render $ pretty e)) e
noneNoDocs = L (NoSpan "")
at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))
(Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))
(render $ pretty e)) e
merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e
where span = case (s1,s2) of
(Span start _ _, Span _ end _) -> Span start end
(Span start end _, _) -> Span start end
(_, Span start end _) -> Span start end
(_, _) -> NoSpan
mergeOldDocs (L s1 _) (L s2 _) e = L span e
where span = case (s1,s2) of
(Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)
(Span _ _ _, _) -> s1
(_, Span _ _ _) -> s2
(_, _) -> NoSpan ""
sameAs (L s _) = L s
instance Show SrcPos where
show (Pos r c) = show r ++ "," ++ show c
instance Show SrcSpan where
show span =
case span of
NoSpan _ -> ""
Span start end _ ->
case line start == line end of
False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
True -> "on line " ++ show (line end) ++ ", column " ++
show (column start) ++ " to " ++ show (column end)
instance Show e => Show (Located e) where
show (L _ e) = show e
instance Pretty a => Pretty (Located a) where
pretty (L _ e) = pretty e

36
compiler/SourceSyntax/Module.hs
View file

@ -1,12 +1,15 @@
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -W #-}
module SourceSyntax.Module where
import Data.Binary
import qualified Data.List as List
import qualified Data.Map as Map
import Control.Applicative ((<$>), (<*>))
import Text.PrettyPrint as P
import SourceSyntax.Expression (LExpr)
import SourceSyntax.Expression (Expr)
import SourceSyntax.Declaration
import SourceSyntax.PrettyPrint
import SourceSyntax.Type
import qualified Elm.Internal.Version as Version
@ -21,6 +24,33 @@ type Imports = [(String, ImportMethod)]
data ImportMethod = As String | Importing [String] | Hiding [String]
deriving (Eq, Ord, Show)
instance (Pretty def) => Pretty (Module def) where
pretty (Module modNames exports imports decls) =
P.vcat [modul, P.text "", prettyImports, P.text "", prettyDecls]
where
prettyDecls = P.sep $ map pretty decls
modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"
moduleName = P.text $ List.intercalate "." modNames
prettyExports =
case exports of
[] -> P.empty
_ -> P.parens . commaCat $ map P.text exports
prettyImports = P.vcat $ map prettyImport imports
prettyImport (name, method) =
P.text "import" <+>
case method of
As alias ->
P.text $ name ++ (if name == alias then "" else " as " ++ alias)
Importing values ->
P.text name <+> P.parens (commaCat (map P.text values))
Hiding [] -> P.text ("open " ++ name)
Hiding _ -> error "invalid import declaration"
instance Binary ImportMethod where
put method =
let put' n info = putWord8 n >> put info in
@ -42,7 +72,7 @@ data MetadataModule =
, path :: FilePath
, exports :: [String]
, imports :: [(String, ImportMethod)]
, program :: LExpr
, program :: Expr
, types :: Map.Map String Type
, fixities :: [(Assoc, Int, String)]
, aliases :: [Alias]

56
compiler/SourceSyntax/Pattern.hs
View file

@ -7,50 +7,54 @@ import Text.PrettyPrint as PP
import qualified Data.Set as Set
import SourceSyntax.Literal as Literal
data Pattern = PData String [Pattern]
| PRecord [String]
| PAlias String Pattern
| PVar String
| PAnything
| PLiteral Literal.Literal
deriving (Eq, Ord, Show)
data Pattern
= Data String [Pattern]
| Record [String]
| Alias String Pattern
| Var String
| Anything
| Literal Literal.Literal
deriving (Eq, Ord, Show)
cons :: Pattern -> Pattern -> Pattern
cons h t = PData "::" [h,t]
cons h t = Data "::" [h,t]
nil :: Pattern
nil = PData "[]" []
nil = Data "[]" []
list :: [Pattern] -> Pattern
list = foldr cons nil
tuple :: [Pattern] -> Pattern
tuple es = PData ("_Tuple" ++ show (length es)) es
tuple es = Data ("_Tuple" ++ show (length es)) es
boundVarList :: Pattern -> [String]
boundVarList = Set.toList . boundVars
boundVars :: Pattern -> Set.Set String
boundVars pattern =
case pattern of
PVar x -> Set.singleton x
PAlias x p -> Set.insert x (boundVars p)
PData _ ps -> Set.unions (map boundVars ps)
PRecord fields -> Set.fromList fields
PAnything -> Set.empty
PLiteral _ -> Set.empty
Var x -> Set.singleton x
Alias x p -> Set.insert x (boundVars p)
Data _ ps -> Set.unions (map boundVars ps)
Record fields -> Set.fromList fields
Anything -> Set.empty
Literal _ -> Set.empty
instance Pretty Pattern where
pretty pattern =
case pattern of
PVar x -> variable x
PLiteral lit -> pretty lit
PRecord fs -> PP.braces (commaCat $ map variable fs)
PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
PAnything -> PP.text "_"
PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
Var x -> variable x
Literal lit -> pretty lit
Record fs -> PP.braces (commaCat $ map variable fs)
Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
Anything -> PP.text "_"
Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
where isCons = case hd of
PData "::" _ -> True
Data "::" _ -> True
_ -> False
PData name ps ->
Data name ps ->
if Help.isTuple name then
PP.parens . commaCat $ map pretty ps
else hsep (PP.text name : map prettyParens ps)
@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
where
needsThem =
case pattern of
PData name (_:_) | not (Help.isTuple name) -> True
PAlias _ _ -> True
Data name (_:_) | not (Help.isTuple name) -> True
Alias _ _ -> True
_ -> False

5
compiler/SourceSyntax/PrettyPrint.hs
View file

@ -10,11 +10,16 @@ class Pretty a where
instance Pretty () where
pretty () = empty
renderPretty :: (Pretty a) => a -> String
renderPretty e = render (pretty e)
commaCat docs = cat (punctuate comma docs)
commaSep docs = sep (punctuate comma docs)
parensIf :: Bool -> Doc -> Doc
parensIf bool doc = if bool then parens doc else doc
variable :: String -> Doc
variable x =
if Help.isOp x then parens (text x)
else text (reprime x)

9
compiler/SourceSyntax/Type.hs
View file

@ -1,18 +1,18 @@
{-# OPTIONS_GHC -W #-}
module SourceSyntax.Type where
import Control.Applicative ((<$>), (<*>))
import Data.Binary
import qualified Data.Map as Map
import qualified SourceSyntax.Helpers as Help
import Control.Applicative ((<$>), (<*>))
import SourceSyntax.PrettyPrint
import qualified SourceSyntax.Helpers as Help
import Text.PrettyPrint as P
data Type = Lambda Type Type
| Var String
| Data String [Type]
| Record [(String,Type)] (Maybe String)
deriving (Eq)
deriving (Eq,Show)
fieldMap :: [(String,a)] -> Map.Map String [a]
fieldMap fields =
@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
tupleOf :: [Type] -> Type
tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
instance Show Type where
show = render . pretty
instance Pretty Type where
pretty tipe =
case tipe of

11
compiler/SourceSyntax/Variable.hs Normal file
View file

@ -0,0 +1,11 @@
module SourceSyntax.Variable where
import qualified Text.PrettyPrint as P
import SourceSyntax.PrettyPrint
newtype Raw = Raw String
deriving (Eq,Ord,Show)
instance Pretty Raw where
pretty (Raw var) = variable var

52
compiler/Transform/Canonicalize.hs
View file

@ -1,19 +1,21 @@
{-# OPTIONS_GHC -W #-}
{-# OPTIONS_GHC -Wall #-}
module Transform.Canonicalize (interface, metadataModule) where
import Control.Arrow ((***))
import Control.Applicative (Applicative,(<$>),(<*>))
import Control.Monad.Identity
import qualified Data.Traversable as T
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
import qualified Data.Either as Either
import SourceSyntax.Module
import qualified Data.Traversable as T
import SourceSyntax.Annotation as A
import SourceSyntax.Expression
import SourceSyntax.Location as Loc
import SourceSyntax.Module
import SourceSyntax.PrettyPrint (pretty)
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as Type
import qualified SourceSyntax.Variable as Var
import Text.PrettyPrint as P
interface :: String -> ModuleInterface -> ModuleInterface
@ -55,7 +57,9 @@ metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
metadataModule ifaces modul =
do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
[] -> Right ()
missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++
"\n You may need to compile with the --make flag to detect modules you have written."
]
program' <- rename initialEnv (program modul)
aliases' <- mapM (three3 renameType') (aliases modul)
datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
@ -94,8 +98,7 @@ type Env = Map.Map String String
extend :: Env -> P.Pattern -> Env
extend env pattern = Map.union (Map.fromList (zip xs xs)) env
where xs = Set.toList (P.boundVars pattern)
where xs = P.boundVarList pattern
replace :: String -> Env -> String -> Either String String
replace variable env v =
@ -108,14 +111,18 @@ replace variable env v =
msg = if null matches then "" else
"\nClose matches include: " ++ List.intercalate ", " matches
rename :: Env -> LExpr -> Either [Doc] LExpr
rename env (L s expr) =
-- TODO: Var.Raw -> Var.Canonical
rename :: Env -> Expr -> Either [Doc] Expr
rename env (A ann expr) =
let rnm = rename env
throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon
, P.text err
]
]
format = Either.either throw return
renameType' env = renameType (format . replace "variable" env)
renameType' environ = renameType (format . replace "variable" environ)
in
L s <$>
A ann <$>
case expr of
Literal _ -> return expr
@ -153,7 +160,8 @@ rename env (L s expr) =
<*> rename env' body
<*> T.traverse (renameType' env') mtipe
Var x -> Var <$> format (replace "variable" env x)
-- TODO: Raw -> Canonical
Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
Data name es -> Data name <$> mapM rnm es
@ -174,10 +182,10 @@ rename env (L s expr) =
renamePattern :: Env -> P.Pattern -> Either String P.Pattern
renamePattern env pattern =
case pattern of
P.PVar _ -> return pattern
P.PLiteral _ -> return pattern
P.PRecord _ -> return pattern
P.PAnything -> return pattern
P.PAlias x p -> P.PAlias x <$> renamePattern env p
P.PData name ps -> P.PData <$> replace "pattern" env name
<*> mapM (renamePattern env) ps
P.Var _ -> return pattern
P.Literal _ -> return pattern
P.Record _ -> return pattern
P.Anything -> return pattern
P.Alias x p -> P.Alias x <$> renamePattern env p
P.Data name ps -> P.Data <$> replace "pattern" env name
<*> mapM (renamePattern env) ps

9
compiler/Transform/Check.hs
View file

@ -32,7 +32,7 @@ dupErr err x =
duplicates :: [D.Declaration] -> [String]
duplicates decls =
map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
case mapM exprDups (portExprs ++ defExprs) of
Left name -> [msg name]
Right _ -> []
@ -50,14 +50,13 @@ duplicates decls =
D.Out name expr _ -> (name, [expr])
D.In name _ -> (name, [])
getNames = Set.toList . Pattern.boundVars
exprDups :: E.LExpr -> Either String E.LExpr
exprDups :: E.Expr -> Either String E.Expr
exprDups expr = Expr.crawlLet defsDups expr
defsDups :: [E.Def] -> Either String [E.Def]
defsDups defs =
case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in
case dups $ concatMap varsIn defs of
[] -> Right defs
name:_ -> Left name

2
compiler/Transform/Declaration.hs
View file

@ -42,7 +42,7 @@ combineAnnotations = go
TypeAnnotation name tipe ->
case defRest of
D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->
do expr' <- exprCombineAnnotations expr
let def' = E.Definition pat expr' (Just tipe)
(:) (D.Definition def') <$> go rest

2
compiler/Transform/Definition.hs
View file

@ -16,7 +16,7 @@ combineAnnotations = go
go defs =
case defs of
TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->
do expr' <- exprCombineAnnotations expr
let def = Definition pat expr' (Just tipe)
(:) def <$> go rest

28
compiler/Transform/Expression.hs
View file

@ -2,17 +2,19 @@
module Transform.Expression (crawlLet, checkPorts) where
import Control.Applicative ((<$>),(<*>))
import SourceSyntax.Annotation ( Annotated(A) )
import SourceSyntax.Expression
import SourceSyntax.Location
import qualified SourceSyntax.Type as ST
import SourceSyntax.Type (Type)
crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
crawlLet :: ([def] -> Either a [def'])
-> GeneralExpr ann def var
-> Either a (GeneralExpr ann def' var)
crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
checkPorts :: (String -> ST.Type -> Either a ())
-> (String -> ST.Type -> Either a ())
-> LExpr
-> Either a LExpr
checkPorts :: (String -> Type -> Either a ())
-> (String -> Type -> Either a ())
-> Expr
-> Either a Expr
checkPorts inCheck outCheck expr =
crawl inCheck outCheck (mapM checkDef) expr
where
@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =
do _ <- checkPorts inCheck outCheck body
return def
crawl :: (String -> ST.Type -> Either a ())
-> (String -> ST.Type -> Either a ())
crawl :: (String -> Type -> Either a ())
-> (String -> Type -> Either a ())
-> ([def] -> Either a [def'])
-> LExpr' def
-> Either a (LExpr' def')
-> GeneralExpr ann def var
-> Either a (GeneralExpr ann def' var)
crawl portInCheck portOutCheck defsTransform = go
where
go (L srcSpan expr) =
L srcSpan <$>
go (A srcSpan expr) =
A srcSpan <$>
case expr of
Var x -> return (Var x)
Lambda p e -> Lambda p <$> go e

37
compiler/Transform/SafeNames.hs
View file

@ -2,38 +2,43 @@
module Transform.SafeNames (metadataModule) where
import Control.Arrow (first, (***))
import SourceSyntax.Expression
import SourceSyntax.Location
import SourceSyntax.Module
import SourceSyntax.Pattern
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Parse.Helpers as PHelp
import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Helpers as SHelp
import SourceSyntax.Module
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as Variable
var :: String -> String
var = dereserve . deprime
var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
where
deprime = map (\c -> if c == '\'' then '$' else c)
dereserve x = case Set.member x PHelp.jsReserveds of
False -> x
True -> "$" ++ x
pattern :: Pattern -> Pattern
pattern :: P.Pattern -> P.Pattern
pattern pat =
case pat of
PVar x -> PVar (var x)
PLiteral _ -> pat
PRecord fs -> PRecord (map var fs)
PAnything -> pat
PAlias x p -> PAlias (var x) (pattern p)
PData name ps -> PData name (map pattern ps)
P.Var x -> P.Var (var x)
P.Literal _ -> pat
P.Record fs -> P.Record (map var fs)
P.Anything -> pat
P.Alias x p -> P.Alias (var x) (pattern p)
P.Data name ps -> P.Data name (map pattern ps)
expression :: LExpr -> LExpr
expression (L loc expr) =
-- TODO: should be "normal expression" -> "expression for JS generation"
expression :: Expr -> Expr
expression (A ann expr) =
let f = expression in
L loc $
A ann $
case expr of
Literal _ -> expr
Var x -> Var (var x)
Var (Variable.Raw x) -> rawVar (var x)
Range e1 e2 -> Range (f e1) (f e2)
ExplicitList es -> ExplicitList (map f es)
Binop op e1 e2 -> Binop op (f e1) (f e2)

37
compiler/Transform/SortDefinitions.hs
View file

@ -3,23 +3,24 @@ module Transform.SortDefinitions (sortDefs) where
import Control.Monad.State
import Control.Applicative ((<$>),(<*>))
import qualified Data.Map as Map
import SourceSyntax.Expression
import SourceSyntax.Location
import qualified SourceSyntax.Pattern as P
import qualified Data.Graph as Graph
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Variable as V
ctors :: P.Pattern -> [String]
ctors pattern =
case pattern of
P.PVar _ -> []
P.PAlias _ p -> ctors p
P.PData ctor ps -> ctor : concatMap ctors ps
P.PRecord _ -> []
P.PAnything -> []
P.PLiteral _ -> []
P.Var _ -> []
P.Alias _ p -> ctors p
P.Data ctor ps -> ctor : concatMap ctors ps
P.Record _ -> []
P.Anything -> []
P.Literal _ -> []
free :: String -> State (Set.Set String) ()
free x = modify (Set.insert x)
@ -27,15 +28,15 @@ free x = modify (Set.insert x)
bound :: Set.Set String -> State (Set.Set String) ()
bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
sortDefs :: LExpr -> LExpr
sortDefs :: Expr -> Expr
sortDefs expr = evalState (reorder expr) Set.empty
reorder :: LExpr -> State (Set.Set String) LExpr
reorder (L s expr) =
L s <$>
reorder :: Expr -> State (Set.Set String) Expr
reorder (A ann expr) =
A ann <$>
case expr of
-- Be careful adding and restricting freeVars
Var x -> free x >> return expr
Var (V.Raw x) -> free x >> return expr
Lambda p e ->
uncurry Lambda <$> bindingReorder (p,e)
@ -103,11 +104,11 @@ reorder (L s expr) =
bound (P.boundVars pattern)
mapM free (ctors pattern)
let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss
return let'
bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
bindingReorder (pattern,expr) =
do expr' <- reorder expr
bound (P.boundVars pattern)

14
compiler/Transform/Substitute.hs
View file

@ -2,14 +2,16 @@
module Transform.Substitute (subst) where
import Control.Arrow (second, (***))
import SourceSyntax.Expression
import SourceSyntax.Location
import qualified SourceSyntax.Pattern as Pattern
import qualified Data.Set as Set
subst :: String -> Expr -> Expr -> Expr
import SourceSyntax.Annotation
import SourceSyntax.Expression
import qualified SourceSyntax.Pattern as Pattern
import qualified SourceSyntax.Variable as V
subst :: String -> Expr' -> Expr' -> Expr'
subst old new expr =
let f (L s e) = L s (subst old new e) in
let f (A a e) = A a (subst old new e) in
case expr of
Range e1 e2 -> Range (f e1) (f e2)
ExplicitList es -> ExplicitList (map f es)
@ -28,7 +30,7 @@ subst old new expr =
anyShadow =
any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
Var x -> if x == old then new else expr
Var (V.Raw 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)
Access e x -> Access (f e) x

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

@ -1,62 +1,62 @@
{-# OPTIONS_GHC -Wall #-}
module Type.Constrain.Declaration where
import SourceSyntax.Declaration
import qualified SourceSyntax.Annotation as A
import qualified SourceSyntax.Declaration as D
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Location as L
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as T
toExpr :: [Declaration] -> [E.Def]
toExpr :: [D.Declaration] -> [E.Def]
toExpr = concatMap toDefs
toDefs :: Declaration -> [E.Def]
toDefs :: D.Declaration -> [E.Def]
toDefs decl =
case decl of
Definition def -> [def]
D.Definition def -> [def]
Datatype name tvars constructors -> concatMap toDefs' constructors
D.Datatype name tvars constructors -> concatMap toDefs' constructors
where
toDefs' (ctor, tipes) =
let vars = take (length tipes) arguments
tbody = T.Data name $ map T.Var tvars
body = L.none . E.Data ctor $ map (L.none . E.Var) vars
body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars
in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
TypeAlias name _ tipe@(T.Record fields ext) ->
D.TypeAlias name _ tipe@(T.Record fields ext) ->
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
where
args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
var = L.none . E.Var
var = A.none . E.rawVar
vars = take (length args) arguments
efields = zip (map fst fields) (map var vars)
record = case ext of
Nothing -> L.none $ E.Record efields
Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
Nothing -> A.none $ E.Record efields
Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
-- Type aliases must be added to an extended equality dictionary,
-- but they do not require any basic constraints.
TypeAlias _ _ _ -> []
D.TypeAlias _ _ _ -> []
Port port ->
D.Port port ->
case port of
Out name expr@(L.L s _) tipe ->
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
In name tipe ->
[ definition name (L.none $ E.PortIn name tipe) tipe ]
D.Out name expr@(A.A s _) tipe ->
[ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
D.In name tipe ->
[ definition name (A.none $ E.PortIn name tipe) tipe ]
-- no constraints are needed for fixity declarations
Fixity _ _ _ -> []
D.Fixity _ _ _ -> []
arguments :: [String]
arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
buildFunction :: E.LExpr -> [String] -> E.LExpr
buildFunction body@(L.L s _) vars =
foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
buildFunction :: E.Expr -> [String] -> E.Expr
buildFunction body@(A.A s _) vars =
foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
definition :: String -> E.LExpr -> T.Type -> E.Def
definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
definition :: String -> E.Expr -> T.Type -> E.Def
definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)

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

@ -1,44 +1,45 @@
{-# OPTIONS_GHC -W #-}
module Type.Constrain.Expression where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Applicative ((<$>))
import qualified Control.Monad as Monad
import Control.Monad.Error
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Text.PrettyPrint as PP
import SourceSyntax.Location as Loc
import SourceSyntax.Pattern (Pattern(PVar), boundVars)
import SourceSyntax.Annotation as Ann
import SourceSyntax.Expression
import qualified SourceSyntax.Type as SrcT
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as ST
import qualified SourceSyntax.Variable as V
import Type.Type hiding (Descriptor(..))
import Type.Fragment
import qualified Type.Environment as Env
import qualified Type.Constrain.Literal as Literal
import qualified Type.Constrain.Pattern as Pattern
constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
constrain env (L span expr) tipe =
constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
constrain env (A region expr) tipe =
let list t = Env.get env Env.types "_List" <| t
and = L span . CAnd
true = L span CTrue
t1 === t2 = L span (CEqual t1 t2)
x <? t = L span (CInstance x t)
clet schemes c = L span (CLet schemes c)
and = A region . CAnd
true = A region CTrue
t1 === t2 = A region (CEqual t1 t2)
x <? t = A region (CInstance x t)
clet schemes c = A region (CLet schemes c)
in
case expr of
Literal lit -> liftIO $ Literal.constrain env span lit tipe
Literal lit -> liftIO $ Literal.constrain env region lit tipe
Var name | name == saveEnvName -> return (L span CSaveEnv)
| otherwise -> return (name <? tipe)
Var (V.Raw name)
| name == saveEnvName -> return (A region CSaveEnv)
| otherwise -> return (name <? tipe)
Range lo hi ->
exists $ \x -> do
clo <- constrain env lo x
chi <- constrain env hi x
return $ and [clo, chi, list x === tipe]
existsNumber $ \n -> do
clo <- constrain env lo n
chi <- constrain env hi n
return $ and [clo, chi, list n === tipe]
ExplicitList exprs ->
exists $ \x -> do
@ -55,7 +56,7 @@ constrain env (L span expr) tipe =
Lambda p e ->
exists $ \t1 ->
exists $ \t2 -> do
fragment <- try span $ Pattern.constrain env p t1
fragment <- try region $ Pattern.constrain env p t1
c2 <- constrain env e t2
let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
(typeConstraint fragment /\ c2 ))
@ -79,7 +80,7 @@ constrain env (L span expr) tipe =
exists $ \t -> do
ce <- constrain env exp t
let branch (p,e) = do
fragment <- try span $ Pattern.constrain env p t
fragment <- try region $ Pattern.constrain env p t
clet [toScheme fragment] <$> constrain env e tipe
and . (:) ce <$> mapM branch branches
@ -112,11 +113,11 @@ constrain env (L span expr) tipe =
Modify e fields ->
exists $ \t -> do
oldVars <- forM fields $ \_ -> liftIO (var Flexible)
let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))
cOld <- ex oldVars <$> constrain env e (record oldFields t)
newVars <- forM fields $ \_ -> liftIO (var Flexible)
let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))
let cNew = tipe === record newFields t
cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
@ -126,7 +127,7 @@ constrain env (L span expr) tipe =
Record fields ->
do vars <- forM fields $ \_ -> liftIO (var Flexible)
cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))
recordType = record fields' (TermN EmptyRecord1)
return . ex vars . and $ tipe === recordType : cs
@ -158,14 +159,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =
do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
-- Currently, qs is always [].
case (pattern, maybeTipe) of
(PVar name, Just tipe) -> do
(P.Var name, Just tipe) -> do
flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
(vars, typ) <- Env.instantiateType env tipe Map.empty
let scheme = Scheme { rigidQuantifiers = [],
flexibleQuantifiers = flexiVars ++ vars,
constraint = Loc.noneNoDocs CTrue,
constraint = Ann.noneNoDocs CTrue,
header = Map.singleton name typ }
c <- constrain env' expr typ
return ( scheme : schemes
@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
, c2
, fl rigidVars c /\ c1 )
(PVar name, Nothing) -> do
(P.Var name, Nothing) -> do
v <- liftIO $ var Flexible
let tipe = VarN v
inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
@ -191,19 +192,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =
_ -> error (show pattern)
expandPattern :: Def -> [Def]
expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
case pattern of
PVar _ -> [def]
_ -> Definition (PVar x) lexpr maybeType : map toDef vars
P.Var _ -> [def]
_ -> Definition (P.Var x) lexpr maybeType : map toDef vars
where
vars = Set.toList $ boundVars pattern
vars = P.boundVarList pattern
x = "$" ++ concat vars
mkVar = L s . Var
toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
mkVar = A r . rawVar
toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
try span computation = do
try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
try region computation = do
result <- liftIO $ runErrorT computation
case result of
Left err -> throwError [err span]
Left err -> throwError [err region]
Right value -> return value

9
compiler/Type/Constrain/Literal.hs
View file

@ -1,14 +1,15 @@
{-# OPTIONS_GHC -W #-}
module Type.Constrain.Literal where
import SourceSyntax.Annotation
import SourceSyntax.Literal
import SourceSyntax.Location
import Type.Type
import Type.Environment as Env
constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
constrain env span literal tipe =
constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
constrain env region literal tipe =
do tipe' <- litType
return . L span $ CEqual tipe tipe'
return . A region $ CEqual tipe tipe'
where
prim name = return (Env.get env Env.types name)

33
compiler/Type/Constrain/Pattern.hs
View file

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -W #-}
{-# LANGUAGE FlexibleInstances #-}
module Type.Constrain.Pattern where
@ -8,31 +9,29 @@ import Control.Monad.Error
import qualified Data.Map as Map
import qualified Text.PrettyPrint as PP
import SourceSyntax.Pattern
import SourceSyntax.Location
import SourceSyntax.PrettyPrint
import Text.PrettyPrint (render)
import qualified SourceSyntax.Location as Loc
import qualified SourceSyntax.Annotation as A
import qualified SourceSyntax.Pattern as P
import SourceSyntax.PrettyPrint (pretty)
import Type.Type
import Type.Fragment
import Type.Environment as Env
import qualified Type.Constrain.Literal as Literal
constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
constrain env pattern tipe =
let span = Loc.NoSpan (render $ pretty pattern)
t1 === t2 = Loc.L span (CEqual t1 t2)
x <? t = Loc.L span (CInstance x t)
let region = A.None (pretty pattern)
t1 === t2 = A.A region (CEqual t1 t2)
x <? t = A.A region (CInstance x t)
in
case pattern of
PAnything -> return emptyFragment
P.Anything -> return emptyFragment
PLiteral lit -> do
c <- liftIO $ Literal.constrain env span lit tipe
P.Literal lit -> do
c <- liftIO $ Literal.constrain env region lit tipe
return $ emptyFragment { typeConstraint = c }
PVar name -> do
P.Var name -> do
v <- liftIO $ var Flexible
return $ Fragment {
typeEnv = Map.singleton name (VarN v),
@ -40,14 +39,14 @@ constrain env pattern tipe =
typeConstraint = VarN v === tipe
}
PAlias name p -> do
P.Alias name p -> do
fragment <- constrain env p tipe
return $ fragment {
typeEnv = Map.insert name tipe (typeEnv fragment),
typeConstraint = name <? tipe /\ typeConstraint fragment
}
PData name patterns -> do
P.Data name patterns -> do
(kind, cvars, args, result) <- liftIO $ freshDataScheme env name
let msg = concat [ "Constructor '", name, "' expects ", show kind
, " argument", if kind == 1 then "" else "s"
@ -63,7 +62,7 @@ constrain env pattern tipe =
vars = cvars ++ vars fragment
}
PRecord fields -> do
P.Record fields -> do
pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
let tenv = Map.fromList (map (second VarN) pairs)
c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
@ -73,7 +72,7 @@ constrain env pattern tipe =
typeConstraint = c
}
instance Error (SrcSpan -> PP.Doc) where
instance Error (A.Region -> PP.Doc) where
noMsg _ = PP.empty
strMsg str span =
PP.vcat [ PP.text $ "Type error " ++ show span

75
compiler/Type/ExtraChecks.hs
View file

@ -1,32 +1,35 @@
{-# OPTIONS_GHC -W #-}
{-| This module contains checks to be run *after* type inference has completed
successfully. At that point we still need to do occurs checks and ensure that
`main` has an acceptable type.
-}
module Type.ExtraChecks (mainType, occurs, portTypes) where
-- This module contains checks to be run *after* type inference has
-- completed successfully. At that point we still need to do occurs
-- checks and ensure that `main` has an acceptable type.
import Control.Applicative ((<$>),(<*>))
import Control.Monad.State
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Traversable as Traverse
import qualified Data.UnionFind.IO as UF
import Type.Type ( Variable, structure, Term1(..), toSrcType )
import Text.PrettyPrint as P
import qualified SourceSyntax.Annotation as A
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.PrettyPrint as SPP
import qualified SourceSyntax.Type as ST
import qualified Transform.Expression as Expr
import qualified Type.Type as TT
import qualified Type.State as TS
import qualified Type.Alias as Alias
import Text.PrettyPrint as P
import SourceSyntax.PrettyPrint (pretty)
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.Type as T
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Location as L
import qualified Transform.Expression as Expr
import qualified Data.Traversable as Traverse
throw err = Left [ P.vcat err ]
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
where
mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)
mainCheck rules env =
case Map.lookup "main" env of
Nothing -> Right env
@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
acceptable = [ "Graphics.Element.Element"
, "Signal.Signal Graphics.Element.Element" ]
tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
, P.text "Instead 'main' has type:\n"
, P.nest 4 . pretty $ Alias.realias rules mainType
, P.nest 4 . SPP.pretty $ Alias.realias rules mainType
, P.text " " ]
data Direction = In | Out
portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
portTypes rules expr =
const () <$> Expr.checkPorts (check In) (check Out) expr
where
check = isValid True False False
isValid isTopLevel seenFunc seenSignal direction name tipe =
case tipe of
T.Data ctor ts
ST.Data ctor ts
| isJs ctor || isElm ctor -> mapM_ valid ts
| ctor == "Signal.Signal" -> handleSignal ts
| otherwise -> err' True "an unsupported type"
T.Var _ -> err "free type variables"
ST.Var _ -> err "free type variables"
T.Lambda _ _ ->
ST.Lambda _ _ ->
case direction of
In -> err "functions"
Out | seenFunc -> err "higher-order functions"
| seenSignal -> err "signals that contain functions"
| otherwise ->
forM_ (T.collectLambdas tipe)
forM_ (ST.collectLambdas tipe)
(isValid' True seenSignal direction name)
T.Record _ (Just _) -> err "extended records with free type variables"
ST.Record _ (Just _) -> err "extended records with free type variables"
T.Record fields Nothing ->
ST.Record fields Nothing ->
mapM_ (\(k,v) -> (,) k <$> valid v) fields
where
@ -100,7 +103,7 @@ portTypes rules expr =
[ txt [ "Type Error: the value ", dir "coming in" "sent out"
, " through port '", name, "' is invalid." ]
, txt [ "It contains ", kind, ":\n" ]
, (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
, (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
, txt [ "Acceptable values for ", dir "incoming" "outgoing"
, " ports include JavaScript values and" ]
, txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
@ -112,37 +115,37 @@ portTypes rules expr =
, txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
]
occurs :: (String, Variable) -> StateT TS.SolverState IO ()
occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
occurs (name, variable) =
do vars <- liftIO $ infiniteVars [] variable
case vars of
[] -> return ()
var:_ -> do
desc <- liftIO $ UF.descriptor var
case structure desc of
case TT.structure desc of
Nothing ->
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
Just _ ->
do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
var' <- liftIO $ UF.fresh desc
TS.addError (L.NoSpan name) (Just msg) var var'
TS.addError (A.None (P.text name)) (Just msg) var var'
where
msg = "Infinite types are not allowed"
fallback _ = return $ P.text msg
infiniteVars :: [Variable] -> Variable -> IO [Variable]
infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
infiniteVars seen var =
let go = infiniteVars (var:seen) in
if var `elem` seen
then return [var]
else do
desc <- UF.descriptor var
case structure desc of
case TT.structure desc of
Nothing -> return []
Just struct ->
case struct of
App1 a b -> (++) <$> go a <*> go b
Fun1 a b -> (++) <$> go a <*> go b
Var1 a -> go a
EmptyRecord1 -> return []
Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
TT.App1 a b -> (++) <$> go a <*> go b
TT.Fun1 a b -> (++) <$> go a <*> go b
TT.Var1 a -> go a
TT.EmptyRecord1 -> return []
TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

23
compiler/Type/Fragment.hs
View file

@ -5,24 +5,23 @@ import qualified Data.Map as Map
import Type.Type
import SourceSyntax.Pattern
import SourceSyntax.Location (noneNoDocs)
import SourceSyntax.Annotation (noneNoDocs)
data Fragment = Fragment {
typeEnv :: Map.Map String Type,
vars :: [Variable],
typeConstraint :: TypeConstraint
} deriving Show
data Fragment = Fragment
{ typeEnv :: Map.Map String Type
, vars :: [Variable]
, typeConstraint :: TypeConstraint
} deriving Show
emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
joinFragment f1 f2 = Fragment {
typeEnv = Map.union (typeEnv f1) (typeEnv f2),
vars = vars f1 ++ vars f2,
typeConstraint = typeConstraint f1 /\ typeConstraint f2
}
joinFragment f1 f2 = Fragment
{ typeEnv = Map.union (typeEnv f1) (typeEnv f2)
, vars = vars f1 ++ vars f2
, typeConstraint = typeConstraint f1 /\ typeConstraint f2
}
joinFragments = List.foldl' (flip joinFragment) emptyFragment
toScheme fragment =
Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

2
compiler/Type/Inference.hs
View file

@ -9,7 +9,7 @@ import qualified Type.Constrain.Expression as TcExpr
import qualified Type.Solve as Solve
import SourceSyntax.Module as Module
import SourceSyntax.Location (noneNoDocs)
import SourceSyntax.Annotation (noneNoDocs)
import SourceSyntax.Type (Type)
import Text.PrettyPrint
import qualified Type.State as TS

38
compiler/Type/Solve.hs
View file

@ -3,15 +3,15 @@ module Type.Solve (solve) where
import Control.Monad
import Control.Monad.State
import qualified Data.UnionFind.IO as UF
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Traversable as Traversable
import qualified Data.List as List
import qualified Data.UnionFind.IO as UF
import Type.Type
import Type.Unify
import qualified Type.ExtraChecks as Check
import qualified Type.State as TS
import SourceSyntax.Location (Located(L), SrcSpan)
import qualified SourceSyntax.Annotation as A
-- | Every variable has rank less than or equal to the maxRank of the pool.
@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
solve :: TypeConstraint -> StateT TS.SolverState IO ()
solve (L span constraint) =
solve (A.A region constraint) =
case constraint of
CTrue -> return ()
@ -105,11 +105,11 @@ solve (L span constraint) =
CEqual term1 term2 -> do
t1 <- TS.flatten term1
t2 <- TS.flatten term2
unify span t1 t2
unify region t1 t2
CAnd cs -> mapM_ solve cs
CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
oldEnv <- TS.getEnv
mapM TS.introduce fqs
solve constraint'
@ -117,7 +117,7 @@ solve (L span constraint) =
CLet schemes constraint' -> do
oldEnv <- TS.getEnv
headers <- Map.unions `fmap` mapM (solveScheme span) schemes
headers <- Map.unions `fmap` mapM (solveScheme region) schemes
TS.modifyEnv $ \env -> Map.union headers env
solve constraint'
mapM Check.occurs $ Map.toList headers
@ -134,10 +134,10 @@ solve (L span constraint) =
error ("Could not find '" ++ name ++ "' when solving type constraints.")
t <- TS.flatten term
unify span freshCopy t
unify region freshCopy t
solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
solveScheme span scheme =
solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
solveScheme region scheme =
case scheme of
Scheme [] [] constraint header -> do
solve constraint
@ -154,39 +154,39 @@ solveScheme span scheme =
header' <- Traversable.traverse TS.flatten header
solve constraint
allDistinct span rigidQuantifiers
allDistinct region rigidQuantifiers
youngPool <- TS.getPool
TS.switchToPool oldPool
generalize youngPool
mapM (isGeneric span) rigidQuantifiers
mapM (isGeneric region) rigidQuantifiers
return header'
-- Checks that all of the given variables belong to distinct equivalence classes.
-- Also checks that their structure is Nothing, so they represent a variable, not
-- a more complex term.
allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
allDistinct span vars = do
allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
allDistinct region vars = do
seen <- TS.uniqueMark
let check var = do
desc <- liftIO $ UF.descriptor var
case structure desc of
Just _ -> TS.addError span (Just msg) var var
Just _ -> TS.addError region (Just msg) var var
where msg = "Cannot generalize something that is not a type variable."
Nothing -> do
if mark desc == seen
then let msg = "Duplicate variable during generalization."
in TS.addError span (Just msg) var var
in TS.addError region (Just msg) var var
else return ()
liftIO $ UF.setDescriptor var (desc { mark = seen })
mapM_ check vars
-- Check that a variable has rank == noRank, meaning that it can be generalized.
isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
isGeneric span var = do
isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
isGeneric region var = do
desc <- liftIO $ UF.descriptor var
if rank desc == noRank
then return ()
else let msg = "Unable to generalize a type variable. It is not unranked."
in TS.addError span (Just msg) var var
in TS.addError region (Just msg) var var

32
compiler/Type/State.hs
View file

@ -1,16 +1,17 @@
{-# OPTIONS_GHC -W #-}
module Type.State where
import Type.Type
import qualified Data.Map as Map
import qualified Data.UnionFind.IO as UF
import Control.Monad.State
import Control.Applicative ((<$>),(<*>), Applicative)
import Control.Monad.State
import qualified Data.Map as Map
import qualified Data.Traversable as Traversable
import Text.PrettyPrint as P
import qualified Data.UnionFind.IO as UF
import qualified SourceSyntax.Annotation as A
import SourceSyntax.PrettyPrint
import SourceSyntax.Location
import Text.PrettyPrint as P
import qualified Type.Alias as Alias
import Type.Type
-- Pool
-- Holds a bunch of variables
@ -46,7 +47,7 @@ initialState = SS {
modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
addError span hint t1 t2 =
addError region hint t1 t2 =
modify $ \state -> state { sErrors = makeError : sErrors state }
where
makeError rules = do
@ -54,24 +55,15 @@ addError span hint t1 t2 =
t1' <- prettiest <$> toSrcType t1
t2' <- prettiest <$> toSrcType t2
return . P.vcat $
[ P.text $ "Type error" ++ location ++ ":"
[ P.text "Type error" <+> pretty region <> P.colon
, maybe P.empty P.text hint
, display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
, P.text ""
, P.nest 8 $ A.getRegionDocs region
, P.text ""
, P.text " Expected Type:" <+> t1'
, P.text " Actual Type:" <+> t2'
]
location = case span of
NoSpan _ -> ""
Span p1 p2 _ ->
if line p1 == line p2 then " on line " ++ show (line p1)
else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
display msg =
P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
, P.text " " ]
switchToPool pool = modifyPool (\_ -> pool)
getPool :: StateT SolverState IO Pool

31
compiler/Type/Type.hs
View file

@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))
import Control.Monad.State
import Control.Monad.Error
import Data.Traversable (traverse)
import SourceSyntax.Location
import SourceSyntax.Annotation
import SourceSyntax.Helpers (isTuple)
import qualified SourceSyntax.Type as Src
@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
infixl 8 /\
(/\) :: Constraint a b -> Constraint a b -> Constraint a b
a@(L _ c1) /\ b@(L _ c2) =
a@(A _ c1) /\ b@(A _ c2) =
case (c1, c2) of
(CTrue, _) -> b
(_, CTrue) -> a
@ -128,17 +128,24 @@ structuredVar structure = UF.fresh $ Descriptor {
-- ex qs constraint == exists qs. constraint
ex :: [Variable] -> TypeConstraint -> TypeConstraint
ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
ex fqs constraint@(A ann _) =
A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
-- fl qs constraint == forall qs. constraint
fl :: [Variable] -> TypeConstraint -> TypeConstraint
fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
fl rqs constraint@(A ann _) =
A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
exists f = do
v <- liftIO $ var Flexible
ex [v] <$> f (VarN v)
existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
existsNumber f = do
v <- liftIO $ var (Is Number)
ex [v] <$> f (VarN v)
instance Show a => Show (UF.Point a) where
show point = unsafePerformIO $ fmap show (UF.descriptor point)
@ -148,8 +155,8 @@ instance PrettyType a => PrettyType (UF.Point a) where
pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
instance PrettyType a => PrettyType (Located a) where
pretty when (L _ e) = pretty when e
instance PrettyType t => PrettyType (Annotated a t) where
pretty when (A _ e) = pretty when e
instance PrettyType a => PrettyType (Term1 a) where
@ -212,12 +219,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
CAnd cs ->
P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
P.sep [ binder, pretty Never c ]
where
mergeExists vs (L _ c) =
mergeExists vs (A _ c) =
case c of
CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'
CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
_ -> (vs, c)
(fqs', c) = mergeExists fqs constraint
@ -233,7 +240,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
P.text name <+> P.text "<" <+> prty tipe
instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
pretty _ (Scheme rqs fqs (L _ constraint) headers) =
pretty _ (Scheme rqs fqs (A _ constraint) headers) =
P.sep [ forall, cs, headers' ]
where
prty = pretty Never
@ -297,8 +304,8 @@ class Crawl t where
-> t
-> StateT CrawlState IO t
instance Crawl a => Crawl (Located a) where
crawl nextState (L s e) = L s <$> crawl nextState e
instance Crawl e => Crawl (Annotated a e) where
crawl nextState (A ann e) = A ann <$> crawl nextState e
instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
crawl nextState constraint =

30
compiler/Type/Unify.hs
View file

@ -1,27 +1,27 @@
{-# OPTIONS_GHC -W #-}
module Type.Unify (unify) where
import Type.Type
import qualified Data.UnionFind.IO as UF
import Control.Monad.State
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.UnionFind.IO as UF
import qualified SourceSyntax.Annotation as A
import qualified Type.State as TS
import Control.Monad.State
import SourceSyntax.Location
import Type.Type
import Type.PrettyPrint
import Text.PrettyPrint (render)
unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
unify span variable1 variable2 = do
unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
unify region variable1 variable2 = do
equivalent <- liftIO $ UF.equivalent variable1 variable2
if equivalent then return ()
else actuallyUnify span variable1 variable2
else actuallyUnify region variable1 variable2
actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
actuallyUnify span variable1 variable2 = do
actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
actuallyUnify region variable1 variable2 = do
desc1 <- liftIO $ UF.descriptor variable1
desc2 <- liftIO $ UF.descriptor variable2
let unify' = unify span
let unify' = unify region
name' :: Maybe String
name' = case (name desc1, name desc2) of
@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
unifyNumber svar name
| name `elem` ["Int","Float","number"] = flexAndUnify svar
| otherwise = TS.addError span (Just hint) variable1 variable2
| otherwise = TS.addError region (Just hint) variable1 variable2
where hint = "A number must be an Int or Float."
comparableError maybe =
TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
unifyComparable var name
@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
List _ -> flexAndUnify varSuper
_ -> comparableError Nothing
rigidError variable = TS.addError span (Just hint) variable1 variable2
rigidError variable = TS.addError region (Just hint) variable1 variable2
where
var = "'" ++ render (pretty Never variable) ++ "'"
hint = "Cannot unify rigid type variable " ++ var ++
@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
(Rigid, _, _, _) -> rigidError variable1
(_, Rigid, _, _) -> rigidError variable2
_ -> TS.addError span Nothing variable1 variable2
_ -> TS.addError region Nothing variable1 variable2
case (structure desc1, structure desc2) of
(Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do
eat (_:xs) (_:ys) = eat xs ys
eat xs _ = xs
_ -> TS.addError span Nothing variable1 variable2
_ -> TS.addError region Nothing variable1 variable2

123
libraries/Automaton.elm.hidden
View file

@ -1,123 +0,0 @@
module Automaton ( pure, state, hiddenState, run, step
, (<<<), (>>>), combine, count, average
) where
{-| This library is a way to package up dynamic behavior. It makes it easier to
dynamically create dynamic components. See the [original release
notes](http://elm-lang.org/blog/announce/0.5.0.elm) on this library to get a feel for how
it can be used.
# Create
@docs pure, state, hiddenState
# Evaluate
@docs run, step
# Combine
@docs (>>>), (<<<), combine
# Common Automatons
@docs count, average
-}
import open Basics
import Signal (lift,foldp,Signal)
import open List
import Maybe (Just, Nothing)
data Automaton a b = Step (a -> (Automaton a b, b))
{-| Run an automaton on a given signal. The automaton steps forward whenever the
input signal updates.
-}
run : Automaton a b -> b -> Signal a -> Signal b
run auto base inputs =
let step a (Step f, _) = f a
in lift (\(x,y) -> y) (foldp step (auto,base) inputs)
{-| Step an automaton forward once with a given input. -}
step : a -> Automaton a b -> (Automaton a b, b)
step a (Step f) = f a
{-| Compose two automatons, chaining them together. -}
(>>>) : Automaton a b -> Automaton b c -> Automaton a c
f >>> g =
Step (\a -> let (f', b) = step a f
(g', c) = step b g
in (f' >>> g', c))
{-| Compose two automatons, chaining them together. -}
(<<<) : Automaton b c -> Automaton a b -> Automaton a c
g <<< f = f >>> g
{-| Combine a list of automatons into a single automaton that produces a
list.
-}
combine : [Automaton a b] -> Automaton a [b]
combine autos =
Step (\a -> let (autos', bs) = unzip (map (step a) autos)
in (combine autos', bs))
{-| Create an automaton with no memory. It just applies the given function to
every input.
-}
pure : (a -> b) -> Automaton a b
pure f = Step (\x -> (pure f, f x))
{-| Create an automaton with state. Requires an initial state and a step
function to step the state forward. For example, an automaton that counted
how many steps it has taken would look like this:
count = Automaton a Int
count = state 0 (\\_ c -> c+1)
It is a stateful automaton. The initial state is zero, and the step function
increments the state on every step.
-}
state : b -> (a -> b -> b) -> Automaton a b
state s f = Step (\x -> let s' = f x s
in (state s' f, s'))
{-| Create an automaton with hidden state. Requires an initial state and a
step function to step the state forward and produce an output.
-}
hiddenState : s -> (a -> s -> (s,b)) -> Automaton a b
hiddenState s f = Step (\x -> let (s',out) = f x s
in (hiddenState s' f, out))
{-| Count the number of steps taken. -}
count : Automaton a Int
count = state 0 (\_ c -> c + 1)
type Queue t = ([t],[t])
empty = ([],[])
enqueue x (en,de) = (x::en, de)
dequeue q = case q of
([],[]) -> Nothing
(en,[]) -> dequeue ([], reverse en)
(en,hd::tl) -> Just (hd, (en,tl))
{-| Computes the running average of the last `n` inputs. -}
average : Int -> Automaton Float Float
average k =
let step n (ns,len,sum) =
if len == k then stepFull n (ns,len,sum)
else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))
stepFull n (ns,len,sum) =
case dequeue ns of
Nothing -> ((ns,len,sum), 0)
Just (m,ns') -> let sum' = sum + n - m
in ((enqueue n ns', len, sum'), sum' / toFloat len)
in hiddenState (empty,0,0) step
{-- TODO(evancz): See the following papers for ideas on how to make this
library faster and better:
- Functional Reactive Programming, Continued
- Causal commutative arrows and their optimization
Speeding things up is a really low priority. Language features and
libraries with nice APIs and are way more important!
--}

149
libraries/AutomatonV2.elm.hidden
View file

@ -1,149 +0,0 @@
module AutomatonV2 where
{-| This library is a way to package up dynamic behavior. It makes it easier to
dynamically create dynamic components. See the [original release
notes](/blog/announce/version-0.5.0.elm) on this library to get a feel for how
it can be used.
-}
import open Basics
import Signal (lift,foldp,Signal)
import open List
import Maybe (Just, Nothing)
data Automaton input output = Pure (input -> output)
| Stateful state (input -> state -> (output,state))
-- The basics
-- AFRP name: arr
pure: (i -> o) -> Automaton i o
pure = Pure
-- AFRP name: >>>
andThen: Automaton i inter -> Automaton inter o -> Automaton i o
andThen first second =
case first of
Pure f -> case second of -- f is the function from first
Pure s -> Pure (s . f) -- s is the function from second
Stateful b s -> Stateful b (\i -> s (f i)) -- b is the base state from second
Stateful fb f -> case second of -- fb is the base state from first
Pure s -> Stateful fb (\i st -> -- sb is the base state from second
let (inter, st') = f i st -- i is the input
in (s inter, st')) -- st is the input state
Stateful sb s -> Stateful (fb, sb) (\i (fst, sst) -> -- inter is the intermediate value
let (inter, fst') = f i fst -- st' is the new state
(o, sst') = s inter sst -- fst and sst are the state of first and second
in (o, (fst', sst'))) -- ect...
-- AFRP name: first
extendDown: Automaton i o -> Automaton (i,extra) (o,extra)
extendDown auto = case auto of
Pure fun -> Pure (\(i,extra) -> (fun i, extra))
Stateful base fun -> Stateful base (\(i,extra) s -> (fun i s, extra))
-- AFRP name: loop
loop: s -> Automaton (i,s) (o,s) -> Automaton i o
loop base auto = case auto of
Pure fun -> Stateful base (curry fun)
Stateful base2 fun -> -- fun: (i, s) -> s2 -> ((o, s), s2)
let newFun = (\i (s,s2) ->
let ((o, s'), s2') = fun (i, s) s2
in (o, (s', s2'))) -- newFun: i -> (s, s2) -> (o, (s, s2))
in Stateful (base, base2) newFun
-- Run an automaton on a given signal
run: Automaton i o -> o -> Signal i -> Signal o
run auto baseOut input = case auto of
Pure fun -> lift fun input
Stateful base fun -> lift fst
(foldp (\i (o, s) -> fun i s)
(baseOut, base) input)
-- Other frequently used functions/operators
-- Create an automaton with state. Requires an initial state and a step
-- function to step the state forward. For example, an automaton that counted
-- how many steps it has taken would look like this:
--
-- count = Automaton a Int
-- count = state 0 (\\_ c -> c+1)
--
-- It is a stateful automaton. The initial state is zero, and the step function
-- increments the state on every step.
state : s -> (i -> s -> s) -> Automaton i s
state base fun = loop base (pure (\(i,s) ->
let s' = fun i s
in (s',s')))
-- Create an automaton with hidden state. Requires an initial state and a
-- step function to step the state forward and produce an output.
hiddenState : s -> (i -> s -> (s,o)) -> Automaton i o
hiddenState base fun = loop base (pure (\(i,s) ->
let (o,s') = fun i s
in (s',o)))
-- AFRP name: second
extendUp: Automaton i o -> Automaton (extra,i) (extra,o)
extendUp auto =
let swap (a, b) = (b, a)
in pure swap `andThen` extendDown auto `andThen` pure swap
-- (parallel composition)
pair: Automaton i1 o1 -> Automaton i2 o2 -> Automaton (i1,i2) (o1,o2)
pair f g = extendDown f `andThen` extendUp g
branch : Automaton i o1 -> Automaton i o2 -> Automaton i (o1,o2)
branch f g =
let double = pure (\i -> (i,i))
in double `andThen` pair f g
combi: Automaton i o -> Automaton i [o] -> Automaton i [o]
combi a1 a2 = (a1 `branch` a2) `andThen` pure (uncurry (::))
-- Combine a list of automatons into a single automaton that produces a list.
combine : [Automaton i o] -> Automaton i [o]
combine autos =
let l = length autos
in if l == 0
then pure (\_ -> [])
else foldr combi (last autos `andThen` pure (\a -> [a])) (take (l-1) autos)
-- Examples of automata
-- Count the number of steps taken.
count : Automaton a Int
count = state 0 (\_ c -> c + 1)
type Queue t = ([t],[t])
empty = ([],[])
enqueue x (en,de) = (x::en, de)
dequeue q = case q of
([],[]) -> Nothing
(en,[]) -> dequeue ([], reverse en)
(en,hd::tl) -> Just (hd, (en,tl))
-- Computes the running average of the last `n` inputs.
average : Int -> Automaton Float Float
average k =
let step n (ns,len,sum) =
if len == k then stepFull n (ns,len,sum)
else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))
stepFull n (ns,len,sum) =
case dequeue ns of
Nothing -> ((ns,len,sum), 0)
Just (m,ns') -> let sum' = sum + n - m
in ((enqueue n ns', len, sum'), sum' / toFloat len)
in hiddenState (empty,0,0) step
{-- TODO(evancz): See the following papers for ideas on how to make this
library faster and better:
- Functional Reactive Programming, Continued -- took some inspirations from this paper (Apanatshka)
- Causal commutative arrows and their optimization
Speeding things up is a really low priority. Language features and
libraries with nice APIs and are way more important!
--}

27
libraries/Basics.elm
View file

@ -39,6 +39,9 @@ which happen to be radians.
# Polar Coordinates
@docs toPolar, fromPolar
# Floating Point Checks
@docs isNaN, isInfinite
# Tuples
@docs fst, snd
@ -271,6 +274,30 @@ ceiling = Native.Basics.ceiling
toFloat : Int -> Float
toFloat = Native.Basics.toFloat
{- | Determines whether a float is an undefined or unrepresentable number.
NaN stands for *not a number* and it is [a standardized part of floating point
numbers](http://en.wikipedia.org/wiki/NaN).
isNaN (0/0) == True
isNaN (sqrt -1) == True
isNaN (1/0) == False -- infinity is a number
isNaN 1 == False
-}
isNaN : Float -> Bool
isNaN = Native.Basics.isNaN
{- | Determines whether a float is positive or negative infinity.
isInfinite (0/0) == False
isInfinite (sqrt -1) == False
isInfinite (1/0) == True
isInfinite 1 == False
Notice that NaN is not infinite! For float `n` to be finite implies that
`not (isInfinite n || isNaN n)` evaluates to `True`.
-}
isInfinite : Float -> Bool
isInfinite = Native.Basics.isInfinite
-- Function Helpers

6
libraries/Date.elm
View file

@ -5,7 +5,7 @@ module Date where
issues with internationalization or locale formatting.
# Conversions
@docs read, toTime
@docs read, toTime, fromTime
# Extractions
@docs year, month, Month, day, dayOfWeek, Day, hour, minute, second
@ -36,6 +36,10 @@ read = Native.Date.read
toTime : Date -> Time
toTime = Native.Date.toTime
{-| Take a UNIX time and convert it to a `Date` -}
fromTime : Time -> Date
fromTime = Native.Date.fromTime
{-| Extract the year of a given date. Given the date 23 June 1990 at 11:45AM
this returns the integer `1990`. -}
year : Date -> Int

17
libraries/Debug.elm Normal file
View file

@ -0,0 +1,17 @@
module Debug where
{-| This library is for investigating bugs or performance problems. It should
*not* be used in production code.
-}
import Native.Debug
{-| Log a tagged value on the developer console, and then return the value.
1 + log "number" 1 -- equals 2, logs "number: 1"
length (log "start" []) -- equals 0, logs "start: []"
Notice that `log` is not a pure function! It should *only* be used for
investigating bugs or performance problems.
-}
log : String -> a -> a
log = Native.Debug.log

7
libraries/Dict.elm
View file

@ -31,11 +31,10 @@ Insert, remove, and query operations all take *O(log n)* time.
-}
import open Basics
import open Maybe
import Basics (..)
import Maybe (..)
import Native.Error
import List
import String
import Native.Utils
-- BBlack and NBlack should only be used during the deletion
@ -197,7 +196,7 @@ lessBlackTree t = case t of
reportRemBug : String -> NColor -> String -> String -> a
reportRemBug msg c lgot rgot =
Native.Error.raise . String.concat <| [
Native.Error.raise <| List.concat [
"Internal red-black tree invariant violated, expected ",
msg,
"and got",

30
libraries/Either.elm
View file

@ -26,28 +26,50 @@ data Either a b = Left a | Right b
{-| Apply the first function to a `Left` and the second function to a `Right`.
This allows the extraction of a value from an `Either`.
either (\n -> n + 1) sqrt (Left 4) == 5
either (\n -> n + 1) sqrt (Right 4) == 2
map : (a -> b) -> Either err a -> Either err b
map f e = either Left (\x -> Right (f x)) e
-}
either : (a -> c) -> (b -> c) -> Either a b -> c
either f g e = case e of { Left x -> f x ; Right y -> g y }
{-| True if the value is a `Left`. -}
{-| True if the value is a `Left`.
isLeft (Left "Cat") == True
isLeft (Right 1123) == False
-}
isLeft : Either a b -> Bool
isLeft e = case e of { Left _ -> True ; _ -> False }
{-| True if the value is a `Right`. -}
{-| True if the value is a `Right`.
isRight (Left "Cat") == False
isRight (Right 1123) == True
-}
isRight : Either a b -> Bool
isRight e = case e of { Right _ -> True ; _ -> False }
{-| Keep only the values held in `Left` values. -}
{-| Keep only the values held in `Left` values.
lefts [Left 3, Right 'a', Left 5, Right "eight"] == [3,5]
-}
lefts : [Either a b] -> [a]
lefts es = List.foldr consLeft [] es
{-| Keep only the values held in `Right` values. -}
{-| Keep only the values held in `Right` values.
rights [Left 3, Right 'a', Left 5, Right 'b'] == ['a','b']
-}
rights : [Either a b] -> [b]
rights es = List.foldr consRight [] es
{-| Split into two lists, lefts on the left and rights on the right. So we
have the equivalence: `(partition es == (lefts es, rights es))`
partition [Left 3, Right 'a', Left 5, Right 'b'] == ([3,5],['a','b'])
-}
partition : [Either a b] -> ([a],[b])
partition es = List.foldr consEither ([],[]) es

2
libraries/Graphics/Collage.elm
View file

@ -30,7 +30,7 @@ it as a single unit.
-}
import open Basics
import Basics (..)
import List
import Either (Either, Left, Right)
import Transform2D (Transform2D, identity)

11
libraries/Graphics/Element.elm
View file

@ -37,12 +37,12 @@ If you need more precision, you can create custom positions.
midRightAt, topLeftAt, topRightAt, bottomLeftAt, bottomRightAt
-}
import open Basics
import Basics (..)
import Native.Utils
import JavaScript as JS
import JavaScript (JSString)
import List as List
import open Color
import Color (..)
import Maybe (Maybe, Just, Nothing)
type Properties = {
@ -53,7 +53,8 @@ type Properties = {
color : Maybe Color,
href : JSString,
tag : JSString,
hover : ()
hover : (),
click : ()
}
type Element = { props : Properties, element : ElementPrim }
@ -128,7 +129,9 @@ link href e = let p = e.props in
emptyStr = JS.fromString ""
newElement w h e =
{ props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr (), element = e }
{ props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr () ()
, element = e
}
data ElementPrim
= Image ImageStyle Int Int JSString

317
libraries/Graphics/Input.elm
View file

@ -1,199 +1,178 @@
module Graphics.Input where
{-| This module is for creating standard input widgets such as buttons and
text boxes. In general, functions in this library return a signal representing
events from the user.
text fields. All functions in this library follow a general pattern in which
you create an `Input` that many elements can report to:
The simplest inputs are *one-way inputs*, meaning the user can update
them, but the programmer cannot. If you need to update an input from
within the program you want the slightly more complex *two-way inputs*.
This document will always show the one-way inputs first, *then* the
two-way inputs.
```haskell
clicks : Input ()
clicks = input ()
# Buttons
@docs button, customButton, buttons, customButtons
clickableYogi : Element
clickableYogi = clickable clicks.handle () (image 40 40 "/yogi.jpg")
```
# Fields
@docs field, password, email, fields, FieldState, emptyFieldState
Whenever the user clicks on the resulting `clickableYogi` element, it sends an
update to the `clicks` input. You will see this pattern again and again in
examples in this library, so just read on to get a better idea of how it works!
# Checkboxes
@docs checkbox, checkboxes
# Creating Inputs
@docs Input, input
# Drop Downs
@docs stringDropDown, dropDown
# Basic Input Elements
To learn about text fields, see the
[`Graphics.Input.Field`](Graphics-Input-Field) library.
@docs button, customButton, checkbox, dropDown
# Clicks and Hovers
@docs clickable, hoverable
# Mouse Hover
@docs hoverable, hoverables
-}
import Basics (String)
import Signal (Signal,lift,dropRepeats)
import Native.Graphics.Input
import List
import Signal (Signal)
import Graphics.Element (Element)
import Maybe (Maybe)
import JavaScript (JSString)
import Native.Graphics.Input
id x = x
{-| This is the key abstraction of this library. An `Input` is a record
of two fields:
{-| Create a group of buttons.
1. `signal` &mdash; all values coming to this input from &ldquo;the world&rdquo;
2. `handle` &mdash; a way to refer to this particular input and send it values
* The first argument is the default value of the `events` signal.
* The `events` signal represents all of the activity in this group
of buttons.
* The `button` function creates a button
with the given name, like &ldquo;Submit&rdquo; or &ldquo;Cancel&rdquo;.
The `a` value is sent to `events` whenever the button is pressed.
This will make more sense as you see more examples.
-}
buttons : a -> { events : Signal a,
button : a -> String -> Element }
buttons = Native.Graphics.Input.buttons
type Input a = { signal : Signal a, handle : Handle a }
{-| Create a button with a given label. The result is an `Element` and
a signal of units. This signal triggers whenever the button is pressed.
data Handle a = Handle
{-| This creates a new `Input`. You provide a single argument that will serve
as the initial value of the input&rsquo;s `signal`. For example:
numbers : Input Int
numbers = input 42
The initial value of `numbers.signal` is 42, and you will be able
to pipe updates to the input using `numbers.handle`.
Note: This is an inherently impure function. Specifically, `(input ())` and
`(input ())` are actually two different inputs with different signals and handles.
-}
button : String -> (Element, Signal ())
button txt =
let pool = buttons ()
in (pool.button () txt, pool.events)
input : a -> Input a
input = Native.Graphics.Input.input
{-| Create a group of custom buttons.
{-| Create a standard button. The following example begins making a basic
calculator:
* The first argument is the default value of the `events` signal.
* The `events` signal represents all of the activity in this group
of custom buttons.
* The `customButton` function creates a button with three different visual
states, one for up, hovering, and down. The resulting button has dimensions
large enough to fit all three possible `Elements`.
The `a` value is sent to `events` whenever the button is pressed.
data Keys = Number Int | Plus | Minus | Clear
keys : Input Keys
keys = input Clear
calculator : Element
calculator =
flow right [ button keys.handle (Number 1) "1"
, button keys.handle (Number 2) "2"
, button keys.handle Plus "+"
]
If the user presses the "+" button, `keys.signal` will update to `Plus`. If the
users presses "2", `keys.signal` will update to `(Number 2)`.
-}
customButtons : a -> { events : Signal a,
customButton : a -> Element -> Element -> Element -> Element }
customButtons = Native.Graphics.Input.customButtons
button : Handle a -> a -> String -> Element
button = Native.Graphics.Input.button
{-| Create a button with custom states for up, hovering, and down
(given in that order). The result is an `Element` and a signal of
units. This signal triggers whenever the button is pressed.
{-| Same as `button` but lets you customize buttons to look however you want.
click : Input ()
click = input ()
prettyButton : Element
prettyButton =
customButton click.handle
(image 100 40 "/button_up.jpg")
(image 100 40 "/button_hover.jpg")
(image 100 40 "/button_down.jpg")
-}
customButton : Element -> Element -> Element -> (Element, Signal ())
customButton up hover down =
let pool = customButtons ()
in (pool.customButton () up hover down, pool.events)
customButton : Handle a -> a -> Element -> Element -> Element -> Element
customButton = Native.Graphics.Input.customButton
{-| Create a group of checkboxes.
{-| Create a checkbox. The following example creates three synced checkboxes:
* The first argument is the default value of the `events` signal.
* The `events` signal represents all of the activity in this group
of checkboxes.
* The `checkbox` function creates a
checkbox with a given state. The `(Bool -> a)` function is used
when the checkbox is modified. It takes the new state and turns
it into a value that can be sent to `events`. For example, this
lets you add an ID to distinguish between checkboxes.
check : Input Bool
check = input False
boxes : Bool -> Element
boxes checked =
let box = container 40 40 middle (checkbox check.handle id checked)
in flow right [ box, box, box ]
main : Signal Element
main = boxes <~ check.signal
-}
checkboxes : a -> { events : Signal a,
checkbox : (Bool -> a) -> Bool -> Element }
checkboxes = Native.Graphics.Input.checkboxes
checkbox : Handle a -> (Bool -> a) -> Bool -> Element
checkbox = Native.Graphics.Input.checkbox
{-| Create a checkbox with a given start state. Unlike `button`, this
result is a *signal* of elements. That is because a checkbox has state
that updates based on user input. The boolean signal represents the
current state of the checkbox.
{-| Create a drop-down menu. The following drop-down lets you choose your
favorite British sport:
data Sport = Football | Cricket | Snooker
sport : Input (Maybe Sport)
sport = input Nothing
sportDropDown : Element
sportDropDown =
dropDown sport.handle
[ ("" , Nothing)
, ("Football", Just Football)
, ("Cricket" , Just Cricket)
, ("Snooker" , Just Snooker)
]
If the user selects "Football" from the drop down menue, `sport.signal`
will update to `Just Football`.
-}
checkbox : Bool -> (Signal Element, Signal Bool)
checkbox b =
let cbs = checkboxes b
in (lift (cbs.checkbox id) cbs.events, cbs.events)
{-| Detect when the mouse is hovering over some elements. This
allows you to create and destroy elements dynamically and still
detect hover information.
-}
hoverables : a -> { events : Signal a,
hoverable : (Bool -> a) -> Element -> Element }
hoverables = Native.Graphics.Input.hoverables
{-| Detect when the mouse is hovering over a specific `Element`. -}
hoverable : Element -> (Element, Signal Bool)
hoverable elem =
let pool = hoverables False
in (pool.hoverable id elem, pool.events)
{-| Represents the current state of a text field. The `string` represents the
characters filling the text field. The `selectionStart` and `selectionEnd`
values represent what the user has selected with their mouse or keyboard.
For example:
{ string="She sells sea shells", selectionStart=3, selectionEnd=0 }
This means the user highlighted the substring `"She"` backwards.
-}
type FieldState = { string:String, selectionStart:Int, selectionEnd:Int }
{-| Create a group of text input fields.
* The first argument is the default value of the `events` signal.
* The `events` signal represents all of the activity in this group
of text fields.
* The `field` function creates a
field with the given ghost text and initial field state.
When the field is modified, the `(FieldState -> a)` function
takes the new state and turns
it into a value that can be sent to `events`. For example, this
lets you add an ID to distinguish between input fields.
-}
fields : a -> { events : Signal a,
field : (FieldState -> a) -> String -> FieldState -> Element }
fields = Native.Graphics.Input.fields
{-| The empty field state:
{ string="", selectionStart=0, selectionEnd=0 }
-}
emptyFieldState : FieldState
emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }
{-| Create a field with the given default text. The output is an element
that updates to match the user input and a signal of strings representing
the content of the field.
-}
field : String -> (Signal Element, Signal String)
field placeHolder =
let tfs = fields emptyFieldState
changes = dropRepeats tfs.events
in (lift (tfs.field id placeHolder) changes,
dropRepeats (lift .string changes))
{-| Same as `field` but the UI element blocks out each characters. -}
password : String -> (Signal Element, Signal String)
password placeHolder =
let tfs = Native.Graphics.Input.passwords emptyFieldState
changes = dropRepeats tfs.events
in (lift (tfs.field id placeHolder) changes,
dropRepeats (lift .string changes))
{-| Same as `field` but it adds an annotation that this field is for email
addresses. This is helpful for auto-complete and for mobile users who may
get a custom keyboard with an `@` and `.com` button.
-}
email : String -> (Signal Element, Signal String)
email placeHolder =
let tfs = Native.Graphics.Input.emails emptyFieldState
changes = dropRepeats tfs.events
in (lift (tfs.field id placeHolder) changes,
dropRepeats (lift .string changes))
{-| Create a drop-down menu. When the user selects a string,
the current state of the drop-down is set to the associated
value. This lets you avoid manually mapping the string onto
functions and values.
-}
dropDown : [(String,a)] -> (Signal Element, Signal a)
dropDown : Handle a -> [(String,a)] -> Element
dropDown = Native.Graphics.Input.dropDown
{-| Create a drop-down menu for selecting strings. The resulting
signal of strings represents the string that is currently selected.
{-| Detect mouse hovers over a specific `Element`. In the following example,
we will create a hoverable picture called `cat`.
hover : Input Bool
hover = input False
cat : Element
cat = image 30 30 "/cat.jpg"
|> hoverable hover.handle id
When the mouse hovers above the `cat` element, `hover.signal` will become
`True`. When the mouse leaves it, `hover.signal` will become `False`.
-}
stringDropDown : [String] -> (Signal Element, Signal String)
stringDropDown strs =
dropDown (List.map (\s -> (s,s)) strs)
hoverable : Handle a -> (Bool -> a) -> Element -> Element
hoverable = Native.Graphics.Input.hoverable
{-| Detect mouse clicks on a specific `Element`. In the following example,
we will create a clickable picture called `cat`.
data Picture = Cat | Hat
picture : Input Picture
picture = input Cat
cat : Element
cat = image 30 30 "/cat.jpg"
|> clickable picture.handle Cat
hat : Element
hat = image 30 30 "/hat.jpg"
|> clickable picture.handle Hat
When the user clicks on the `cat` element, `picture.signal` receives
an update containing the value `Cat`. When the user clicks on the `hat` element,
`picture.signal` receives an update containing the value `Hat`. This lets you
distinguish which element was clicked. In a more complex example, they could be
distinguished with IDs or more complex data structures.
-}
clickable : Handle a -> a -> Element -> Element
clickable = Native.Graphics.Input.clickable

170
libraries/Graphics/Input/Field.elm Normal file
View file

@ -0,0 +1,170 @@
module Graphics.Input.Field where
{-| This library provides an API for creating and updating text fields.
Text fields use exactly the same approach as [`Graphics.Input`](Graphics-Input)
for modelling user input, allowing you to keep track of new events and update
text fields programmatically.
# Create Fields
@docs field, password, email
# Field Content
@docs Content, Selection, Direction, noContent
# Field Style
@docs Style, Outline, noOutline, Highlight, noHighlight, Dimensions, uniformly
-}
import Color (Color)
import Color
import Graphics.Element (Element)
import Graphics.Input (Input, Handle)
import Native.Graphics.Input
import Text
{-| Create uniform dimensions:
uniformly 4 == { left=4, right=4, top=4, bottom=4 }
The following example creates an outline where the left, right, top, and bottom
edges all have width 1:
Outline grey (uniformly 1) 4
-}
uniformly : Int -> Dimensions
uniformly n = Dimensions n n n n
{-| For setting dimensions of a fields padding or border. The left, right, top,
and bottom may all have different sizes. The following example creates
dimensions such that the left and right are twice as wide as the top and bottom:
myDimensions : Int -> Dimensions
myDimensions n = { left = 2 * n, right = 2 * n, top = n, bottom = n }
-}
type Dimensions = { left:Int, right:Int, top:Int, bottom:Int }
{-| A field can have a outline around it. This lets you set its color, width,
and radius. The radius allows you to round the corners of your field. Set the
width to zero to make it invisible. Here is an example outline that is grey
and thin with slightly rounded corners:
{ color = grey, width = uniformly 1, radius = 4 }
-}
type Outline = { color:Color, width:Dimensions, radius:Int }
{-| An outline with zero width, so you cannot see it. -}
noOutline : Outline
noOutline = Outline Color.grey (uniformly 0) 0
{-| When a field has focus, it has a blue highlight around it by default. The
`Highlight` lets you set the `color` and `width` of this highlight. Set the
`width` to zero to turn the highlight off. Here is an example highlight that
is blue and thin:
{ color = blue, width = 1 }
-}
type Highlight = { color:Color, width:Int }
{-| An highlight with zero width, so you cannot see it. -}
noHighlight : Highlight
noHighlight = Highlight Color.blue 0
{-| Describe the style of a text box. `style` describes the style of the text
itself using [`Text.Style`](/Text#Style). `outline` describes the glowing blue
outline that shows up when the field has focus. `outline` describes the line
surrounding the text field, and `padding` adds whitespace between the `outline`
and the text.
The width and height of the text box *includes* the `padding` and `outline`.
Say we have a text box that is 40 pixels tall. It has a uniform outline of
1 pixel and a uniform padding of 5 pixels. Both of these must be subtracted
from the total height to determine how much room there is for text. The
`padding` and `outline` appear on the top and bottom, so there will be 28
vertical pixels remaining for the text (40 - 1 - 5 - 5 - 1).
-}
type Style =
{ padding : Dimensions
, outline : Outline
, highlight : Highlight
, style : Text.Style
}
{-| The default style for a text field. The outline is `Color.grey` with width
1 and radius 2. The highlight is `Color.blue` with width 1, and the default
text color is black.
-}
defaultStyle : Style
defaultStyle =
{ padding = uniformly 4
, outline = Outline Color.grey (uniformly 1) 2
, highlight = Highlight Color.blue 1
, style = Text.defaultStyle
}
{-| Represents the current content of a text field. For example:
content = Content "She sells sea shells" (Selection 0 3 Backward)
This means the user highlighted the substring `"She"` backwards. The value of
`content.string` is `"She sells sea shells"`.
-}
type Content = { string:String, selection:Selection }
{-| The selection within a text field. `start` is never greater than `end`:
Selection 0 0 Forward -- cursor precedes all characters
Selection 5 9 Backward -- highlighting characters starting after
-- the 5th and ending after the 9th
-}
type Selection = { start:Int, end:Int, direction:Direction }
{-| The direction of selection. When the user highlights a selection in a text
field, they must do it in a particular direction. This determines which end of
the selection moves when they change the selection by pressing Shift-Left or
Shift-Right.
-}
data Direction = Forward | Backward
{-| A field with no content:
Content "" (Selection 0 0 Forward)
-}
noContent : Content
noContent = Content "" (Selection 0 0 Forward)
{-| Create a text field. The following example creates a time-varying element
called `nameField`. As the user types their name, the field will be updated
to match what they have entered.
name : Input Content
name = input noContent
nameField : Signal Element
nameField = field defaultStyle name.handle id "Name" <~ name.signal
When we use the `field` function, we first give it a visual style. This is
the first argument so that it is easier to define your own custom field
(`myField = field myStyle`). The next two arguments are a `Handle` and a
handler function that processes or augments events before sending them along
to the associated `Input`. In the example above we use the `id` function to
pass events along unchanged to the `name` `Input`. We then provide the
place-holder message to use when no input has been provided yet. Finally,
we give the current `Content` of the field. This argument is last because
it is most likely to change frequently, making function composition easier.
-}
field : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
field = Native.Graphics.Input.field
{-| Same as `field` but the UI element blocks out each characters. -}
password : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
password = Native.Graphics.Input.password
{-| Same as `field` but it adds an annotation that this field is for email
addresses. This is helpful for auto-complete and for mobile users who may
get a custom keyboard with an `@` and `.com` button.
-}
email : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
email = Native.Graphics.Input.email
-- area : Handle a -> (Content -> a) -> Handle b -> ((Int,Int) -> b) -> (Int,Int) -> String -> Content -> Element
-- area = Native.Graphics.Input.area

2
libraries/Http.elm
View file

@ -14,7 +14,7 @@ you have very strict latency requirements.
@docs Response
-}
import open Signal
import Signal (..)
import Native.Http
{-| The datatype for responses. Success contains only the returned message.

2
libraries/Json.elm
View file

@ -17,7 +17,7 @@ module Json where
-}
import open Basics
import Basics (..)
import Dict
import Maybe (Maybe)
import JavaScript as JS

2
libraries/List.elm
View file

@ -25,7 +25,7 @@ list must have the same type.
@docs sort, sortBy, sortWith
-}
import open Basics
import Basics (..)
import Native.List
{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}

24
libraries/Maybe.elm
View file

@ -21,27 +21,45 @@ numbers).
-}
data Maybe a = Just a | Nothing
{-| Apply a function to the contents of a `Maybe`.
Return default when given `Nothing`.
{-| Provide a default value and a function to extract the contents of a `Maybe`.
When given `Nothing` you get the default, when given a `Just` you apply the
function to the associated value.
isPositive : Maybe Int -> Bool
isPositive maybeInt = maybe False (\n -> n > 0) maybeInt
map : (a -> b) -> Maybe a -> Maybe b
map f m = maybe Nothing (\x -> Just (f x)) m
-}
maybe : b -> (a -> b) -> Maybe a -> b
maybe b f m = case m of
Just v -> f v
Nothing -> b
{-| Check if constructed with `Just`.
{-| Check if a maybe happens to be a `Just`.
isJust (Just 42) == True
isJust (Just []) == True
isJust Nothing == False
-}
isJust : Maybe a -> Bool
isJust = maybe False (\_ -> True)
{-| Check if constructed with `Nothing`.
isNothing (Just 42) == False
isNothing (Just []) == False
isNothing Nothing == True
-}
isNothing : Maybe a -> Bool
isNothing = not . isJust
cons : Maybe a -> [a] -> [a]
cons mx xs = maybe xs (\x -> x :: xs) mx
{-| Filters out Nothings and extracts the remaining values.
justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]
-}
justs : [Maybe a] -> [a]
justs = foldr cons []

7
libraries/Mouse.elm
View file

@ -7,7 +7,7 @@ module Mouse where
@docs position, x, y
# Button Status
@docs isDown, clicks, isClicked
@docs isDown, clicks
-}
@ -31,11 +31,6 @@ True when the button is down, and false otherwise. -}
isDown : Signal Bool
isDown = Native.Mouse.isDown
{-| True immediately after the left mouse-button has been clicked,
and false otherwise. -}
isClicked : Signal Bool
isClicked = Native.Mouse.isClicked
{-| Always equal to unit. Event triggers on every mouse click. -}
clicks : Signal ()
clicks = Native.Mouse.clicks

3
libraries/Native/Basics.js
View file

@ -19,6 +19,7 @@ Elm.Native.Basics.make = function(elm) {
return Utils.cmp(n,lo) < 0 ? lo : Utils.cmp(n,hi) > 0 ? hi : n; }
function xor(a,b) { return a !== b; }
function not(b) { return !b; }
function isInfinite(n) { return n === Infinity || n === -Infinity }
function truncate(n) { return n|0; }
@ -53,6 +54,8 @@ Elm.Native.Basics.make = function(elm) {
floor:Math.floor,
round:Math.round,
toFloat:function(x) { return x; },
isNaN:isNaN,
isInfinite:isInfinite
};
return elm.Native.Basics.values = basics;

12
libraries/Native/Bitwise.js
View file

@ -13,13 +13,13 @@ Elm.Native.Bitwise.make = function(elm) {
function srl(a,offset) { return a >>> offset; }
return elm.Native.Bitwise.values = {
and: A2(and),
or : A2(or ),
xor: A2(xor),
and: F2(and),
or : F2(or ),
xor: F2(xor),
complement: not,
shiftLeft : A2(sll),
shiftRightArithmatic: A2(sra),
shiftRightLogical : A2(srl),
shiftLeft : F2(sll),
shiftRightArithmatic: F2(sra),
shiftRightLogical : F2(srl),
};
};

9
libraries/Native/Color.js
View file

@ -6,6 +6,12 @@ Elm.Native.Color.make = function(elm) {
var Utils = Elm.Native.Utils.make(elm);
function toCss(c) {
return (c._3 === 1)
? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
: ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
}
function complement(rgb) {
var hsv = toHSV(rgb);
hsv.hue = (hsv.hue + 180) % 360;
@ -63,7 +69,8 @@ Elm.Native.Color.make = function(elm) {
return elm.Native.Color.values = {
hsva:F4(hsva),
hsv:F3(hsv),
complement:complement
complement:complement,
toCss:toCss
};
};

1
libraries/Native/Date.js
View file

@ -27,6 +27,7 @@ Elm.Native.Date.make = function(elm) {
minute : function(d) { return d.getMinutes(); },
second : function(d) { return d.getSeconds(); },
toTime : function(d) { return d.getTime(); },
fromTime: function(t) { return new window.Date(t); },
dayOfWeek : function(d) { return { ctor:dayTable[d.getDay()] }; }
};

24
libraries/Native/Debug.js Normal file
View file

@ -0,0 +1,24 @@
Elm.Native.Debug = {};
Elm.Native.Debug.make = function(elm) {
elm.Native = elm.Native || {};
elm.Native.Debug = elm.Native.Debug || {};
if (elm.Native.Debug.values) return elm.Native.Debug.values;
var show = Elm.Native.Show.make(elm).show;
function log(tag,value) {
var msg = tag + ': ' + show(value);
var process = process || {};
if (process.stdout) {
process.stdout.write(msg);
} else {
console.log(msg);
}
return value;
}
return elm.Native.Debug.values = {
log: F2(log)
};
};

612
libraries/Native/Graphics/Input.js
View file

@ -1,303 +1,407 @@
Elm.Native.Graphics.Input = {};
Elm.Native.Graphics.Input.make = function(elm) {
elm.Native = elm.Native || {};
elm.Native.Graphics = elm.Native.Graphics || {};
elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
elm.Native = elm.Native || {};
elm.Native.Graphics = elm.Native.Graphics || {};
elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
var Render = ElmRuntime.use(ElmRuntime.Render.Element);
var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
var Render = ElmRuntime.use(ElmRuntime.Render.Element);
var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
var toCss = Elm.Native.Color.make(elm).toCss;
var Text = Elm.Native.Text.make(elm);
var Signal = Elm.Signal.make(elm);
var newElement = Elm.Graphics.Element.make(elm).newElement;
var JS = Elm.Native.JavaScript.make(elm);
var Utils = Elm.Native.Utils.make(elm);
var Tuple2 = Utils.Tuple2;
var Signal = Elm.Signal.make(elm);
var newElement = Elm.Graphics.Element.make(elm).newElement;
var JS = Elm.Native.JavaScript.make(elm);
var Utils = Elm.Native.Utils.make(elm);
var Tuple2 = Utils.Tuple2;
function input(initialValue) {
var signal = Signal.constant(initialValue);
return { _:{}, signal:signal, handle:signal };
}
function dropDown(values) {
var entries = JS.fromList(values);
var events = Signal.constant(entries[0]._1);
function renderDropDown(signal, values) {
return function(_) {
var entries = JS.fromList(values);
var drop = newNode('select');
drop.style.border = '0 solid';
for (var i = 0; i < entries.length; ++i) {
var option = newNode('option');
var name = JS.fromString(entries[i]._0);
option.value = name;
option.innerHTML = name;
drop.appendChild(option);
}
drop.addEventListener('change', function() {
elm.notify(events.id, entries[drop.selectedIndex]._1);
});
var drop = newNode('select');
drop.style.border = '0 solid';
drop.style.pointerEvents = 'auto';
for (var i = 0; i < entries.length; ++i) {
var option = newNode('option');
var name = JS.fromString(entries[i]._0);
option.value = name;
option.innerHTML = name;
drop.appendChild(option);
}
drop.addEventListener('change', function() {
elm.notify(signal.id, entries[drop.selectedIndex]._1);
});
var t = drop.cloneNode(true);
t.style.visibility = "hidden";
var t = drop.cloneNode(true);
t.style.visibility = "hidden";
elm.node.appendChild(t);
var style = window.getComputedStyle(t, null);
var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
elm.node.removeChild(t);
elm.node.appendChild(t);
var style = window.getComputedStyle(t, null);
var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
elm.node.removeChild(t);
return drop;
};
}
var element = A3(newElement, w, h, {
ctor: 'Custom',
type: 'DropDown',
render: function render(model) { return drop; },
update: function update(node, oldModel, newModel) {},
model: {}
});
function updateDropDown(node, oldModel, newModel) {
}
return Tuple2(Signal.constant(element), events);
}
function dropDown(signal, values) {
return A3(newElement, 100, 24, {
ctor: 'Custom',
type: 'DropDown',
render: renderDropDown(signal,values),
update: updateDropDown,
model: {}
});
}
function buttons(defaultValue) {
var events = Signal.constant(defaultValue);
function renderButton(model) {
var node = newNode('button');
node.style.display = 'block';
node.style.pointerEvents = 'auto';
node.elm_signal = model.signal;
node.elm_value = model.value;
function click() {
elm.notify(node.elm_signal.id, node.elm_value);
}
node.addEventListener('click', click);
node.innerHTML = model.text;
return node;
}
function render(model) {
var b = newNode('button');
b.style.display = 'block';
b.elmEvent = model.event;
function click() { elm.notify(events.id, b.elmEvent); }
b.addEventListener('click', click);
b.innerHTML = model.text;
return b;
}
function updateButton(node, oldModel, newModel) {
node.elm_signal = newModel.signal;
node.elm_value = newModel.value;
var txt = newModel.text;
if (oldModel.text !== txt) node.innerHTML = txt;
}
function update(node, oldModel, newModel) {
node.elmEvent = newModel.event;
var txt = newModel.text;
if (oldModel.text !== txt) node.innerHTML = txt;
}
function button(signal, value, text) {
return A3(newElement, 100, 40, {
ctor: 'Custom',
type: 'Button',
render: renderButton,
update: updateButton,
model: { signal:signal, value:value, text:JS.fromString(text) }
});
}
function button(evnt, txt) {
return A3(newElement, 100, 40, {
ctor: 'Custom',
type: 'Button',
render: render,
update: update,
model: { event:evnt, text:JS.fromString(txt) }
});
}
function renderCustomButton(model) {
var btn = newNode('div');
btn.style.pointerEvents = 'auto';
btn.elm_signal = model.signal;
btn.elm_value = model.value;
return { _:{}, button:F2(button), events:events };
}
btn.elm_up = Render.render(model.up);
btn.elm_hover = Render.render(model.hover);
btn.elm_down = Render.render(model.down);
function customButtons(defaultValue) {
var events = Signal.constant(defaultValue);
function replace(node) {
if (node !== btn.firstChild) {
btn.replaceChild(node, btn.firstChild);
}
}
var overCount = 0;
function over(e) {
if (overCount++ > 0) return;
replace(btn.elm_hover);
}
function out(e) {
if (btn.contains(e.toElement || e.relatedTarget)) return;
overCount = 0;
replace(btn.elm_up);
}
function up() {
replace(btn.elm_hover);
elm.notify(btn.elm_signal.id, btn.elm_value);
}
function down() {
replace(btn.elm_down);
}
btn.addEventListener('mouseover', over);
btn.addEventListener('mouseout' , out);
btn.addEventListener('mousedown', down);
btn.addEventListener('mouseup' , up);
function render(model) {
var btn = newNode('div');
btn.elmEvent = model.event;
btn.appendChild(btn.elm_up);
btn.elmUp = Render.render(model.up);
btn.elmHover = Render.render(model.hover);
btn.elmDown = Render.render(model.down);
var clicker = newNode('div');
clicker.style.width = btn.elm_up.style.width;
clicker.style.height = btn.elm_up.style.height;
clicker.style.position = 'absolute';
clicker.style.top = 0;
btn.appendChild(clicker);
function replace(node) {
if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
}
var overCount = 0;
function over(e) {
if (overCount++ > 0) return;
replace(btn.elmHover);
}
function out(e) {
if (btn.contains(e.toElement || e.relatedTarget)) return;
overCount = 0;
replace(btn.elmUp);
}
function up() {
replace(btn.elmHover);
elm.notify(events.id, btn.elmEvent);
}
function down() { replace(btn.elmDown); }
btn.addEventListener('mouseover', over);
btn.addEventListener('mouseout' , out);
btn.addEventListener('mousedown', down);
btn.addEventListener('mouseup' , up);
return btn;
}
btn.appendChild(btn.elmUp);
function updateCustomButton(node, oldModel, newModel) {
var signal = newModel.signal;
node.elm_up.elm_signal = signal;
node.elm_hover.elm_signal = signal;
node.elm_down.elm_signal = signal;
var clicker = newNode('div');
clicker.style.width = btn.elmUp.style.width;
clicker.style.height = btn.elmUp.style.height;
clicker.style.position = 'absolute';
clicker.style.top = 0;
btn.appendChild(clicker);
var value = newModel.value;
node.elm_up.elm_value = value;
node.elm_hover.elm_value = value;
node.elm_down.elm_value = value;
return btn;
}
Render.update(node.elm_up, oldModel.up, newModel.up)
Render.update(node.elm_hover, oldModel.hover, newModel.hover)
Render.update(node.elm_down, oldModel.down, newModel.down)
}
function update(node, oldModel, newModel) {
node.elmEvent = newModel.event;
Render.update(node.elmUp, oldModel.up, newModel.up)
Render.update(node.elmHover, oldModel.hover, newModel.hover)
Render.update(node.elmDown, oldModel.down, newModel.down)
}
function max3(a,b,c) {
var ab = a > b ? a : b;
return ab > c ? ab : c;
}
function button(evnt, up, hover, down) {
return A3(newElement,
Math.max(up.props.width, hover.props.width, down.props.width),
Math.max(up.props.height, hover.props.height, down.props.height),
{ ctor: 'Custom',
type: 'CustomButton',
render: render,
update: update,
model: { event:evnt, up:up, hover:hover, down:down }
});
}
function customButton(signal, value, up, hover, down) {
return A3(newElement,
max3(up.props.width, hover.props.width, down.props.width),
max3(up.props.height, hover.props.height, down.props.height),
{ ctor: 'Custom',
type: 'CustomButton',
render: renderCustomButton,
update: updateCustomButton,
model: { signal:signal, value:value, up:up, hover:hover, down:down }
});
}
return { _:{}, customButton:F4(button), events:events };
}
function renderCheckbox(model) {
var node = newNode('input');
node.type = 'checkbox';
node.checked = model.checked;
node.style.display = 'block';
node.style.pointerEvents = 'auto';
node.elm_signal = model.signal;
node.elm_handler = model.handler;
function change() {
elm.notify(node.elm_signal.id, node.elm_handler(node.checked));
}
node.addEventListener('change', change);
return node;
}
function updateCheckbox(node, oldModel, newModel) {
node.elm_signal = newModel.signal;
node.elm_handler = newModel.handler;
node.checked = newModel.checked;
return true;
}
function hoverables(defaultValue) {
var events = Signal.constant(defaultValue);
function hoverable(handler, elem) {
function onHover(bool) {
elm.notify(events.id, handler(bool));
}
var props = Utils.replace([['hover',onHover]], elem.props);
return { props:props, element:elem.element };
}
return { _:{}, hoverable:F2(hoverable), events:events };
}
function checkbox(signal, handler, checked) {
return A3(newElement, 13, 13, {
ctor: 'Custom',
type: 'CheckBox',
render: renderCheckbox,
update: updateCheckbox,
model: { signal:signal, handler:handler, checked:checked }
});
}
function setRange(node, start, end, dir) {
if (node.parentNode) {
node.setSelectionRange(start, end, dir);
} else {
setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
}
}
function checkboxes(defaultValue) {
var events = Signal.constant(defaultValue);
function updateIfNeeded(css, attribute, latestAttribute) {
if (css[attribute] !== latestAttribute) {
css[attribute] = latestAttribute;
}
}
function cssDimensions(dimensions) {
return dimensions.top + 'px ' +
dimensions.right + 'px ' +
dimensions.bottom + 'px ' +
dimensions.left + 'px';
}
function updateFieldStyle(css, style) {
updateIfNeeded(css, 'padding', cssDimensions(style.padding));
function render(model) {
var b = newNode('input');
b.type = 'checkbox';
b.checked = model.checked;
b.style.display = 'block';
b.elmHandler = model.handler;
function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
b.addEventListener('change', change);
return b;
}
var outline = style.outline;
updateIfNeeded(css, 'border-width', cssDimensions(outline.width));
updateIfNeeded(css, 'border-color', toCss(outline.color));
updateIfNeeded(css, 'border-radius', outline.radius + 'px');
function update(node, oldModel, newModel) {
node.elmHandler = newModel.handler;
node.checked = newModel.checked;
return true;
}
var highlight = style.highlight;
if (highlight.width === 0) {
css.outline = 'none';
} else {
updateIfNeeded(css, 'outline-width', highlight.width + 'px');
updateIfNeeded(css, 'outline-color', toCss(highlight.color));
}
function box(handler, checked) {
return A3(newElement, 13, 13, {
ctor: 'Custom',
type: 'CheckBox',
render: render,
update: update,
model: { checked:checked, handler:handler }
});
}
var textStyle = style.style;
updateIfNeeded(css, 'color', toCss(textStyle.color));
if (textStyle.typeface.ctor !== '[]') {
updateIfNeeded(css, 'font-family', Text.toTypefaces(textStyle.typeface));
}
if (textStyle.height.ctor !== "Nothing") {
updateIfNeeded(css, 'font-size', textStyle.height._0 + 'px');
}
updateIfNeeded(css, 'font-weight', textStyle.bold ? 'bold' : 'normal');
updateIfNeeded(css, 'font-style', textStyle.italic ? 'italic' : 'normal');
if (textStyle.line.ctor !== 'Nothing') {
updateIfNeeded(css, 'text-decoration', Text.toLine(textStyle.line._0));
}
}
return { _:{}, checkbox:F2(box), events:events };
}
function renderField(model) {
var field = newNode('input');
updateFieldStyle(field.style, model.style);
field.style.borderStyle = 'solid';
field.style.pointerEvents = 'auto';
function setRange(node, start, end, dir) {
if (node.parentNode) {
node.setSelectionRange(start, end, dir);
} else {
setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
}
}
field.type = model.type;
field.placeholder = JS.fromString(model.placeHolder);
field.value = JS.fromString(model.content.string);
function mkTextPool(type) { return function fields(defaultValue) {
var events = Signal.constant(defaultValue);
field.elm_signal = model.signal;
field.elm_handler = model.handler;
field.elm_old_value = field.value;
var state = null;
function inputUpdate(event) {
var curr = field.elm_old_value;
var next = field.value;
if (curr === next) {
return;
}
function render(model) {
var field = newNode('input');
field.elmHandler = model.handler;
var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
var start = field.selectionStart;
var end = field.selectionEnd;
field.value = field.elm_old_value;
field.id = 'test';
field.type = type;
field.placeholder = JS.fromString(model.placeHolder);
field.value = JS.fromString(model.state.string);
setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
field.style.border = 'none';
state = model.state;
elm.notify(field.elm_signal.id, field.elm_handler({
_:{},
string: JS.toString(next),
selection: {
_:{},
start: start,
end: end,
direction: { ctor: direction }
},
}));
}
function update() {
var start = field.selectionStart,
end = field.selectionEnd;
if (field.selectionDirection === 'backward') {
start = end;
end = field.selectionStart;
}
state = { _:{},
string:JS.toString(field.value),
selectionStart:start,
selectionEnd:end };
elm.notify(events.id, field.elmHandler(state));
}
function mousedown() {
update();
elm.node.addEventListener('mouseup', mouseup);
}
function mouseup() {
update();
elm.node.removeEventListener('mouseup', mouseup)
}
field.addEventListener('keyup', update);
field.addEventListener('mousedown', mousedown);
function mouseUpdate(event) {
var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
elm.notify(field.elm_signal.id, field.elm_handler({
_:{},
string: field.value,
selection: {
_:{},
start: field.selectionStart,
end: field.selectionEnd,
direction: { ctor: direction }
},
}));
}
function mousedown(event) {
mouseUpdate(event);
elm.node.addEventListener('mouseup', mouseup);
}
function mouseup(event) {
mouseUpdate(event);
elm.node.removeEventListener('mouseup', mouseup)
}
field.addEventListener('input', inputUpdate);
field.addEventListener('mousedown', mousedown);
field.addEventListener('focus', function() {
field.elm_hasFocus = true;
});
field.addEventListener('blur', function() {
field.elm_hasFocus = false;
});
return field;
}
return field;
}
function update(node, oldModel, newModel) {
node.elmHandler = newModel.handler;
if (state === newModel.state) return;
var newStr = JS.fromString(newModel.state.string);
if (node.value !== newStr) node.value = newStr;
function updateField(field, oldModel, newModel) {
if (oldModel.style !== newModel.style) {
updateFieldStyle(field.style, newModel.style);
}
field.elm_signal = newModel.signal;
field.elm_handler = newModel.handler;
var start = newModel.state.selectionStart;
var end = newModel.state.selectionEnd;
var direction = 'forward';
if (end < start) {
start = end;
end = newModel.state.selectionStart;
direction = 'backward';
}
field.type = newModel.type;
field.placeholder = JS.fromString(newModel.placeHolder);
var value = JS.fromString(newModel.content.string);
field.value = value;
field.elm_old_value = value;
if (field.elm_hasFocus) {
var selection = newModel.content.selection;
var direction = selection.direction.ctor === 'Forward' ? 'forward' : 'backward';
setRange(field, selection.start, selection.end, direction);
}
}
if (node.selectionStart !== start
|| node.selectionEnd !== end
|| node.selectionDirection !== direction) {
setRange(node, start, end, direction);
}
}
function mkField(type) {
function field(style, signal, handler, placeHolder, content) {
var padding = style.padding;
var outline = style.outline.width;
var adjustWidth = padding.left + padding.right + outline.left + outline.right;
var adjustHeight = padding.top + padding.bottom + outline.top + outline.bottom;
return A3(newElement, 200, 30, {
ctor: 'Custom',
type: type + 'Field',
adjustWidth: adjustWidth,
adjustHeight: adjustHeight,
render: renderField,
update: updateField,
model: {
signal:signal,
handler:handler,
placeHolder:placeHolder,
content:content,
style:style,
type:type
}
});
}
return F5(field);
}
function field(handler, placeHolder, state) {
return A3(newElement, 200, 30,
{ ctor: 'Custom',
type: type + 'Input',
render: render,
update: update,
model: { handler:handler,
placeHolder:placeHolder,
state:state }
});
}
function hoverable(signal, handler, elem) {
function onHover(bool) {
elm.notify(signal.id, handler(bool));
}
var props = Utils.replace([['hover',onHover]], elem.props);
return { props:props, element:elem.element };
}
return { _:{}, field:F3(field), events:events };
}
}
function clickable(signal, value, elem) {
function onClick(bool) {
elm.notify(signal.id, value);
}
var props = Utils.replace([['click',onClick]], elem.props);
return { props:props, element:elem.element };
}
return elm.Native.Graphics.Input.values = {
buttons:buttons,
customButtons:customButtons,
hoverables:hoverables,
checkboxes:checkboxes,
fields:mkTextPool('text'),
emails:mkTextPool('email'),
passwords:mkTextPool('password'),
dropDown:dropDown
};
return elm.Native.Graphics.Input.values = {
input:input,
button:F3(button),
customButton:F5(customButton),
checkbox:F3(checkbox),
dropDown:F2(dropDown),
field:mkField('text'),
email:mkField('email'),
password:mkField('password'),
hoverable:F3(hoverable),
clickable:F3(clickable)
};
};

29
libraries/Native/Regex.js
View file

@ -15,18 +15,16 @@ Elm.Native.Regex.make = function(elm) {
function caseInsensitive(re) {
return new RegExp(re.source, 'gi');
}
function pattern(raw) {
function regex(raw) {
return new RegExp(raw, 'g');
}
function contains(re, string) {
return re.test(JS.fromString(string));
return JS.fromString(string).match(re) !== null;
}
function findAll(re, string) {
return find(Infinity, re, string);
}
function find(n, re, str) {
n = n.ctor === "All" ? Infinity : n._0;
var out = [];
var number = 0;
var string = JS.fromString(str);
@ -51,10 +49,8 @@ Elm.Native.Regex.make = function(elm) {
return JS.toList(out);
}
function replaceAll(re, replacer, string) {
return replace(Infinity, re, replacer, string);
}
function replace(n, re, replacer, string) {
n = n.ctor === "All" ? Infinity : n._0;
var count = 0;
function jsReplacer(match) {
if (count++ > n) return match;
@ -77,10 +73,10 @@ Elm.Native.Regex.make = function(elm) {
return string.replace(re, jsReplacer);
}
function split(re, string) {
return JS.toList(JS.fromString(string).split(re));
}
function splitN(n, re, str) {
function split(n, re, str) {
if (n === Infinity) {
return JS.toList(JS.fromString(string).split(re));
}
var string = JS.fromString(str);
var result;
var out = [];
@ -95,18 +91,13 @@ Elm.Native.Regex.make = function(elm) {
}
return Elm.Native.Regex.values = {
pattern: pattern,
regex: regex,
caseInsensitive: caseInsensitive,
escape: escape,
contains: F2(contains),
findAll: F2(findAll),
find: F3(find),
replaceAll: F3(replaceAll),
replace: F4(replace),
split: F2(split),
splitN: F3(splitN),
split: F3(split),
};
};

3
libraries/Native/Show.js
View file

@ -6,10 +6,7 @@ Elm.Native.Show.make = function(elm) {
var NList = Elm.Native.List.make(elm);
var List = Elm.List.make(elm);
var Maybe = Elm.Maybe.make(elm);
var JS = Elm.JavaScript.make(elm);
var Dict = Elm.Dict.make(elm);
var Json = Elm.Json.make(elm);
var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;
var toString = function(v) {

105
libraries/Native/Signal/Http.js
View file

@ -1,61 +1,64 @@
Elm.Native.Http = {};
Elm.Native.Http.make = function(elm) {
elm.Native = elm.Native || {};
elm.Native.Http = elm.Native.Http || {};
if (elm.Native.Http.values) return elm.Native.Http.values;
elm.Native = elm.Native || {};
elm.Native.Http = elm.Native.Http || {};
if (elm.Native.Http.values) return elm.Native.Http.values;
var JS = Elm.JavaScript.make(elm);
var List = Elm.List.make(elm);
var Signal = Elm.Signal.make(elm);
var JS = Elm.JavaScript.make(elm);
var List = Elm.List.make(elm);
var Signal = Elm.Signal.make(elm);
function registerReq(queue,responses) { return function(req) {
if (req.url.ctor !== '[]') { sendReq(queue,responses,req); }
};
}
function updateQueue(queue,responses) {
if (queue.length > 0) {
elm.notify(responses.id, queue[0].value);
if (queue[0].value.ctor !== 'Waiting') {
queue.shift();
setTimeout(function() { updateQueue(queue,responses); }, 0);
}
function registerReq(queue,responses) {
return function(req) {
if (req.url.length > 0) {
sendReq(queue,responses,req);
}
};
}
}
function sendReq(queue,responses,req) {
var response = { value: { ctor:'Waiting' } };
queue.push(response);
function updateQueue(queue,responses) {
if (queue.length > 0) {
elm.notify(responses.id, queue[0].value);
if (queue[0].value.ctor !== 'Waiting') {
queue.shift();
setTimeout(function() { updateQueue(queue,responses); }, 0);
}
}
}
var request = null;
if (window.ActiveXObject) { request = new ActiveXObject("Microsoft.XMLHTTP"); }
if (window.XMLHttpRequest) { request = new XMLHttpRequest(); }
request.onreadystatechange = function(e) {
if (request.readyState === 4) {
response.value = (request.status >= 200 && request.status < 300 ?
{ ctor:'Success', _0:JS.toString(request.responseText) } :
{ ctor:'Failure', _0:request.status, _1:JS.toString(request.statusText) });
setTimeout(function() { updateQueue(queue,responses); }, 0);
}
function sendReq(queue,responses,req) {
var response = { value: { ctor:'Waiting' } };
queue.push(response);
var request = (window.ActiveXObject
? new ActiveXObject("Microsoft.XMLHTTP")
: new XMLHttpRequest());
request.onreadystatechange = function(e) {
if (request.readyState === 4) {
response.value = (request.status >= 200 && request.status < 300 ?
{ ctor:'Success', _0:JS.toString(request.responseText) } :
{ ctor:'Failure', _0:request.status, _1:JS.toString(request.statusText) });
setTimeout(function() { updateQueue(queue,responses); }, 0);
}
};
request.open(JS.fromString(req.verb), JS.fromString(req.url), true);
function setHeader(pair) {
request.setRequestHeader( JS.fromString(pair._0), JS.fromString(pair._1) );
}
List.map(setHeader)(req.headers);
request.send(JS.fromString(req.body));
}
function send(requests) {
var responses = Signal.constant(elm.Http.values.Waiting);
var sender = A2( Signal.lift, registerReq([],responses), requests );
function f(x) { return function(y) { return x; } }
return A3( Signal.lift2, f, responses, sender );
}
return elm.Native.Http.values = {
send:send
};
request.open(JS.fromString(req.verb), JS.fromString(req.url), true);
function setHeader(pair) {
request.setRequestHeader( JS.fromString(pair._0), JS.fromString(pair._1) );
}
List.map(setHeader)(req.headers);
request.send(JS.fromString(req.body));
}
function send(requests) {
var responses = Signal.constant(elm.Http.values.Waiting);
var sender = A2( Signal.lift, registerReq([],responses), requests );
function f(x) { return function(y) { return x; } }
return A3( Signal.lift2, f, responses, sender );
}
return elm.Native.Http.values = {send:send};
};

6
libraries/Native/Signal/Mouse.js
View file

@ -20,15 +20,12 @@ Elm.Native.Mouse.make = function(elm) {
y.defaultNumberOfKids = 0;
var isDown = Signal.constant(false);
var isClicked = Signal.constant(false);
var clicks = Signal.constant(Utils.Tuple0);
var node = elm.display === ElmRuntime.Display.FULLSCREEN ? document : elm.node;
elm.addListener([isClicked.id, clicks.id], node, 'click', function click() {
elm.notify(isClicked.id, true);
elm.addListener([clicks.id], node, 'click', function click() {
elm.notify(clicks.id, Utils.Tuple0);
elm.notify(isClicked.id, false);
});
elm.addListener([isDown.id], node, 'mousedown', function down() {
elm.notify(isDown.id, true);
@ -44,7 +41,6 @@ Elm.Native.Mouse.make = function(elm) {
position: position,
x:x,
y:y,
isClicked: isClicked,
isDown: isDown,
clicks: clicks
};

9
libraries/Native/Signal/Signal.js
View file

@ -127,12 +127,6 @@ Elm.Native.Signal.make = function(elm) {
input.kids.push(this);
}
function dropWhen(s1,b,s2) {
var pairs = lift2( F2(function(x,y){return {x:x,y:y};}), s1, s2 );
var dropped = new DropIf(function(p){return p.x;},{x:true,y:b},pairs);
return lift(function(p){return p.y;}, dropped);
}
function timestamp(a) {
function update() { return Utils.Tuple2(Date.now(), a.value); }
return new LiftN(update, [a]);
@ -225,9 +219,6 @@ Elm.Native.Signal.make = function(elm) {
keepIf : F3(function(pred,base,sig) {
return new DropIf(function(x) {return !pred(x);},base,sig); }),
dropIf : F3(function(pred,base,sig) { return new DropIf(pred,base,sig); }),
keepWhen : F3(function(s1,b,s2) {
return dropWhen(lift(function(b){return !b;},s1), b, s2); }),
dropWhen : F3(dropWhen),
dropRepeats : function(s) { return new DropRepeats(s);},
sampleOn : F2(sampleOn),
timestamp : timestamp

3
libraries/Native/String.js
View file

@ -144,7 +144,8 @@ Elm.Native.String.make = function(elm) {
return str.indexOf(sub) === 0;
}
function endsWith(sub, str) {
return str.lastIndexOf(sub) === str.length - sub.length;
return str.length >= sub.length &&
str.lastIndexOf(sub) === str.length - sub.length;
}
function indexes(sub, str) {
var subLen = sub.length;

100
libraries/Native/Text.js
View file

@ -4,11 +4,10 @@ Elm.Native.Text.make = function(elm) {
elm.Native.Text = elm.Native.Text || {};
if (elm.Native.Text.values) return elm.Native.Text.values;
var JS = Elm.JavaScript.make(elm);
var Utils = Elm.Native.Utils.make(elm);
var Color = Elm.Native.Color.make(elm);
var toCss = Elm.Native.Color.make(elm).toCss;
var Element = Elm.Graphics.Element.make(elm);
var show = Elm.Native.Show.make(elm).show;
var List = Elm.Native.List.make(elm);
var Utils = Elm.Native.Utils.make(elm);
function makeSpaces(s) {
if (s.length == 0) { return s; }
@ -51,13 +50,51 @@ Elm.Native.Text.make = function(elm) {
return arr.join('<br/>');
}
function toText(str) { return Utils.txt(properEscape(JS.fromString(str))); }
function toText(str) { return Utils.txt(properEscape(str)); }
// conversions from Elm values to CSS
function toTypefaces(list) {
var typefaces = List.toArray(list);
for (var i = typefaces.length; i--; ) {
var typeface = typefaces[i];
if (typeface.indexOf(' ') > -1) {
typefaces[i] = "'" + typeface + "'";
}
}
return typefaces.join(',');
}
function toLine(line) {
var ctor = line.ctor;
return ctor === 'Under' ? 'underline' :
ctor === 'Over' ? 'overline' : 'line-through';
}
// setting styles of Text
function style(style, text) {
var newText = '<span style="color:' + toCss(style.color) + ';'
if (style.typeface.ctor !== '[]') {
newText += 'font-family:' + toTypefaces(style.typeface) + ';'
}
if (style.height.ctor !== "Nothing") {
newText += 'font-size:' + style.height._0 + 'px;';
}
if (style.bold) {
newText += 'font-weight:bold;';
}
if (style.italic) {
newText += 'font-style:italic;';
}
if (style.line.ctor !== 'Nothing') {
newText += 'text-decoration:' + toLine(style.line._0) + ';';
}
newText += '">' + Utils.makeText(text) + '</span>'
return Utils.txt(newText);
}
function height(px, text) {
return { style: 'font-size:' + px + 'px;', text:text }
}
function typeface(name, text) {
return { style: 'font-family:' + name + ';', text:text }
function typeface(names, text) {
return { style: 'font-family:' + toTypefaces(names) + ';', text:text }
}
function monospace(text) {
return { style: 'font-family:monospace;', text:text }
@ -71,25 +108,16 @@ Elm.Native.Text.make = function(elm) {
function link(href, text) {
return { href: toText(href), text:text };
}
function underline(text) {
return { line: ' underline', text:text };
}
function overline(text) {
return { line: ' overline', text:text };
}
function strikeThrough(text) {
return { line: ' line-through', text:text };
function line(line, text) {
return { style: 'text-decoration:' + toLine(line) + ';', text:text };
}
function color(c, text) {
var color = (c._3 === 1)
? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
: ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
return { style: 'color:' + color + ';', text:text };
function color(color, text) {
return { style: 'color:' + toCss(color) + ';', text:text };
}
function position(align) {
function create(text) {
function block(align) {
return function(text) {
var raw = {
ctor :'RawHtml',
html : Utils.makeText(text),
@ -100,7 +128,6 @@ Elm.Native.Text.make = function(elm) {
var pos = A2(Utils.htmlHeight, 0, raw);
return A3(Element.newElement, pos._0, pos._1, raw);
}
return create;
}
function markdown(text, guid) {
@ -115,36 +142,25 @@ Elm.Native.Text.make = function(elm) {
return A3(Element.newElement, pos._0, pos._1, raw);
}
var text = position('left');
function asText(v) {
return text(monospace(toText(show(v))));
}
function plainText(v) {
return text(toText(v));
}
return elm.Native.Text.values = {
toText: toText,
height : F2(height),
italic : italic,
bold : bold,
underline : underline,
overline : overline,
strikeThrough : strikeThrough,
line : F2(line),
monospace : monospace,
typeface : F2(typeface),
color : F2(color),
link : F2(link),
justified : position('justify'),
centered : position('center'),
righted : position('right'),
text : text,
plainText : plainText,
markdown : markdown,
leftAligned : block('left'),
rightAligned : block('right'),
centered : block('center'),
justified : block('justify'),
markdown : markdown,
asText : asText,
toTypefaces:toTypefaces,
toLine:toLine,
};
};

24
libraries/Native/Trampoline.js Normal file
View file

@ -0,0 +1,24 @@
Elm.Native.Trampoline = {};
Elm.Native.Trampoline.make = function(elm) {
elm.Native = elm.Native || {};
elm.Native.Trampoline = elm.Native.Trampoline || {};
if (elm.Native.Trampoline.values) return elm.Native.Trampoline.values;
// trampoline : Trampoline a -> a
function trampoline(t) {
var tramp = t;
while(true) {
switch(tramp.ctor) {
case "Done":
return tramp._0;
case "Continue":
tramp = tramp._0({ctor: "_Tuple0"});
continue;
}
}
}
return elm.Native.Trampoline.values = {
trampoline:trampoline
};
};

14
libraries/Native/Utils.js
View file

@ -9,7 +9,12 @@ Elm.Native.Utils.make = function(elm) {
if (x === y) return true;
if (typeof x === "object") {
var c = 0;
for (var i in x) { ++c; if (!eq(x[i],y[i])) return false; }
for (var i in x) {
++c;
if (!eq(x[i],y[i])) {
return false;
}
}
return c === Object.keys(y).length;
}
if (typeof x === 'function') {
@ -76,14 +81,8 @@ Elm.Native.Utils.make = function(elm) {
function makeText(text) {
var style = '';
var line = '';
var href = '';
while (true) {
if (text.line) {
line += text.line;
text = text.text;
continue;
}
if (text.style) {
style += text.style;
text = text.text;
@ -95,7 +94,6 @@ Elm.Native.Utils.make = function(elm) {
continue;
}
if (href) text = '<a href="' + href + '">' + text + '</a>';
if (line) style += 'text-decoration:' + line + ';';
if (style) text = '<span style="' + style + '">' + text + '</span>';
return text;
}

8
libraries/Prelude.elm
View file

@ -1,8 +0,0 @@
module Prelude where
{-| Everything that is automatically imported -}
import Native.Show
-- Convert almost any value to its string representation.
show : a -> String
show = Native.Show.show

105
libraries/Regex.elm
View file

@ -3,16 +3,17 @@ module Regex where
same kind of regular expressions accepted by JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions).
# Create
@docs pattern, caseInsensitive, escape
@docs regex, escape, caseInsensitive
# Match
@docs Match
# Helpful Data Structures
# Find and Replace
@docs contains, find, findAll, replace, replaceAll
These data structures are needed to help define functions like [`find`](#find)
and [`replace`](#replace).
# Split
@docs split, splitN
@docs HowMany, Match
# Use
@docs contains, find, replace, split
-}
@ -21,31 +22,35 @@ import Native.Regex
data Regex = Regex
{-| Escape all special characters. So `pattern (escape "$$$")`
will match exactly `"$$$"` even though `$` is a special character.
{-| Escape strings to be regular expressions, making all special characters
safe. So `regex (escape "^a+")` will match exactly `"^a+"` instead of a series
of `a`&rsquo;s that start at the beginning of the line.
-}
escape : String -> String
escape = Native.Regex.escape
{-| Create a Regex that matches patterns [as specified in JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Writing_a_Regular_Expression_Pattern).
Be careful to escape backslashes properly!
Be careful to escape backslashes properly! For example, `"\w"` is escaping the
letter `w` which is probably not what you want. You probably want `"\\w"`
instead, which escapes the backslash.
-}
pattern : String -> Regex
pattern = Native.Regex.pattern
regex : String -> Regex
regex = Native.Regex.regex
{-| Make a pattern case insensitive -}
{-| Make a regex case insensitive -}
caseInsensitive : Regex -> Regex
caseInsensitive = Native.Regex.caseInsensitive
{-| Check to see if a Regex is contained in a string.
```haskell
contains (pattern "123") "12345" == True
contains (pattern "b+") "aabbcc" == True
contains (regex "123") "12345" == True
contains (regex "b+") "aabbcc" == True
contains (pattern "789") "12345" == False
contains (pattern "z+") "aabbcc" == False
contains (regex "789") "12345" == False
contains (regex "z+") "aabbcc" == False
```
-}
contains : Regex -> String -> Bool
@ -55,79 +60,67 @@ contains = Native.Regex.contains
Here are details on each field:
* `match` &mdash; the full string of the match.
* `submatches` &mdash; a pattern might have [subpatterns, surrounded by
* `submatches` &mdash; a regex might have [subpatterns, surrounded by
parentheses](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Using_Parenthesized_Substring_Matches).
If there are N subpatterns, there will be N elements in the `submatches` list.
Each submatch in this list is a `Maybe` because not all subpatterns may trigger.
For example, `(pattern "(a+)|(b+)")` will either match many `a`&rsquo;s or
For example, `(regex "(a+)|(b+)")` will either match many `a`&rsquo;s or
many `b`&rsquo;s, but never both.
* `index` &mdash; the index of the match in the original string.
* `number` &mdash; if you find many matches, you can think of each one
as being labeled with a `number` starting at one. So the first time you
find a match, that is match `number` one. Second time is match `number` two.
This is useful when paired with `replaceAll` if replacement is dependent on how
This is useful when paired with `replace All` if replacement is dependent on how
many times a pattern has appeared before.
-}
type Match = { match : String, submatches : [Maybe String], index : Int, number : Int }
{-| Find all of the matches in a string:
{-| `HowMany` is used to specify how many matches you want to make. So
`replace All` would replace every match, but `replace (AtMost 2)` would
replace at most two matches (i.e. zero, one, two, but never three or more).
-}
data HowMany = All | AtMost Int
{-| Find matches in a string:
```haskell
words = findAll (pattern "\\w+") "hello world"
findTwoCommas = find (AtMost 2) (regex ",")
map .match words == ["hello","world"]
map .index words == [0,6]
-- map .index (findTwoCommas "a,b,c,d,e") == [1,3]
-- map .index (findTwoCommas "a b c d e") == []
places = findAll (pattern "[oi]n a (\\w+)") "I am on a boat in a lake."
places = find All (regex "[oi]n a (\\w+)") "I am on a boat in a lake."
map .match places== ["on a boat", "in a lake"]
map .submatches places == [ [Just "boat"], [Just "lake"] ]
-- map .match places == ["on a boat", "in a lake"]
-- map .submatches places == [ [Just "boat"], [Just "lake"] ]
```
-}
findAll : Regex -> String -> [Match]
findAll = Native.Regex.findAll
{-| Same as `findAll`, but `find` will quit searching after the *n<sup>th</sup>* match.
That means the resulting list has maximum length N, but *it can be shorter*
if there are not that many matches in the given string.
-}
find : Int -> Regex -> String -> [Match]
find : HowMany -> Regex -> String -> [Match]
find = Native.Regex.find
{-| Replace all matches. The function from `Match` to `String` lets
{-| Replace matches. The function from `Match` to `String` lets
you use the details of a specific match when making replacements.
```haskell
devowel = replaceAll (pattern "[aeiou]") (\_ -> "")
devowel = replace All (regex "[aeiou]") (\_ -> "")
devowel "The quick brown fox" == "Th qck brwn fx"
-- devowel "The quick brown fox" == "Th qck brwn fx"
reverseWords = replaceAll (pattern "\\w+") (\{match} -> String.reverse match)
reverseWords = replace All (regex "\\w+") (\{match} -> String.reverse match)
reverseWords "deliver mined parts" == "reviled denim strap"
-- reverseWords "deliver mined parts" == "reviled denim strap"
```
-}
replaceAll : Regex -> (Match -> String) -> String -> String
replaceAll = Native.Regex.replaceAll
{-| Same as `replaceAll`, but `replace` will quit after the *n<sup>th</sup>* match.-}
replace : Int -> Regex -> (Match -> String) -> String -> String
replace : HowMany -> Regex -> (Match -> String) -> String -> String
replace = Native.Regex.replace
{-| Split a string, using the regex as the separator.
```haskell
split (pattern " *, *") "a ,b, c,d" == ["a","b","c","d"]
split (AtMost 1) (regex ",") "tom,99,90,85" == ["tom","99,90,85"]
split All (regex ",") "a,b,c,d" == ["a","b","c","d"]
```
-}
split : Regex -> String -> [String]
split : HowMany -> Regex -> String -> [String]
split = Native.Regex.split
{-| Same as `split` but stops after the *n<sup>th</sup>* match.
```haskell
splitN 1 (pattern ": *") "tom: 99,90,85" == ["tom","99,90,85"]
```
-}
splitN : Int -> Regex -> String -> [String]
splitN = Native.Regex.splitN

9
libraries/Signal.elm
View file

@ -32,6 +32,10 @@ the [`Time`](/docs/Signal/Time.elm) library.
import Native.Signal
import List (foldr)
import Basics (fst, snd, not)
import Native.Error
import Maybe as M
data Signal a = Signal
{-| Create a constant signal that never changes. -}
@ -122,7 +126,8 @@ Until the first signal becomes false again, all events will be propagated. Elm
does not allow undefined signals, so a base case must be provided in case the
first signal is not true initially. -}
keepWhen : Signal Bool -> a -> Signal a -> Signal a
keepWhen = Native.Signal.keepWhen
keepWhen bs def sig =
snd <~ (keepIf fst (False, def) ((,) <~ (sampleOn sig bs) ~ sig))
{-| Drop events when the first signal is true. When the first signal becomes
false, the most recent value of the second signal will be propagated. Until the
@ -130,7 +135,7 @@ first signal becomes true again, all events will be propagated. Elm does not
allow undefined signals, s oa base case must be provided in case the first
signal is true initially. -}
dropWhen : Signal Bool -> a -> Signal a -> Signal a
dropWhen = Native.Signal.dropWhen
dropWhen bs = keepWhen (not <~ bs)
{-| Drop updates that repeat the current value of the signal.

39
libraries/String.elm
View file

@ -15,7 +15,7 @@ are enclosed in `"double quotes"`. Strings are *not* lists of characters.
@docs contains, startsWith, endsWith, indexes, indices
# Conversions
@docs toInt, toFloat, toList, fromList
@docs show, toInt, toFloat, toList, fromList
# Formatting
Cosmetic operations such as padding with extra characters or trimming whitespace.
@ -28,10 +28,15 @@ Cosmetic operations such as padding with extra characters or trimming whitespace
@docs map, filter, foldl, foldr, any, all
-}
import Native.Show
import Native.String
import Maybe (Maybe)
{-| Check if a string is empty `(isEmpty "" == True)` -}
{-| Check if a string is empty.
isEmpty "" == True
isEmpty "the world" == False
-}
isEmpty : String -> Bool
isEmpty = Native.String.isEmpty
@ -63,7 +68,11 @@ append = Native.String.append
concat : [String] -> String
concat = Native.String.concat
{-| Get the length of a string `(length "innumerable" == 11)` -}
{-| Get the length of a string.
length "innumerable" == 11
-}
length : String -> Int
length = Native.String.length
@ -81,7 +90,10 @@ map = Native.String.map
filter : (Char -> Bool) -> String -> String
filter = Native.String.filter
{-| Reverse a string. `(reverse "stressed" == "desserts")` -}
{-| Reverse a string.
reverse "stressed" == "desserts"
-}
reverse : String -> String
reverse = Native.String.reverse
@ -103,6 +115,8 @@ foldr = Native.String.foldr
split "," "cat,dog,cow" == ["cat","dog","cow"]
split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
Use `Regex.split` if you need something more flexible.
-}
split : String -> String -> [String]
split = Native.String.split
@ -115,7 +129,10 @@ split = Native.String.split
join : String -> [String] -> String
join = Native.String.join
{-| Repeat a string N times `(repeat 3 "ha" == "hahaha")` -}
{-| Repeat a string N times.
repeat 3 "ha" == "hahaha"
-}
repeat : Int -> String -> String
repeat = Native.String.repeat
@ -231,7 +248,7 @@ any = Native.String.any
all isDigit "90210" == True
all isDigit "R2-D2" == False
any isDigit "heart" == False
all isDigit "heart" == False
-}
all : (Char -> Bool) -> String -> Bool
all = Native.String.all
@ -241,6 +258,8 @@ all = Native.String.all
contains "the" "theory" == True
contains "hat" "theory" == False
contains "THE" "theory" == False
Use `Regex.contains` if you need something more flexible.
-}
contains : String -> String -> Bool
contains = Native.String.contains
@ -274,6 +293,14 @@ indexes = Native.String.indexes
indices : String -> String -> [Int]
indices = Native.String.indexes
{-| Turn any kind of value into a string.
show 42 == "42"
show [1,2] == "[1,2]"
-}
show : a -> String
show = Native.Show.show
{-| Try to convert a string into an int, failing on improperly formatted strings.
toInt "123" == Just 123

204
libraries/Text.elm
View file

@ -1,99 +1,210 @@
module Text where
{-| Functions for displaying text
{-| A library for styling and displaying text. Whlie the `String` library
focuses on representing and manipulating strings of character strings, the
`Text` library focuses on how those strings should look on screen. It lets
you make text bold or italic, set the typeface, set the text size, etc.
# Creating Text
@docs toText
# Creating Elements
@docs plainText, asText, text, centered, justified, righted
# Formatting
@docs color, typeface, height, link
Each of the following functions places `Text` into a box. The function you use
determines the alignment of the text.
# Simple Formatting
@docs monospace, bold, italic, underline, overline, strikeThrough
@docs leftAligned, rightAligned, centered, justified
# Links and Style
@docs link, Style, style, defaultStyle, Line
# Convenience Functions
There are two convenience functions for creating an `Element` which can be
useful when debugging or prototyping:
@docs plainText, asText
There are also a bunch of functions to set parts of a `Style` individually:
@docs typeface, monospace, height, color, bold, italic, line
-}
import open Basics
import Color (Color)
import Basics (..)
import String
import Color (Color, black)
import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
import Maybe (Maybe)
import Maybe (Maybe, Nothing)
import JavaScript (JSString)
import Native.Show
import Native.Text
data Text = Text
{-| Convert a string into text which can be styled and displayed. -}
{-| Styles for lines on text. This allows you to add an underline, an overline,
or a strike out text:
line Under (toText "underline")
line Over (toText "overline")
line Through (toText "strike out")
-}
data Line = Under | Over | Through
{-| Representation of all the ways you can style `Text`. If the `typeface` list
is empty or the `height` is `Nothing`, the users will fall back on their
browser's default settings. The following `Style` is black, 16 pixel tall,
underlined, and Times New Roman (assuming that typeface is available on the
user's computer):
{ typeface = [ "Times New Roman", "serif" ]
, height = Just 16
, color = black
, bold = False
, italic = False
, line = Just Under
}
-}
type Style =
{ typeface : [String]
, height : Maybe Float
, color : Color
, bold : Bool
, italic : Bool
, line : Maybe Line
}
{-| Plain black text. It uses the browsers default typeface and text height.
No decorations are used:
{ typeface = []
, height = Nothing
, color = black
, bold = False
, italic = False
, line = Nothing
}
-}
defaultStyle : Style
defaultStyle =
{ typeface = []
, height = Nothing
, color = black
, bold = False
, italic = False
, line = Nothing
}
{-| Convert a string into text which can be styled and displayed. To show the
string `"Hello World!"` on screen in italics, you could say:
main = leftAligned (italic (toText "Hello World!"))
-}
toText : String -> Text
toText = Native.Text.toText
{-| Set the typeface of some text. The first argument should be a comma
separated listing of the desired typefaces:
{-| Set the style of some text. For example, if you design a `Style` called
`footerStyle` that is specifically for the bottom of your page, you could apply
it to text like this:
"helvetica, arial, sans-serif"
Works the same as the CSS font-family property.
style footerStyle (toText "the old prince / 2007")
-}
typeface : String -> Text -> Text
style : Style -> Text -> Text
style = Native.Text.style
{-| Provide a list of prefered typefaces for some text.
["helvetica","arial","sans-serif"]
Not every browser has access to the same typefaces, so rendering will use the
first typeface in the list that is found on the user's computer. If there are
no matches, it will use their default typeface. This works the same as the CSS
font-family property.
-}
typeface : [String] -> Text -> Text
typeface = Native.Text.typeface
{-| Switch to a monospace typeface. Good for code snippets. -}
{-| Switch to a monospace typeface. Good for code snippets.
monospace (toText "foldl (+) 0 [1,2,3]")
-}
monospace : Text -> Text
monospace = Native.Text.monospace
{-| Create a link. -}
{-| Create a link by providing a URL and the text of the link:
link "http://elm-lang.org" (toText "Elm Website")
-}
link : String -> Text -> Text
link = Native.Text.link
{-| Set the height of text in pixels. -}
{-| Set the height of some text:
height 40 (toText "Title")
-}
height : Float -> Text -> Text
height = Native.Text.height
{-| Set the color of a string. -}
{-| Set the color of some text:
color red (toText "Red")
-}
color : Color -> Text -> Text
color = Native.Text.color
{-| Make a string bold. -}
{-| Make text bold:
toText "sometimes you want " ++ bold (toText "emphasis")
-}
bold : Text -> Text
bold = Native.Text.bold
{-| Italicize a string. -}
{-| Make text italic:
toText "make it " ++ italic (toText "important")
-}
italic : Text -> Text
italic = Native.Text.italic
{-| Draw a line above a string. -}
overline : Text -> Text
overline = Native.Text.overline
{-| Put lines on text:
{-| Underline a string. -}
underline : Text -> Text
underline = Native.Text.underline
line Under (toText "underlined")
line Over (toText "overlined")
line Through (toText "strike out")
-}
line : Line -> Text -> Text
line = Native.Text.line
{-| Draw a line through a string. -}
strikeThrough : Text -> Text
strikeThrough = Native.Text.strikeThrough
{-| `Text` is aligned along the left side of the text block. This is sometimes
known as *ragged right*.
-}
leftAligned : Text -> Element
leftAligned = Native.Text.leftAligned
{-| Display justified, styled text. -}
justified : Text -> Element
justified = Native.Text.justified
{-| `Text` is aligned along the right side of the text block. This is sometimes
known as *ragged left*.
-}
rightAligned : Text -> Element
rightAligned = Native.Text.rightAligned
{-| Display centered, styled text. -}
{-| `Text` is centered in the text block. There is equal spacing on either side
of a line of text.
-}
centered : Text -> Element
centered = Native.Text.centered
{-| Display right justified, styled text. -}
righted : Text -> Element
righted = Native.Text.righted
{-| `Text` is aligned along the left and right sides of the text block. Word
spacing is adjusted to make this possible.
-}
justified : Text -> Element
justified = Native.Text.justified
{-| Display styled text. -}
text : Text -> Element
text = Native.Text.text
{-| Display a string with no styling:
{-| Display a plain string. -}
plainText string = leftAligned (toText string)
-}
plainText : String -> Element
plainText = Native.Text.plainText
plainText str =
leftAligned (toText str)
{-| for internal use only -}
markdown : Element
@ -102,9 +213,10 @@ markdown = Native.Text.markdown
{-| Convert anything to its textual representation and make it displayable in
the browser:
asText == text . monospace . show
asText value = text (monospace (show value))
Excellent for debugging.
-}
asText : a -> Element
asText = Native.Text.asText
asText value =
leftAligned (monospace (toText (Native.Show.show value)))

2
libraries/Time.elm
View file

@ -14,7 +14,7 @@ module Time where
-}
import open Basics
import Basics (..)
import Native.Time
import Signal (Signal)

49
libraries/Trampoline.elm Normal file
View file

@ -0,0 +1,49 @@
module Trampoline where
{-| A [trampoline](http://en.wikipedia.org/wiki/Tail-recursive_function#Through_trampolining)
makes it possible to recursively call a function without growing the stack.
Popular JavaScript implementations do not perform any tail-call elimination, so
recursive functions can cause a stack overflow if they go to deep. Trampolines
permit unbounded recursion despite limitations in JavaScript.
This strategy may create many intermediate closures, which is very expensive in
JavaScript, so use this library only when it is essential that you recurse deeply.
# Trampolines
@docs trampoline, Trampoline
-}
import Native.Trampoline
{-| A way to build computations that may be deeply recursive. We will take an
example of a tail-recursive function and rewrite it in a way that lets us use
a trampoline:
length : [a] -> Int
length list = length' 0 list
length' : Int -> [a] -> Int
length' accum list =
case list of
[] -> accum
hd::tl -> length' (accum+1) tl
This finds the length of a list, but if the list is too long, it may cause a
stack overflow. We can rewrite it as follows:
length : [a] -> Int
length list = trampoline (length' 0 list)
length' : Int -> [a] -> Trampoline Int
length' accum list =
case list of
[] -> Done accum
hd::tl -> Continue (\() -> length' (accum+1) tl)
Now it uses a trampoline and can recurse without growing the stack!
-}
data Trampoline a = Done a | Continue (() -> Trampoline a)
{-| Evaluate a trampolined value in constant space. -}
trampoline : Trampoline a -> a
trampoline = Native.Trampoline.trampoline

9
libraries/elm_dependencies.json
View file

@ -1,9 +1,9 @@
{ "version": "0.11"
{ "version": "0.12"
, "summary": "Elm's standard libraries"
, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.11, you should be using version 0.11 of the standard libraries."
, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.12, you should be using version 0.12 of the standard libraries."
, "license": "BSD3"
, "repository": "http://github.com/evancz/Elm.git"
, "elm-version": "0.11"
, "elm-version": "0.12"
, "dependencies": {}
, "exposed-modules":
[ "Basics"
@ -11,11 +11,13 @@
, "Char"
, "Color"
, "Date"
, "Debug"
, "Dict"
, "Either"
, "Graphics.Element"
, "Graphics.Collage"
, "Graphics.Input"
, "Graphics.Input.Field"
, "Http"
, "JavaScript"
, "JavaScript.Experimental"
@ -32,6 +34,7 @@
, "Text"
, "Time"
, "Touch"
, "Trampoline"
, "Transform2D"
, "WebSocket"
, "Window"

4
runtime/HotSwap.js
View file

@ -5,8 +5,8 @@
// structure.
ElmRuntime.swap = function(from, to) {
function similar(nodeOld,nodeNew) {
idOkay = nodeOld.id === nodeNew.id;
lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
var idOkay = nodeOld.id === nodeNew.id;
var lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
return idOkay && lengthOkay;
}
function swap(nodeOld,nodeNew) {

2
runtime/Init.js
View file

@ -91,7 +91,7 @@ function init(display, container, module, ports, moduleToReplace) {
checkPorts(elm);
} catch(e) {
var directions = "<br/>&nbsp; &nbsp; Open the developer console for more details."
Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');
Module.main = Elm.Text.make(elm).leftAligned('<code>' + e.message + directions + '</code>');
reportAnyErrors = function() { throw e; }
}
inputs = ElmRuntime.filterDeadInputs(inputs);

1
runtime/Render/Collage.js
View file

@ -254,6 +254,7 @@ function makeCanvas(w,h) {
function render(model) {
var div = newElement('div');
div.style.overflow = 'hidden';
div.style.position = 'relative';
update(div, model, model);
return div;
}

89
runtime/Render/Element.js
View file

@ -7,10 +7,16 @@ var newElement = Utils.newElement, extract = Utils.extract,
addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
fromList = Utils.fromList, eq = Utils.eq;
function setProps(props, e) {
e.style.width = (props.width |0) + 'px';
e.style.height = (props.height|0) + 'px';
if (props.opacity !== 1) { e.style.opacity = props.opacity; }
function setProps(elem, e) {
var props = elem.props;
var element = elem.element;
var width = props.width - (element.adjustWidth || 0);
var height = props.height - (element.adjustHeight || 0);
e.style.width = (width |0) + 'px';
e.style.height = (height|0) + 'px';
if (props.opacity !== 1) {
e.style.opacity = props.opacity;
}
if (props.color.ctor === 'Just') {
e.style.backgroundColor = extract(props.color._0);
}
@ -28,15 +34,30 @@ function setProps(props, e) {
e.appendChild(a);
}
if (props.hover.ctor !== '_Tuple0') {
var overCount = 0;
e.style.pointerEvents = 'auto';
e.elm_hover_handler = props.hover;
e.elm_hover_count = 0;
e.addEventListener('mouseover', function() {
if (overCount++ > 0) return;
props.hover(true);
if (e.elm_hover_count++ > 0) return;
var handler = e.elm_hover_handler;
if (handler !== null) {
handler(true);
}
});
e.addEventListener('mouseout', function(evt) {
if (e.contains(evt.toElement || evt.relatedTarget)) return;
overCount = 0;
props.hover(false);
e.elm_hover_count = 0;
var handler = e.elm_hover_handler;
if (handler !== null) {
handler(false);
}
});
}
if (props.click.ctor !== '_Tuple0') {
e.style.pointerEvents = 'auto';
e.elm_click_handler = props.click;
e.addEventListener('click', function() {
e.elm_click_handler(Tuple0);
});
}
return e;
@ -99,6 +120,8 @@ function goDown(e) { return e }
function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
function flowWith(f, array) {
var container = newElement('div');
if (f == goIn) container.style.pointerEvents = 'none';
for (var i = array.length; i--; ) {
container.appendChild(f(render(array[i])));
}
@ -126,7 +149,12 @@ function toPos(pos) {
// must clear right, left, top, bottom, and transform
// before calling this function
function setPos(pos,w,h,e) {
function setPos(pos,elem,e) {
var element = elem.element;
var props = elem.props;
var w = props.width + (element.adjustWidth ? element.adjustWidth : 0);
var h = props.height + (element.adjustHeight ? element.adjustHeight : 0);
e.style.position = 'absolute';
e.style.margin = 'auto';
var transform = '';
@ -146,7 +174,7 @@ function setPos(pos,w,h,e) {
function container(pos,elem) {
var e = render(elem);
setPos(pos, elem.props.width, elem.props.height, e);
setPos(pos, elem, e);
var div = newElement('div');
div.style.position = 'relative';
div.style.overflow = 'hidden';
@ -183,7 +211,7 @@ function rawHtml(elem) {
return div;
}
function render(elem) { return setProps(elem.props, makeElement(elem)); }
function render(elem) { return setProps(elem, makeElement(elem)); }
function makeElement(e) {
var elem = e.element;
switch(elem.ctor) {
@ -209,7 +237,9 @@ function update(node, curr, next) {
case "RawHtml":
// only markdown blocks have guids, so this must be a text block
if (nextE.guid === null) {
node.innerHTML = nextE.html;
if(currE.html.valueOf() !== nextE.html.valueOf()) {
node.innerHTML = nextE.html;
}
break;
}
if (nextE.guid !== currE.guid) {
@ -275,7 +305,7 @@ function update(node, curr, next) {
break;
case "Container":
update(node.firstChild, currE._1, nextE._1);
setPos(nextE._0, nextE._1.props.width, nextE._1.props.height, node.firstChild);
setPos(nextE._0, nextE._1, node.firstChild);
break;
case "Custom":
if (currE.type === nextE.type) {
@ -289,10 +319,19 @@ function update(node, curr, next) {
}
function updateProps(node, curr, next) {
var props = next.props, currP = curr.props, e = node;
if (props.width !== currP.width) e.style.width = (props.width |0) + 'px';
if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';
if (props.opacity !== 1 && props.opacity !== currP.opacity) {
var props = next.props;
var currP = curr.props;
var e = node;
var element = next.element;
var width = props.width - (element.adjustWidth || 0);
var height = props.height - (element.adjustHeight || 0);
if (width !== currP.width) {
e.style.width = (width|0) + 'px';
}
if (height !== currP.height) {
e.style.height = (height|0) + 'px';
}
if (props.opacity !== currP.opacity) {
e.style.opacity = props.opacity;
}
var nextColor = (props.color.ctor === 'Just' ?
@ -317,6 +356,20 @@ function updateProps(node, curr, next) {
node.lastNode.href = props.href;
}
}
// update hover handlers
if (props.hover.ctor !== '_Tuple0') {
e.elm_hover_handler = props.hover;
} else if (e.elm_hover_handler) {
e.elm_hover_handler = null;
}
// update click handlers
if (props.click.ctor !== '_Tuple0') {
e.elm_click_handler = props.click;
} else if (e.elm_click_handler) {
e.elm_click_handler = null;
}
}
return { render:render, update:update };

2
server/elm-server.cabal
View file

@ -10,7 +10,7 @@ License-file: LICENSE
Author: Evan Czaplicki
Maintainer: info@elm-lang.org
Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
Category: Compiler, Language

33
tests/Tests/Property.hs
View file

@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)
import Text.PrettyPrint as P
import SourceSyntax.Literal as Lit
import SourceSyntax.Pattern as Pat
import qualified SourceSyntax.Pattern as P
import SourceSyntax.PrettyPrint (Pretty, pretty)
import Parse.Helpers (IParser, iParse)
import Parse.Literal (literal)
@ -31,24 +31,25 @@ propertyTests =
where
-- This test was autogenerated from the Pattern test and should be
-- left in all its ugly glory.
longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
, Pat.PRecord [
"q7yclkcm7k_ikstrczv_"
, "wQRv6gKsvvkjw4b5F"
,"c9'eFfhk9FTvsMnwF_D"
,"yqxhEkHvRFwZ"
,"o"
,"nbUlCn3y3NnkVoxhW"
,"iJ0MNy3KZ_lrs"
,"ug"
,"sHHsX"
,"mRKs9d"
,"o2KiCX5'ZRzHJfRi8" ]
, Pat.PVar "su'BrrbPUK6I33Eq" ]
longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
, P.Record
[ "q7yclkcm7k_ikstrczv_"
, "wQRv6gKsvvkjw4b5F"
,"c9'eFfhk9FTvsMnwF_D"
,"yqxhEkHvRFwZ"
,"o"
,"nbUlCn3y3NnkVoxhW"
,"iJ0MNy3KZ_lrs"
,"ug"
,"sHHsX"
,"mRKs9d"
,"o2KiCX5'ZRzHJfRi8" ]
, P.Var "su'BrrbPUK6I33Eq"
]
prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
prop_parse_print p x =
either (const False) (== x) . parse_print p $ x
parse_print :: (Pretty a) => IParser a -> a -> Either String a
parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty

159
tests/Tests/Property/Arbitrary.hs
View file

@ -8,98 +8,112 @@ import Test.QuickCheck.Gen
import qualified Data.Set as Set
import qualified Parse.Helpers (reserveds)
import SourceSyntax.Literal
import SourceSyntax.Pattern
import SourceSyntax.Type hiding (listOf)
import qualified SourceSyntax.Literal as L
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as T
instance Arbitrary Literal where
arbitrary = oneof [ IntNum <$> arbitrary
, FloatNum <$> (arbitrary `suchThat` noE)
, Chr <$> arbitrary
-- This is too permissive
, Str <$> arbitrary
-- Booleans aren't actually source syntax
-- , Boolean <$> arbitrary
]
shrink l = case l of
IntNum n -> IntNum <$> shrink n
FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
Chr c -> Chr <$> shrink c
Str s -> Str <$> shrink s
Boolean b -> Boolean <$> shrink b
instance Arbitrary L.Literal where
arbitrary =
oneof
[ L.IntNum <$> arbitrary
, L.FloatNum <$> (arbitrary `suchThat` noE)
, L.Chr <$> arbitrary
-- This is too permissive
, L.Str <$> arbitrary
-- Booleans aren't actually source syntax
-- , Boolean <$> arbitrary
]
shrink lit =
case lit of
L.IntNum n -> L.IntNum <$> shrink n
L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
L.Chr c -> L.Chr <$> shrink c
L.Str s -> L.Str <$> shrink s
L.Boolean b -> L.Boolean <$> shrink b
noE :: Double -> Bool
noE = notElem 'e' . show
genVector :: Int -> (Int -> Gen a) -> Gen [a]
genVector n generator = do
len <- choose (0,n)
let m = n `div` (len + 1)
vectorOf len $ generator m
instance Arbitrary Pattern where
instance Arbitrary P.Pattern where
arbitrary = sized pat
where pat :: Int -> Gen Pattern
pat n = oneof [ pure PAnything
, PVar <$> lowVar
, PRecord <$> (listOf1 lowVar)
, PLiteral <$> arbitrary
, PAlias <$> lowVar <*> pat (n-1)
, PData <$> capVar <*> sizedPats
]
where sizedPats = do
len <- choose (0,n)
let m = n `div` (len + 1)
vectorOf len $ pat m
where
pat :: Int -> Gen P.Pattern
pat n =
oneof
[ pure P.Anything
, P.Var <$> lowVar
, P.Record <$> (listOf1 lowVar)
, P.Literal <$> arbitrary
, P.Alias <$> lowVar <*> pat (n-1)
, P.Data <$> capVar <*> genVector n pat
]
shrink pat = case pat of
PAnything -> []
PVar v -> PVar <$> shrinkWHead v
PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
PLiteral l -> PLiteral <$> shrink l
PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
shrink pat =
case pat of
P.Anything -> []
P.Var v -> P.Var <$> shrinkWHead v
P.Literal l -> P.Literal <$> shrink l
P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)
P.Record fs ->
P.Record <$> filter (all notNull) (filter notNull (shrink fs))
where
notNull = not . null
shrinkWHead :: Arbitrary a => [a] -> [[a]]
shrinkWHead [] = error "Should be nonempty"
shrinkWHead (x:xs) = (x:) <$> shrink xs
instance Arbitrary Type where
instance Arbitrary T.Type where
arbitrary = sized tipe
where tipe :: Int -> Gen Type
tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
, Var <$> lowVar
, Data <$> capVar <*> depthTipes
, Record <$> fields <*> pure Nothing
, Record <$> fields1 <*> (Just <$> lowVar)
]
where depthTipe = choose (0,n) >>= tipe
depthTipes = do
len <- choose (0,n)
let m = n `div` (len + 1)
vectorOf len $ tipe m
where
tipe :: Int -> Gen T.Type
tipe n =
let depthTipe = tipe =<< choose (0,n)
field = (,) <$> lowVar <*> depthTipe
fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
fields1 = (:) <$> field <*> fields
in
oneof
[ T.Lambda <$> depthTipe <*> depthTipe
, T.Var <$> lowVar
, T.Data <$> capVar <*> genVector n tipe
, T.Record <$> fields <*> pure Nothing
, T.Record <$> fields1 <*> (Just <$> lowVar)
]
field = (,) <$> lowVar <*> depthTipe
fields = do
len <- choose (0,n)
let m = n `div` (len + 1)
vectorOf len $ (,) <$> lowVar <*> tipe m
fields1 = (:) <$> field <*> fields
shrink tipe =
case tipe of
T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
T.Var _ -> []
T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
T.Record fs t -> map snd fs ++ record
where
record =
case t of
Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
Just _ ->
do fields <- filter (not . null) $ shrinkList shrinkField fs
return $ T.Record fields t
shrink tipe = case tipe of
Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
Var _ -> []
Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
Record fs t -> map snd fs ++ case t of
Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
Just _ ->
do
fields <- filter (not . null) $ shrinkList shrinkField fs
return $ Record fields t
where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
lowVar :: Gen String
lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
where lower = elements ['a'..'z']
where
lower = elements ['a'..'z']
capVar :: Gen String
capVar = notReserved $ (:) <$> upper <*> listOf varLetter
where upper = elements ['A'..'Z']
where
upper = elements ['A'..'Z']
varLetter :: Gen Char
varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds
exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
exceptFor g xs = g `suchThat` notAnX
where notAnX = flip Set.notMember xset
xset = Set.fromList xs
where
notAnX = flip Set.notMember xset
xset = Set.fromList xs