Merge branch 'dev'

Elm.cabal

@@ -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-html >= 0.5 && < 0.8,
-                       blaze-markup == 0.5.1.*,
+                       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,

Setup.hs

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

changelog.md

@@ -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)
+  * Ports, a new FFI that is more general and much nicer to use
-  * sortBy, sortWith (thanks to Max Goldstein)
+  * 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)

compiler/Build/Dependencies.hs

@@ -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
+         Left err -> failure err
-             where msg = "\nYou may need to create a " ++
-                         Path.dependencyFile ++
-                         " file if you\nare trying to use a 3rd party library."
 
 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 =
+readAllDeps srcDirs rawBuiltIns filePath =
-  do let ifaces = (Set.fromList . Map.keys) builtIns
+    State.evalStateT (go Nothing filePath) Set.empty
-     State.evalStateT (go ifaces root) Set.empty
   where
-    go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
+    builtIns :: Set.Set String
-    go builtIns root = do
+    builtIns = Set.fromList $ Map.keys rawBuiltIns
-      root'        <- lift $ findSrcFile srcDirs root
+
-      (name, deps) <- lift $ readDeps root'
+    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))
+      State.put (Set.insert moduleName (Set.union newDeps seen))
-      rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
+      rest <- mapM (go (Just moduleName) . toFilePath) (Set.toList newDeps)
-      return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
+      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 :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
-findSrcFile dirs path = foldr tryDir notFound dirs
+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
 

compiler/Build/Source.hs

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

compiler/Build/Utils.hs

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

compiler/Docs.hs

@@ -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 qualified SourceSyntax.Helpers as Help
-import SourceSyntax.Type (Type(..))
+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
+instance ToJSON T.Type where
-    toJSON tipe =
+  toJSON tipe =
-        case tipe of
+    object $
-          Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
+    case tipe of
-          Var x -> toJSON x
+      T.Lambda _ _ ->
-          Data name ts -> toJSON (toJSON name : map toJSON ts)
+          let tipes = T.collectLambdas tipe in
-          Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
+          [ "tag" .= ("function" :: Text.Text)
-              where fields' = case ext of
+          , "args" .= toJSON (init tipes)
-                                Nothing -> fields
+          , "result" .= toJSON (last tipes)
-                                Just x -> ("_", Var x) : fields
+          ]
 
+      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 ]

compiler/Elm/Internal/Paths.hs

@@ -1,7 +1,8 @@
+{-# OPTIONS_GHC -Wall #-}
 module Elm.Internal.Paths where
 
-import System.IO.Unsafe
+import Build.Utils (getDataFile)
-import qualified Paths_Elm as This
+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"

compiler/Generate/Cases.hs

@@ -6,14 +6,15 @@ import Control.Monad.State
 import Data.List (groupBy,sortBy)
 import Data.Maybe (fromMaybe)
 
-import SourceSyntax.Location
+import SourceSyntax.Annotation 
-import SourceSyntax.Literal
-import SourceSyntax.Pattern
 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)) =
+matchSubst pairs (Other (A a e)) =
-    Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
+    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
+    P.Data _ _  -> True
-    PLiteral _ -> True
+    P.Literal _ -> True
-    _          -> False
+    _           -> 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
+              P.Var x     -> subst x (rawVar v) e
-              PAnything  -> e
+              P.Anything  -> e
-              PRecord fs ->
+              P.Record fs ->
-                 foldr (\x -> subst x (Access (L s (Var v)) x)) e 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
+          (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
-          (PLiteral lit : _, _) -> matchClause (Right lit) (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)
+            P.Data _ ps' -> (ps' ++ ps, e)
-            PLiteral _  -> (ps, e)
+            P.Literal _  -> (ps, e)
 
       getVars =
           case head cs of
-            (PData _ ps : _, _) -> forM ps (const newVar)
+            (P.Data _ ps : _, _) -> forM ps (const newVar)
-            (PLiteral _ : _, _) -> return []
+            (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
+    where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

compiler/Generate/JavaScript.hs

@@ -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 qualified SourceSyntax.Pattern as P
-import Language.ECMAScript3.PrettyPrint
+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 :: Expr -> State Int (Expression ())
-expression (L span expr) =
+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'
+             (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
-             (L _ (Literal (Boolean True)), _) -> safeIfs branches'
+             (A _ (Literal (Boolean True)), _) -> safeIfs branches'
-             _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
+             _ -> 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, [])
+                   A _ (Var (V.Raw x)) ->
-                   _ -> do e' <- expression e
+                       return (Case.matchSubst [(tempVar,x)] initialMatch, [])
-                           return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
+                   _ ->
-             match' <- match span revisedMatch
+                       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
+          vars = P.boundVarList pattern
-          mkVar = L span . Var
+          mkVar = A region . rawVar
-          toDef y = let expr =  L span $ Case (mkVar "$") [(pattern, mkVar y)]
+          toDef y = let expr =  A region $ Case (mkVar "$") [(pattern, mkVar y)]
-                    in  definition $ Definition (PVar y) expr Nothing
+                    in  definition $ Definition (P.Var y) expr Nothing
 
-match :: SrcSpan -> Case.Match -> State Int [Statement ()]
+match :: Region -> Case.Match -> State Int [Statement ()]
-match span mtch =
+match region mtch =
   case mtch of
     Case.Match name clauses mtch' ->
-        do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
+        do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
-           mtch'' <- match span mtch'
+           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 :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
-clause span variable (Case.Clause value vars mtch) =
+clause region variable (Case.Clause value vars mtch) =
-    (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars 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 :: [Def] -> Expr -> ([Def], Expr)
-flattenLets defs lexpr@(L _ 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 :: Region -> String -> Expr -> Expr -> State Int (Expression ())
-binop span op e1 e2 =
+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)

compiler/Generate/JavaScript/Ports.hs

@@ -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 ->
+      Data ctor ts
-          ArrayLit () $ zipWith convert [0..] ts
+          | Help.isTuple ctor ->
-          where
+              let convert n t = out t $ DotRef () x $ var ('_':show n)
-            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

compiler/Generate/Noscript.hs

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

compiler/Metadata/Prelude.hs

@@ -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")
+    string = map ((,) "String") [ As "String", Importing ["show"] ]
-    modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
+    modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"
-              , "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]
+              , "Graphics.Element", "Graphics.Collage", "Native.Ports" ]
 
 interfaces :: Bool -> IO Interfaces
 interfaces noPrelude =
     if noPrelude
-    then return $ Map.empty
+    then return Map.empty
-    else safeReadDocs =<< Path.getDataFileName "interfaces.data"
+    else safeReadDocs =<< getDataFile "interfaces.data"
 
 safeReadDocs :: FilePath -> IO Interfaces
 safeReadDocs name =

compiler/Parse/Binop.hs

@@ -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
+binops :: IParser E.ParseExpr
-       -> IParser E.LParseExpr
+       -> 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
+      -> E.ParseExpr
-      -> [(String, E.LParseExpr)]
+      -> [(String, E.ParseExpr)]
-      -> IParser E.LParseExpr
+      -> 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)]
+splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
-           -> [IParser E.LParseExpr]
+           -> [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." ]

compiler/Parse/Expression.hs

@@ -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.Annotation as Annotation
-import SourceSyntax.Pattern hiding (tuple,list)
+import qualified SourceSyntax.Pattern as P
-import qualified SourceSyntax.Literal as Literal
+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 :: String -> ParseExpr'
-toVar v = case v of "True"  -> Literal (Literal.Boolean True)
+toVar v = case v of "True"  -> Literal (L.Boolean True)
-                    "False" -> Literal (Literal.Boolean False)
+                    "False" -> Literal (L.Boolean False)
-                    _       -> Var v
+                    _       -> 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
+  let loc e = Annotation.at start end e
-  return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
+  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
+  let loc e = Annotation.at start end e
-  return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
+  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
+      let loc = Annotation.at start end
-      return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
+      return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
-             Binop op (loc $ Var "x") (loc $ Var "y")
+             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
+    where
-              label <- rLabel
+      field = do
-              patterns <- spacePrefix Pattern.term
+        label <- rLabel
-              padded equals
+        patterns <- spacePrefix Pattern.term
-              body <- expr
+        padded equals
-              return (label, makeFunction patterns body)
+        body <- expr
+        return (label, makeFunction patterns body)
               
-          record = Record <$> commaSep field
+      record = Record <$> commaSep field
 
-          change = do
+      change = do
-              lbl <- rLabel
+        lbl <- rLabel
-              padded (string "<-")
+        padded (string "<-")
-              (,) lbl <$> expr
+        (,) lbl <$> expr
 
-          remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
+      remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
 
-          insert r = addLocation $ do
+      insert r = addLocation $ do
-                       string "|" >> whitespace
+                   string "|" >> whitespace
-                       Insert r <$> rLabel <*> (padded equals >> expr)
+                   Insert r <$> rLabel <*> (padded equals >> expr)
 
-          modify r = addLocation
+      modify r =
-                     (string "|" >> whitespace >> Modify r <$> commaSep1 change)
+          addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
 
-          misc = try $ do
+      misc = try $ do
-            record <- addLocation (Var <$> rLabel)
+               record <- addLocation (rawVar <$> rLabel)
-            opt <- padded (optionMaybe (remove record))
+               opt <- padded (optionMaybe (remove record))
-            case opt of
+               case opt of
-              Just e  -> try (insert e) <|> return e
+                 Just e  -> try (insert e) <|> return e
-              Nothing -> try (insert record) <|> try (modify record)
+                 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 ]
+        return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
-                             else [ PVar (o:p), p1, p2 ]
+                             else [ P.Var (o:p), p1, p2 ]
 
-makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
+makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
-makeFunction args body@(L s _) =
+makeFunction args body@(A ann _) =
-    foldr (\arg body' -> L s $ Lambda arg body') body args
+    foldr (\arg body' -> A ann $ Lambda arg body') body args
 
 definition :: IParser ParseDef
 definition = withPos $ do

compiler/Parse/Helpers.hs

@@ -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.Annotation as Annotation
-import SourceSyntax.Location as Location
-import SourceSyntax.Expression
-import SourceSyntax.PrettyPrint
 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))
+                       return (Annotation.at start end (f v))
-  case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
+  case e of
-                       | otherwise -> rest (Access ce)
+    Var (Variable.Raw (c:cs))
-            _ -> rest (Access ce)
+        | 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 :: ([a] -> IParser (String, [a])) -> IParser (String, [a])
-markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
+markdown interpolation = try (string "[markdown|") >> closeMarkdown (++ "") []
     where
       closeMarkdown md stuff =
           choice [ do try (string "|]")
-                      return (md, stuff)
+                      return (md "", stuff)
-                 , uncurry closeMarkdown =<< interpolation md stuff
+                 , (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff
                  , do c <- anyChar
-                      closeMarkdown (md ++ [c]) stuff
+                      closeMarkdown (md . ([c]++)) stuff
                  ]
 
 --str :: IParser String

compiler/Parse/Literal.hs

@@ -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")
+num = toLit <$> (number <?> "number")
-    where toLit n | '.' `elem` n = FloatNum (read n)
+  where
-                  | otherwise = IntNum (read n)
+    toLit n
-          preNum  = concat <$> sequence [ option "" minus, many1 digit, option "" postNum ]
+        | any (`elem` ".eE") n = FloatNum (read n)
-          postNum = do try $ lookAhead (string "." >> digit)
+        | otherwise            = IntNum (read n)    
-                       string "."
+
-                       ('.':) <$> many1 digit
+    number = concat <$> sequence
-          minus = try $ do string "-"
+             [ option "" minus
-                           lookAhead digit
+             , many1 digit
-                           return "-"
+             , 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)

compiler/Parse/Module.hs

@@ -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
+     (,) name <$> option (As name) method
-       Just _ -> return (name, Hiding [])
-       Nothing -> let how = try (whitespace >> (as' <|> importing'))
-                  in  (,) name <$> option (As name) how
   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)")

compiler/Parse/Pattern.hs

@@ -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 P
-import qualified SourceSyntax.Pattern as Pattern
 
-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)
+                    "True"          -> P.Literal (Boolean True)
-                    "False"         -> PLiteral (Boolean False)
+                    "False"         -> P.Literal (Boolean False)
-                    c:_ | isUpper c -> PData v []
+                    c:_ | isUpper c -> P.Data v []
-                    _               -> PVar v
+                    _               -> P.Var v
-    , PLiteral <$> literal
+    , 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 :: IParser P.Pattern
-record = PRecord <$> brackets (commaSep1 lowVar)
+record = P.Record <$> brackets (commaSep1 lowVar)
 
-tuple :: IParser Pattern
+tuple :: IParser P.Pattern
-tuple = do ps <- parens (commaSep expr)
+tuple = do
-           return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
+  ps <- parens (commaSep expr)
+  return $ case ps of
+             [p] -> p
+             _ -> P.tuple ps
 
-list :: IParser Pattern
+list :: IParser P.Pattern
-list = Pattern.list <$> braces (commaSep expr)
+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)
+    "True"  -> return $ P.Literal (Boolean True)
-    "False" -> return $ PLiteral (Boolean False)
+    "False" -> return $ P.Literal (Boolean False)
-    _       -> PData v <$> spacePrefix term
+    _       -> 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"

compiler/SourceSyntax/Annotation.hs

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

compiler/SourceSyntax/Declaration.hs

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

compiler/SourceSyntax/Expression.hs

@@ -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
+move through the compilation process. The type holes are used to represent:
-structural changes in the types. The only type hole right now is:
 
-  def: Parsing allows two kinds of definitions (type annotations or definitions),
+  ann: Annotations for arbitrary expressions. Allows you to add information
-       but later checks will see that they are well formed and combine them.
+       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
+    | Var var
-    | Range (LExpr' def) (LExpr' def)
+    | Range (GeneralExpr ann def var) (GeneralExpr ann def var)
-    | ExplicitList [LExpr' def]
+    | ExplicitList [GeneralExpr ann def var]
-    | Binop String (LExpr' def) (LExpr' def)
+    | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
-    | Lambda Pattern.Pattern (LExpr' def)
+    | Lambda Pattern.Pattern (GeneralExpr ann def var)
-    | App (LExpr' def) (LExpr' def)
+    | App (GeneralExpr ann def var) (GeneralExpr ann def var)
-    | MultiIf [(LExpr' def,LExpr' def)]
+    | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
-    | Let [def] (LExpr' def)
+    | Let [def] (GeneralExpr ann def var)
-    | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
+    | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
-    | Data String [LExpr' def]
+    | Data String [GeneralExpr ann def var]
-    | Access (LExpr' def) String
+    | Access (GeneralExpr ann def var) String
-    | Remove (LExpr' def) String
+    | Remove (GeneralExpr ann def var) String
-    | Insert (LExpr' def) String (LExpr' def)
+    | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
-    | Modify (LExpr' def) [(String, LExpr' def)]
+    | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
-    | Record [(String, LExpr' def)]
+    | Record [(String, GeneralExpr ann def var)]
-    | Markdown String String [LExpr' def]
+    | 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 ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
-type LParseExpr = LExpr' ParseDef
+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 = GeneralExpr Annotation.Region Def Variable.Raw
-type Expr = Expr' Def
+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 :: GeneralExpr ann def var -> [GeneralExpr ann def var]
-delist (Location.L _ (Data "::" [h,t])) = h : delist t
+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
+instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
-  show = render . pretty
-
-instance Pretty def => Pretty (Expr' def) 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))
+         where
-     MultiIf branches ->  P.text "if" $$ nest 3 (vcat $ map iff branches)
+           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 :: GeneralExpr ann def var -> [GeneralExpr ann def var]
-collectApps lexpr@(Location.L _ expr) =
+collectApps annExpr@(Annotation.A _ expr) =
   case expr of
     App a b -> collectApps a ++ [b]
-    _ -> [lexpr]
+    _ -> [annExpr]
 
-collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
+collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
-collectLambdas lexpr@(Location.L _ expr) =
+collectLambdas lexpr@(Annotation.A _ expr) =
   case expr of
-    Lambda pattern body -> (pattern : ps, body')
+    Lambda pattern body ->
-        where (ps, body') = collectLambdas body
+        let (ps, body') = collectLambdas body
+        in  (pattern : ps, body')
+
     _ -> ([], lexpr)
 
-prettyParens :: (Pretty def) => LExpr' def -> Doc
+prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
-prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
+prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
   where
     needed =
       case expr of

compiler/SourceSyntax/Helpers.hs

@@ -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 ++ " }"
 

compiler/SourceSyntax/Location.hs

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

compiler/SourceSyntax/Module.hs

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

compiler/SourceSyntax/Pattern.hs

@@ -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]
+data Pattern
-             | PRecord [String]
+    = Data String [Pattern]
-             | PAlias String Pattern
+    | Record [String]
-             | PVar String
+    | Alias String Pattern
-             | PAnything
+    | Var String
-             | PLiteral Literal.Literal
+    | Anything
-               deriving (Eq, Ord, Show)
+    | 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
+      Var x -> Set.singleton x
-      PAlias x p -> Set.insert x (boundVars p)
+      Alias x p -> Set.insert x (boundVars p)
-      PData _ ps -> Set.unions (map boundVars ps)
+      Data _ ps -> Set.unions (map boundVars ps)
-      PRecord fields -> Set.fromList fields
+      Record fields -> Set.fromList fields
-      PAnything -> Set.empty
+      Anything -> Set.empty
-      PLiteral _ -> Set.empty
+      Literal _ -> Set.empty
 
 
 instance Pretty Pattern where
   pretty pattern =
    case pattern of
-     PVar x -> variable x
+     Var x -> variable x
-     PLiteral lit -> pretty lit
+     Literal lit -> pretty lit
-     PRecord fs -> PP.braces (commaCat $ map variable fs)
+     Record fs -> PP.braces (commaCat $ map variable fs)
-     PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
+     Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
-     PAnything -> PP.text "_"
+     Anything -> PP.text "_"
-     PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
+     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
+        Data name (_:_) | not (Help.isTuple name) -> True
-        PAlias _ _ -> True
+        Alias _ _ -> True
         _ -> False

compiler/SourceSyntax/PrettyPrint.hs

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

compiler/SourceSyntax/Type.hs

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

compiler/SourceSyntax/Variable.hs

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

compiler/Transform/Canonicalize.hs

@@ -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.Traversable as T
-import qualified Data.Either as Either
+import SourceSyntax.Annotation as A
-import SourceSyntax.Module
 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
+-- TODO: Var.Raw -> Var.Canonical
-rename env (L s expr) =
+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.Var _ -> return pattern
-      P.PLiteral _ -> return pattern
+      P.Literal _ -> return pattern
-      P.PRecord _ -> return pattern
+      P.Record _ -> return pattern
-      P.PAnything -> return pattern
+      P.Anything -> return pattern
-      P.PAlias x p -> P.PAlias x <$> renamePattern env p
+      P.Alias x p -> P.Alias x <$> renamePattern env p
-      P.PData name ps -> P.PData <$> replace "pattern" env name
+      P.Data name ps -> P.Data <$> replace "pattern" env name
-                                 <*> mapM (renamePattern env) ps
+                               <*> mapM (renamePattern env) ps

compiler/Transform/Check.hs

@@ -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.Expr -> Either String E.Expr
-
-    exprDups :: E.LExpr -> Either String E.LExpr
     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
 

compiler/Transform/Declaration.hs

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

compiler/Transform/Definition.hs

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

compiler/Transform/Expression.hs

@@ -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 SourceSyntax.Type (Type)
-import qualified SourceSyntax.Type as ST
 
-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 ())
+checkPorts :: (String -> Type -> Either a ())
-           -> (String -> ST.Type -> Either a ())
+           -> (String -> Type -> Either a ())
-           -> LExpr
+           -> Expr
-           -> Either a LExpr
+           -> 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 ())
+crawl :: (String -> Type -> Either a ())
-      -> (String -> ST.Type -> Either a ())
+      -> (String -> Type -> Either a ())
       -> ([def] -> Either a [def'])
-      -> LExpr' def
+      -> GeneralExpr ann def var
-      -> Either a (LExpr' def')
+      -> Either a (GeneralExpr ann def' var)
 crawl portInCheck portOutCheck defsTransform = go
     where
-      go (L srcSpan expr) =
+      go (A srcSpan expr) =
-          L srcSpan <$>
+          A srcSpan <$>
           case expr of
             Var x -> return (Var x)
             Lambda p e -> Lambda p <$> go e

compiler/Transform/SafeNames.hs

@@ -2,38 +2,43 @@
 module Transform.SafeNames (metadataModule) where
 
 import Control.Arrow (first, (***))
-import SourceSyntax.Expression
+import qualified Data.List as List
-import SourceSyntax.Location
-import SourceSyntax.Module
-import SourceSyntax.Pattern
 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)
+      P.Var x -> P.Var (var x)
-      PLiteral _ -> pat
+      P.Literal _ -> pat
-      PRecord fs -> PRecord (map var fs)
+      P.Record fs -> P.Record (map var fs)
-      PAnything -> pat
+      P.Anything -> pat
-      PAlias x p -> PAlias (var x) (pattern p)
+      P.Alias x p -> P.Alias (var x) (pattern p)
-      PData name ps -> PData name (map pattern ps)
+      P.Data name ps -> P.Data name (map pattern ps)
 
-expression :: LExpr -> LExpr
+-- TODO: should be "normal expression" -> "expression for JS generation"
-expression (L loc expr) =
+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)

compiler/Transform/SortDefinitions.hs

@@ -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.Var _ -> []
-      P.PAlias _ p -> ctors p
+      P.Alias _ p -> ctors p
-      P.PData ctor ps -> ctor : concatMap ctors ps
+      P.Data ctor ps -> ctor : concatMap ctors ps
-      P.PRecord _ -> []
+      P.Record _ -> []
-      P.PAnything -> []
+      P.Anything -> []
-      P.PLiteral _ -> []
+      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 :: Expr -> State (Set.Set String) Expr
-reorder (L s expr) =
+reorder (A ann expr) =
-    L s <$>
+    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)

compiler/Transform/Substitute.hs

@@ -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
@@ -39,4 +41,4 @@ subst old new expr =
       Literal _ -> expr
       Markdown uid md es -> Markdown uid md (map f es)
       PortIn name st -> PortIn name st
-      PortOut name st signal -> PortOut name st (f signal)
+      PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Constrain/Declaration.hs

@@ -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
+                   Nothing -> A.none $ E.Record efields
-                   Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) 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 ->
+          D.Out name expr@(A.A s _) tipe ->
-              [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
+              [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
-          In name tipe ->
+          D.In name tipe ->
-              [ definition name (L.none $ E.PortIn name tipe) 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 :: E.Expr -> [String] -> E.Expr
-buildFunction body@(L.L s _) vars =
+buildFunction body@(A.A s _) vars =
-    foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar 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 :: String -> E.Expr -> T.Type -> E.Def
-definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
+definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)

compiler/Type/Constrain/Expression.hs

@@ -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.Annotation as Ann
-import SourceSyntax.Pattern (Pattern(PVar), boundVars)
 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.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
-constrain env (L span expr) tipe =
+constrain env (A region expr) tipe =
     let list t = Env.get env Env.types "_List" <| t
-        and = L span . CAnd
+        and = A region . CAnd
-        true = L span CTrue
+        true = A region CTrue
-        t1 === t2 = L span (CEqual t1 t2)
+        t1 === t2 = A region (CEqual t1 t2)
-        x <? t = L span (CInstance x t)
+        x <? t = A region (CInstance x t)
-        clet schemes c = L span (CLet schemes c)
+        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)
+      Var (V.Raw name)
-               | otherwise           -> return (name <? tipe)
+          | name == saveEnvName -> return (A region CSaveEnv)
+          | otherwise           -> return (name <? tipe)
 
       Range lo hi ->
-          exists $ \x -> do
+          existsNumber $ \n -> do
-            clo <- constrain env lo x
+            clo <- constrain env lo n
-            chi <- constrain env hi x
+            chi <- constrain env hi n
-            return $ and [clo, chi, list x === tipe]
+            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]
+      P.Var _ -> [def]
-      _ -> Definition (PVar x) lexpr maybeType : map toDef vars
+      _ -> 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
+            mkVar = A r . rawVar
-            toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
+            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 :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
-try span computation = do
+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

compiler/Type/Constrain/Literal.hs

@@ -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 :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
-constrain env span literal tipe =
+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)
 

compiler/Type/Constrain/Pattern.hs

@@ -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 qualified SourceSyntax.Annotation as A
-import SourceSyntax.Location
+import qualified SourceSyntax.Pattern as P
-import SourceSyntax.PrettyPrint
+import SourceSyntax.PrettyPrint (pretty)
-import Text.PrettyPrint (render)
-import qualified SourceSyntax.Location as Loc
 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)
+    let region = A.None (pretty pattern)
-        t1 === t2 = Loc.L span (CEqual t1 t2)
+        t1 === t2 = A.A region (CEqual t1 t2)
-        x <? t = Loc.L span (CInstance x t)
+        x <? t = A.A region (CInstance x t)
     in
     case pattern of
-      PAnything -> return emptyFragment
+      P.Anything -> return emptyFragment
 
-      PLiteral lit -> do
+      P.Literal lit -> do
-          c <- liftIO $ Literal.constrain env span lit tipe
+          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,8 +72,8 @@ 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
-              , PP.text str ]
+              , PP.text str ]

compiler/Type/ExtraChecks.hs

@@ -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 :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
-mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
+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 =
+    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
+                  TT.App1 a b -> (++) <$> go a <*> go b
-                  Fun1 a b -> (++) <$> go a <*> go b
+                  TT.Fun1 a b -> (++) <$> go a <*> go b
-                  Var1 a   -> go a
+                  TT.Var1 a   -> go a
-                  EmptyRecord1 -> return []
+                  TT.EmptyRecord1 -> return []
-                  Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
+                  TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

compiler/Type/Fragment.hs

@@ -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 {
+data Fragment = Fragment
-    typeEnv        :: Map.Map String Type,
+    { typeEnv        :: Map.Map String Type
-    vars           :: [Variable],
+    , vars           :: [Variable]
-    typeConstraint :: TypeConstraint
+    , typeConstraint :: TypeConstraint
-} deriving Show
+    } deriving Show
 
 emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
 
-joinFragment f1 f2 = Fragment {
+joinFragment f1 f2 = Fragment
-    typeEnv = Map.union (typeEnv f1) (typeEnv f2),
+    { typeEnv        = Map.union (typeEnv f1) (typeEnv f2)
-    vars    = vars f1 ++ vars f2,
+    , vars           = vars f1 ++ vars f2
-    typeConstraint = typeConstraint f1 /\ typeConstraint f2
+    , typeConstraint = typeConstraint f1 /\ typeConstraint f2
-}
+    }
 
 joinFragments = List.foldl' (flip joinFragment) emptyFragment
 
-
 toScheme fragment =
-    Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
+    Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

compiler/Type/Inference.hs

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

compiler/Type/Solve.hs

@@ -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 :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
-solveScheme span scheme =
+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 :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
-allDistinct span vars = do
+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 :: A.Region -> Variable -> StateT TS.SolverState IO ()
-isGeneric span var = do
+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

compiler/Type/State.hs

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

compiler/Type/Type.hs

@@ -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
+instance PrettyType t => PrettyType (Annotated a t) where
-  pretty when (L _ e) = pretty when e
+  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
+instance Crawl e => Crawl (Annotated a e) where
-  crawl nextState (L s e) = L s <$> crawl nextState e
+  crawl nextState (A ann e) = A ann <$> crawl nextState e
 
 instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
   crawl nextState constraint = 

compiler/Type/Unify.hs

@@ -1,27 +1,27 @@
 {-# OPTIONS_GHC -W #-}
 module Type.Unify (unify) where
 
-import Type.Type
+import Control.Monad.State
-import qualified Data.UnionFind.IO as UF
 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 Type.Type
-import SourceSyntax.Location
 import Type.PrettyPrint
 import Text.PrettyPrint (render)
 
-unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
+unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
-unify span variable1 variable2 = do
+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 :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
-actuallyUnify span variable1 variable2 = do
+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
 

libraries/Automaton.elm.hidden

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

libraries/AutomatonV2.elm.hidden

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

libraries/Basics.elm

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

libraries/Date.elm

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

libraries/Debug.elm

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

libraries/Dict.elm

@@ -31,11 +31,10 @@ Insert, remove, and query operations all take *O(log n)* time.
 -}
 
 
-import open Basics
+import Basics (..)
-import open Maybe
+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",

libraries/Either.elm

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

libraries/Graphics/Collage.elm

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

libraries/Graphics/Element.elm

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

libraries/Graphics/Input.elm

@@ -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
+text fields. All functions in this library follow a general pattern in which
-events from the user.
+you create an `Input` that many elements can report to:
 
-The simplest inputs are *one-way inputs*, meaning the user can update
+```haskell
-them, but the programmer cannot. If you need to update an input from
+clicks : Input ()
-within the program you want the slightly more complex *two-way inputs*.
+clicks = input ()
-This document will always show the one-way inputs first, *then* the
-two-way inputs.
 
-# Buttons
+clickableYogi : Element
-@docs button, customButton, buttons, customButtons
+clickableYogi = clickable clicks.handle () (image 40 40 "/yogi.jpg")
+```
 
-# Fields
+Whenever the user clicks on the resulting `clickableYogi` element, it sends an
-@docs field, password, email, fields, FieldState, emptyFieldState
+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
+# Creating Inputs
-@docs checkbox, checkboxes
+@docs Input, input
 
-# Drop Downs
+# Basic Input Elements
-@docs stringDropDown, dropDown
+
+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)
-import Signal (Signal,lift,dropRepeats)
-import Native.Graphics.Input
-import List
 import Graphics.Element (Element)
-import Maybe (Maybe)
+import Native.Graphics.Input
-import JavaScript (JSString)
 
-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` — all values coming to this input from “the world”
+  2. `handle` — a way to refer to this particular input and send it values
 
- * The first argument is the default value of the `events` signal.
+This will make more sense as you see more examples.
- * The `events` signal represents all of the activity in this group
-   of buttons.
- * The `button` function creates a button
-   with the given name, like “Submit” or “Cancel”.
-   The `a` value is sent to `events` whenever the button is pressed.
 -}
-buttons : a -> { events : Signal a,
+type Input a = { signal : Signal a, handle : Handle a }
-                 button : a -> String -> Element }
-buttons = Native.Graphics.Input.buttons
 
-{-| Create a button with a given label. The result is an `Element` and
+data Handle a = Handle
-a signal of units. This signal triggers whenever the button is pressed.
+
+{-| This creates a new `Input`. You provide a single argument that will serve
+as the initial value of the input’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 ())
+input : a -> Input a
-button txt =
+input = Native.Graphics.Input.input
-    let pool = buttons ()
-    in  (pool.button () txt, pool.events)
 
-{-| 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.
+      data Keys = Number Int | Plus | Minus | Clear
- * The `events` signal represents all of the activity in this group
+
-   of custom buttons.
+      keys : Input Keys
- * The `customButton` function creates a button with three different visual
+      keys = input Clear
-   states, one for up, hovering, and down. The resulting button has dimensions
+
-   large enough to fit all three possible `Elements`.
+      calculator : Element
-   The `a` value is sent to `events` whenever the button is pressed.
+      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,
+button : Handle a -> a -> String -> Element
-                       customButton : a -> Element -> Element -> Element -> Element }
+button = Native.Graphics.Input.button
-customButtons = Native.Graphics.Input.customButtons
 
-{-| Create a button with custom states for up, hovering, and down
+{-| Same as `button` but lets you customize buttons to look however you want.
-(given in that order). The result is an `Element` and  a signal of
+
-units. This signal triggers whenever the button is pressed.
+      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 : Handle a -> a -> Element -> Element -> Element -> Element
-customButton up hover down =
+customButton = Native.Graphics.Input.customButton
-    let pool = customButtons ()
-    in  (pool.customButton () up hover down, pool.events)
 
-{-| 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.
+      check : Input Bool
- * The `events` signal represents all of the activity in this group
+      check = input False
-   of checkboxes.
+
- * The `checkbox` function creates a
+      boxes : Bool -> Element
-   checkbox with a given state. The `(Bool -> a)` function is used
+      boxes checked =
-   when the checkbox is modified. It takes the new state and turns
+          let box = container 40 40 middle (checkbox check.handle id checked)
-   it into a value that can be sent to `events`. For example, this
+          in  flow right [ box, box, box ]
-   lets you add an ID to distinguish between checkboxes.
+
+      main : Signal Element
+      main = boxes <~ check.signal
 -}
-checkboxes : a -> { events : Signal a,
+checkbox : Handle a -> (Bool -> a) -> Bool -> Element
-                    checkbox : (Bool -> a) -> Bool -> Element }
+checkbox = Native.Graphics.Input.checkbox
-checkboxes = Native.Graphics.Input.checkboxes
 
-{-| Create a checkbox with a given start state. Unlike `button`, this
+{-| Create a drop-down menu.  The following drop-down lets you choose your
-result is a *signal* of elements. That is because a checkbox has state
+favorite British sport:
-that updates based on user input. The boolean signal represents the
+
-current state of the checkbox.
+      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)
+dropDown : Handle a -> [(String,a)] -> Element
-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 = Native.Graphics.Input.dropDown
 
-{-| Create a drop-down menu for selecting strings. The resulting
+{-| Detect mouse hovers over a specific `Element`. In the following example,
-signal of strings represents the string that is currently selected.
+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)
+hoverable : Handle a -> (Bool -> a) -> Element -> Element
-stringDropDown strs =
+hoverable = Native.Graphics.Input.hoverable
-    dropDown (List.map (\s -> (s,s)) strs)
+
+{-| 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

libraries/Graphics/Input/Field.elm

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

libraries/Http.elm

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

libraries/Json.elm

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

libraries/List.elm

@@ -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])` -}

libraries/Maybe.elm

@@ -21,27 +21,45 @@ numbers).
 -}
 data Maybe a = Just a | Nothing
 
-{-| Apply a function to the contents of a `Maybe`.
+{-| Provide a default value and a function to extract the contents of a `Maybe`.
-Return default when given `Nothing`.
+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 []

libraries/Mouse.elm

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

libraries/Native/Basics.js

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

libraries/Native/Bitwise.js

@@ -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),
+        and: F2(and),
-        or : A2(or ),
+        or : F2(or ),
-        xor: A2(xor),
+        xor: F2(xor),
         complement: not,
-        shiftLeft           : A2(sll),
+        shiftLeft           : F2(sll),
-        shiftRightArithmatic: A2(sra),
+        shiftRightArithmatic: F2(sra),
-        shiftRightLogical   : A2(srl),
+        shiftRightLogical   : F2(srl),
     };
     
 };

libraries/Native/Color.js

@@ -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
     };
 
-};
+};

libraries/Native/Date.js

@@ -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()] }; }
  };
 

libraries/Native/Debug.js

@@ -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)
+    };
+    
+};

libraries/Native/Graphics/Input.js

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

libraries/Native/Regex.js

@@ -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) {
+    function split(n, re, str) {
-        return JS.toList(JS.fromString(string).split(re));
+        if (n === Infinity) {
-    }
+            return JS.toList(JS.fromString(string).split(re));
-    function splitN(n, re, str) {
+        }
         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: F3(split),
-        split: F2(split),
-        splitN: F3(splitN),
     };
-};
+};

libraries/Native/Show.js

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

libraries/Native/Signal/Http.js

@@ -1,61 +1,64 @@
 Elm.Native.Http = {};
 Elm.Native.Http.make = function(elm) {
 
-  elm.Native = elm.Native || {};
+    elm.Native = elm.Native || {};
-  elm.Native.Http = elm.Native.Http || {};
+    elm.Native.Http = elm.Native.Http || {};
-  if (elm.Native.Http.values) return elm.Native.Http.values;
+    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);
+    function registerReq(queue,responses) {
-  var List = Elm.List.make(elm);
+        return function(req) {
-  var Signal = Elm.Signal.make(elm);
+            if (req.url.length > 0) {
-
+                sendReq(queue,responses,req);
-
+            }
-  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 sendReq(queue,responses,req) {
+    function updateQueue(queue,responses) {
-    var response = { value: { ctor:'Waiting' } };
+        if (queue.length > 0) {
-    queue.push(response);
+            elm.notify(responses.id, queue[0].value);
+            if (queue[0].value.ctor !== 'Waiting') {
+                queue.shift();
+                setTimeout(function() { updateQueue(queue,responses); }, 0);
+            }
+        }
+    }
 
-    var request = null;
+    function sendReq(queue,responses,req) {
-    if (window.ActiveXObject)  { request = new ActiveXObject("Microsoft.XMLHTTP"); }
+        var response = { value: { ctor:'Waiting' } };
-    if (window.XMLHttpRequest) { request = new XMLHttpRequest(); }
+        queue.push(response);
-    request.onreadystatechange = function(e) {
+
-      if (request.readyState === 4) {
+        var request = (window.ActiveXObject
-        response.value = (request.status >= 200 && request.status < 300 ?
+                       ? new ActiveXObject("Microsoft.XMLHTTP")
-        { ctor:'Success', _0:JS.toString(request.responseText) } :
+                       : new XMLHttpRequest());
-        { ctor:'Failure', _0:request.status, _1:JS.toString(request.statusText) });
+
-        setTimeout(function() { updateQueue(queue,responses); }, 0);
+        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};
-
 };

libraries/Native/Signal/Mouse.js

@@ -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.addListener([clicks.id], node, 'click', function click() {
-        elm.notify(isClicked.id, true);
         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,8 +41,7 @@ Elm.Native.Mouse.make = function(elm) {
         position: position,
         x:x,
         y:y,
-        isClicked: isClicked,
         isDown: isDown,
         clicks: clicks
     };
-};
+};

libraries/Native/Signal/Signal.js

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

libraries/Native/String.js

@@ -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;
@@ -248,4 +249,4 @@ Elm.Native.String.make = function(elm) {
         toList: toList,
         fromList: fromList,
     };
-};
+};

libraries/Native/Text.js

@@ -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 toCss = Elm.Native.Color.make(elm).toCss;
-    var Utils = Elm.Native.Utils.make(elm);
-    var Color = Elm.Native.Color.make(elm);
     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) {
+    function typeface(names, text) {
-        return { style: 'font-family:' + name + ';', text: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) {
+    function line(line, text) {
-        return { line: ' underline', text:text };
+        return { style: 'text-decoration:' + toLine(line) + ';', text:text };
-    }
-    function overline(text) {
-        return { line: ' overline', text:text };
-    }
-    function strikeThrough(text) {
-        return { line: ' line-through', text:text };
     }
 
-    function color(c, text) {
+    function color(color, text) {
-        var color = (c._3 === 1)
+        return { style: 'color:' + toCss(color) + ';', text:text };
-            ? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
-            : ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
-        return { style: 'color:' + color + ';', text:text };
     }
 
-    function position(align) {
+    function block(align) {
-        function create(text) {
+        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,
+        line : F2(line),
-        overline : overline,
-        strikeThrough : strikeThrough,
         monospace : monospace,
         typeface : F2(typeface),
         color : F2(color),
         link : F2(link),
 
-        justified : position('justify'),
+        leftAligned  : block('left'),
-        centered : position('center'),
+        rightAligned : block('right'),
-        righted : position('right'),
+        centered     : block('center'),
-        text : text,
+        justified    : block('justify'),
-        plainText : plainText,
+        markdown     : markdown,
-        markdown : markdown,
 
-        asText : asText,
+        toTypefaces:toTypefaces,
+        toLine:toLine,
     };
 };

libraries/Native/Trampoline.js

@@ -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
+    };
+};

libraries/Native/Utils.js

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

libraries/Prelude.elm

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

libraries/Regex.elm

@@ -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
+# Helpful Data Structures
-@docs Match
 
-# Find and Replace
+These data structures are needed to help define functions like [`find`](#find)
-@docs contains, find, findAll, replace, replaceAll
+and [`replace`](#replace).
 
-# Split
+@docs HowMany, Match
-@docs split, splitN
+
+# Use
+@docs contains, find, replace, split
 
 -}
 
@@ -21,31 +22,35 @@ import Native.Regex
 
 data Regex = Regex
 
-{-| Escape all special characters. So `pattern (escape "$$$")`
+{-| Escape strings to be regular expressions, making all special characters
-will match exactly `"$$$"` even though `$` is a special character.
+safe. So `regex (escape "^a+")` will match exactly `"^a+"` instead of a series
+of `a`’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
+regex : String -> Regex
-pattern = Native.Regex.pattern
+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 (regex "123") "12345" == True
-  contains (pattern "b+") "aabbcc" == True
+  contains (regex "b+") "aabbcc" == True
 
-  contains (pattern "789") "12345" == False
+  contains (regex "789") "12345" == False
-  contains (pattern "z+") "aabbcc" == 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` — the full string of the match.
-  * `submatches` — a pattern might have [subpatterns, surrounded by
+  * `submatches` — 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`’s or
+    For example, `(regex "(a+)|(b+)")` will either match many `a`’s or
     many `b`’s, but never both.
   * `index` — the index of the match in the original string.
   * `number` — 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 (findTwoCommas "a,b,c,d,e") == [1,3]
-    map .index words == [0,6]
+    -- 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 .match places == ["on a boat", "in a lake"]
-    map .submatches places == [ [Just "boat"], [Just "lake"] ]
+    -- map .submatches places == [ [Just "boat"], [Just "lake"] ]
 ```
 -}
-findAll : Regex -> String -> [Match]
+find : HowMany -> 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 = 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
+replace : HowMany -> 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 = 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

libraries/Signal.elm

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

libraries/String.elm

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

libraries/Text.elm

@@ -1,99 +1,210 @@
 module Text where
-
+{-| A library for styling and displaying text. Whlie the `String` library
-{-| Functions for displaying text
+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
+Each of the following functions places `Text` into a box. The function you use
-@docs color, typeface, height, link
+determines the alignment of the text.
 
-# Simple Formatting
+@docs leftAligned, rightAligned, centered, justified
-@docs monospace, bold, italic, underline, overline, strikeThrough
+
+# 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 Basics (..)
-import Color (Color)
+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
+{-| Set the style of some text. For example, if you design a `Style` called
-separated listing of the desired typefaces:
+`footerStyle` that is specifically for the bottom of your page, you could apply
+it to text like this:
 
-        "helvetica, arial, sans-serif"
+      style footerStyle (toText "the old prince / 2007")
-
-Works the same as the CSS font-family property.
 -}
-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. -}
+{-| Put lines on text:
-overline : Text -> Text
-overline = Native.Text.overline
 
-{-| Underline a string. -}
+      line Under   (toText "underlined")
-underline : Text -> Text
+      line Over    (toText "overlined")
-underline = Native.Text.underline
+      line Through (toText "strike out")
+-}
+line : Line -> Text -> Text
+line = Native.Text.line
 
-{-| Draw a line through a string. -}
+{-| `Text` is aligned along the left side of the text block. This is sometimes
-strikeThrough : Text -> Text
+known as *ragged right*.
-strikeThrough = Native.Text.strikeThrough
+-}
+leftAligned : Text -> Element
+leftAligned = Native.Text.leftAligned
 
-{-| Display justified, styled text. -}
+{-| `Text` is aligned along the right side of the text block. This is sometimes
-justified : Text -> Element
+known as *ragged left*.
-justified = Native.Text.justified
+-}
+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. -}
+{-| `Text` is aligned along the left and right sides of the text block. Word
-righted : Text -> Element
+spacing is adjusted to make this possible.
-righted = Native.Text.righted
+-}
+justified : Text -> Element
+justified = Native.Text.justified
 
-{-| Display styled text. -}
+{-| Display a string with no styling:
-text : Text -> Element
-text = Native.Text.text
 
-{-| 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)))

libraries/Time.elm

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

libraries/Trampoline.elm

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

libraries/elm_dependencies.json

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

runtime/HotSwap.js

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

runtime/Init.js

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

runtime/Render/Collage.js

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

runtime/Render/Element.js

@@ -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) {
+function setProps(elem, e) {
-    e.style.width  = (props.width |0) + 'px';
+    var props = elem.props;
-    e.style.height = (props.height|0) + 'px';
+    var element = elem.element;
-    if (props.opacity !== 1) { e.style.opacity = props.opacity; }
+    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;
+            if (e.elm_hover_count++ > 0) return;
-            props.hover(true);
+            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;
+            e.elm_hover_count = 0;
-            props.hover(false);
+            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;
+    var props = next.props;
-    if (props.width !== currP.width)   e.style.width  = (props.width |0) + 'px';
+    var currP = curr.props;
-    if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';
+    var e = node;
-    if (props.opacity !== 1 && props.opacity !== currP.opacity) {
+    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 };

server/elm-server.cabal

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

tests/Tests/Property.hs

@@ -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 '+')
+    longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
-                            , Pat.PRecord [
+                         , P.Record
-                                 "q7yclkcm7k_ikstrczv_"
+                           [ "q7yclkcm7k_ikstrczv_"
-                                 , "wQRv6gKsvvkjw4b5F"
+                           , "wQRv6gKsvvkjw4b5F"
-                                 ,"c9'eFfhk9FTvsMnwF_D"
+                           ,"c9'eFfhk9FTvsMnwF_D"
-                                 ,"yqxhEkHvRFwZ"
+                           ,"yqxhEkHvRFwZ"
-                                 ,"o"
+                           ,"o"
-                                 ,"nbUlCn3y3NnkVoxhW"
+                           ,"nbUlCn3y3NnkVoxhW"
-                                 ,"iJ0MNy3KZ_lrs"
+                           ,"iJ0MNy3KZ_lrs"
-                                 ,"ug"
+                           ,"ug"
-                                 ,"sHHsX"
+                           ,"sHHsX"
-                                 ,"mRKs9d"
+                           ,"mRKs9d"
-                                 ,"o2KiCX5'ZRzHJfRi8" ]
+                           ,"o2KiCX5'ZRzHJfRi8" ]
-                            , Pat.PVar "su'BrrbPUK6I33Eq" ]
+                         , 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

tests/Tests/Property/Arbitrary.hs

@@ -8,98 +8,112 @@ import Test.QuickCheck.Gen
 import qualified Data.Set as Set
 import qualified Parse.Helpers (reserveds)
 
-import SourceSyntax.Literal
+import qualified SourceSyntax.Literal as L
-import SourceSyntax.Pattern
+import qualified SourceSyntax.Pattern as P
-import SourceSyntax.Type hiding (listOf)
+import qualified SourceSyntax.Type as T
 
-instance Arbitrary Literal where
+instance Arbitrary L.Literal where
-  arbitrary = oneof [ IntNum   <$> arbitrary
+  arbitrary =
-                    , FloatNum <$> (arbitrary `suchThat` noE)
+      oneof
-                    , Chr      <$> arbitrary
+      [ L.IntNum   <$> arbitrary
-                      -- This is too permissive
+      , L.FloatNum <$> (arbitrary `suchThat` noE)
-                    , Str      <$> arbitrary
+      , L.Chr      <$> arbitrary
-                      -- Booleans aren't actually source syntax 
+      -- This is too permissive
-                      -- , Boolean  <$> arbitrary
+      , L.Str      <$> arbitrary
-                    ]
+      -- Booleans aren't actually source syntax 
-  shrink l = case l of
+      -- , Boolean  <$> arbitrary
-    IntNum n   -> IntNum   <$> shrink n
+      ]
-    FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
+
-    Chr c      -> Chr      <$> shrink c
+  shrink lit =
-    Str s      -> Str      <$> shrink s
+    case lit of
-    Boolean b  -> Boolean  <$> shrink b
+      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
+    where
-          pat n = oneof [ pure PAnything
+      pat :: Int -> Gen P.Pattern
-                        , PVar     <$> lowVar
+      pat n =
-                        , PRecord  <$> (listOf1 lowVar)
+          oneof
-                        , PLiteral <$> arbitrary
+          [ pure P.Anything
-                        , PAlias   <$> lowVar    <*> pat (n-1)
+          , P.Var     <$> lowVar
-                        , PData    <$> capVar    <*> sizedPats
+          , P.Record  <$> (listOf1 lowVar)
-                        ]
+          , P.Literal <$> arbitrary
-            where sizedPats = do
+          , P.Alias   <$> lowVar <*> pat (n-1)
-                    len <- choose (0,n)
+          , P.Data    <$> capVar <*> genVector n pat
-                    let m = n `div` (len + 1)
+          ]
-                    vectorOf len $ pat m
 
-  shrink pat = case pat of
+  shrink pat =
-    PAnything  -> []
+    case pat of
-    PVar v     -> PVar     <$> shrinkWHead v
+      P.Anything  -> []
-    PRecord fs -> PRecord  <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
+      P.Var v     -> P.Var <$> shrinkWHead v
-    PLiteral l -> PLiteral <$> shrink l
+      P.Literal l -> P.Literal <$> shrink l
-    PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
+      P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
-    PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
+      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
+    where
-          tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
+      tipe :: Int -> Gen T.Type
-                         , Var    <$> lowVar
+      tipe n =
-                         , Data   <$> capVar <*> depthTipes
+          let depthTipe = tipe =<< choose (0,n)
-                         , Record <$> fields <*> pure Nothing
+              field = (,) <$> lowVar <*> depthTipe
-                         , Record <$> fields1 <*> (Just <$> lowVar)
+              fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
-                         ]
+              fields1 = (:) <$> field <*> fields
-            where depthTipe = choose (0,n) >>= tipe
+          in
-                  depthTipes = do
+              oneof
-                    len <- choose (0,n) 
+              [ T.Lambda <$> depthTipe <*> depthTipe
-                    let m = n `div` (len + 1)
+              , T.Var    <$> lowVar
-                    vectorOf len $ tipe m
+              , T.Data   <$> capVar <*> genVector n tipe
+              , T.Record <$> fields <*> pure Nothing
+              , T.Record <$> fields1 <*> (Just <$> lowVar)
+              ]
 
-                  field = (,) <$> lowVar <*> depthTipe
+  shrink tipe =
-                  fields = do
+    case tipe of
-                    len <- choose (0,n)
+      T.Lambda s t  -> s : t : (T.Lambda <$> shrink s <*> shrink t)
-                    let m = n `div` (len + 1)
+      T.Var _       -> []
-                    vectorOf len $ (,) <$> lowVar <*> tipe m
+      T.Data n ts   -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
-                  fields1 = (:) <$> field <*> fields
+      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
+            shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
-    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
 
 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
+  where
-        xset = Set.fromList xs
+    notAnX = flip Set.notMember xset
+    xset = Set.fromList xs