diff --git a/.gitignore b/.gitignore
index a502b8e..d096822 100644
--- a/.gitignore
+++ b/.gitignore
@@ -10,3 +10,4 @@ cabal-dev
data
*/ElmFiles/*
.DS_Store
+*~
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
index 0000000..5f9abb7
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,3 @@
+language: haskell
+ghc:
+ - 7.6
diff --git a/Elm.cabal b/Elm.cabal
index c306ba9..943fbf1 100644
--- a/Elm.cabal
+++ b/Elm.cabal
@@ -47,18 +47,21 @@ Library
SourceSyntax.PrettyPrint,
SourceSyntax.Type,
Generate.JavaScript,
+ Generate.JavaScript.Helpers,
+ Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown,
Generate.Html,
Generate.Cases,
Transform.Canonicalize,
Transform.Check,
+ Transform.Expression,
+ Transform.Declaration,
+ Transform.Definition,
Transform.SafeNames,
Transform.SortDefinitions,
Transform.Substitute,
- Transform.Optimize,
Metadata.Prelude,
- InterfaceSerialization,
Parse.Binop,
Parse.Declaration,
Parse.Expression,
@@ -85,6 +88,7 @@ Library
Build.Dependencies,
Build.File,
Build.Flags,
+ Build.Interface,
Build.Print,
Build.Source,
Build.Utils,
@@ -125,18 +129,21 @@ Executable elm
SourceSyntax.PrettyPrint,
SourceSyntax.Type,
Generate.JavaScript,
+ Generate.JavaScript.Helpers,
+ Generate.JavaScript.Ports,
Generate.Noscript,
Generate.Markdown,
Generate.Html,
Generate.Cases,
Transform.Canonicalize,
Transform.Check,
+ Transform.Expression,
+ Transform.Declaration,
+ Transform.Definition,
Transform.SafeNames,
Transform.SortDefinitions,
Transform.Substitute,
- Transform.Optimize,
Metadata.Prelude,
- InterfaceSerialization,
Parse.Binop,
Parse.Declaration,
Parse.Expression,
@@ -163,6 +170,7 @@ Executable elm
Build.Dependencies,
Build.File,
Build.Flags,
+ Build.Interface,
Build.Print,
Build.Source,
Build.Utils,
@@ -224,10 +232,46 @@ Executable elm-doc
pandoc >= 1.10,
parsec >= 3.1.1,
pretty,
- text
+ text,
+ union-find
Test-Suite test-elm
Type: exitcode-stdio-1.0
- Hs-Source-Dirs: tests
+ Hs-Source-Dirs: tests, compiler
Main-is: Main.hs
- build-depends: base, directory, HTF
+ other-modules: Tests.Compiler
+ Tests.Property
+ Tests.Property.Arbitrary
+ SourceSyntax.Helpers
+ SourceSyntax.Literal
+ SourceSyntax.PrettyPrint
+ build-depends: base,
+ directory,
+ Elm,
+ test-framework,
+ test-framework-hunit,
+ test-framework-quickcheck2,
+ HUnit,
+ pretty,
+ QuickCheck >= 2 && < 3,
+ filemanip,
+ aeson,
+ base >=4.2 && <5,
+ binary >= 0.6.4.0,
+ blaze-html == 0.5.* || == 0.6.*,
+ blaze-markup == 0.5.1.*,
+ bytestring,
+ cmdargs,
+ containers >= 0.3,
+ directory,
+ filepath,
+ indents,
+ language-ecmascript >=0.15 && < 1.0,
+ mtl >= 2,
+ pandoc >= 1.10,
+ parsec >= 3.1.1,
+ pretty,
+ text,
+ transformers >= 0.2,
+ union-find,
+ unordered-containers
diff --git a/README.md b/README.md
index 5e7fb1a..333f0ee 100644
--- a/README.md
+++ b/README.md
@@ -1,5 +1,6 @@
Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
+[](https://travis-ci.org/evancz/Elm)
## Install
diff --git a/compiler/Build/Dependencies.hs b/compiler/Build/Dependencies.hs
index 4ebdcb0..e2f54d1 100644
--- a/compiler/Build/Dependencies.hs
+++ b/compiler/Build/Dependencies.hs
@@ -1,42 +1,32 @@
-module Build.Dependencies (getSortedDependencies) where
+{-# OPTIONS_GHC -W #-}
+module Build.Dependencies (getSortedDependencies, readDeps) where
-import Data.Data
import Control.Applicative
import Control.Monad.Error
import qualified Control.Monad.State as State
import qualified Data.Aeson as Json
import qualified Data.ByteString.Lazy.Char8 as BSC
-import qualified Data.Char as Char
import qualified Data.Graph as Graph
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import System.Directory
-import System.Exit
import System.FilePath as FP
-import System.IO
-import Text.PrettyPrint (Doc)
+
+import Build.Print (failure)
import qualified SourceSyntax.Module as Module
-import qualified SourceSyntax.Type as Type
import qualified Parse.Parse as Parse
-import qualified Metadata.Prelude as Prelude
-import qualified Transform.Check as Check
-import qualified Transform.SortDefinitions as SD
-import qualified Type.Inference as TI
-import qualified Type.Constrain.Declaration as TcDecl
-import qualified Transform.Canonicalize as Canonical
import qualified Elm.Internal.Paths as Path
import qualified Elm.Internal.Name as N
-import qualified Elm.Internal.Version as V
import qualified Elm.Internal.Dependencies as Deps
getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]
getSortedDependencies srcDirs builtIns root =
do extras <- extraDependencies
let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
- result <- runErrorT $ readDeps allSrcDirs 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
@@ -44,8 +34,6 @@ getSortedDependencies srcDirs builtIns root =
Path.dependencyFile ++
" file if you\nare trying to use a 3rd party library."
-failure msg = hPutStrLn stderr msg >> exitFailure
-
extraDependencies :: IO (Maybe [FilePath])
extraDependencies =
do exists <- doesFileExist Path.dependencyFile
@@ -86,46 +74,52 @@ sortDeps depends =
mistakes = filter (\scc -> length scc > 1) sccs
msg = "A cyclical module dependency or was detected in:\n"
-readDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
-readDeps srcDirs builtIns root = do
- let ifaces = (Set.fromList . Map.keys) builtIns
- State.evalStateT (go ifaces root) Set.empty
+readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
+readAllDeps srcDirs builtIns root =
+ do let ifaces = (Set.fromList . Map.keys) builtIns
+ State.evalStateT (go ifaces root) Set.empty
where
go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
go builtIns root = do
- (root', txt) <- lift $ getFile srcDirs root
- case Parse.dependencies txt of
- Left err -> throwError $ msg ++ show err
- where msg = "Error resolving dependencies in " ++ root' ++ ":\n"
+ root' <- lift $ findSrcFile srcDirs root
+ (name, deps) <- lift $ readDeps root'
+ seen <- State.get
+ let realDeps = Set.difference (Set.fromList deps) builtIns
+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
+ State.put (Set.insert name (Set.union newDeps seen))
+ rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
+ return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
- Right (name,deps) ->
- do seen <- State.get
- let realDeps = Set.difference (Set.fromList deps) builtIns
- newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
- State.put (Set.insert name (Set.union newDeps seen))
- rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
- return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
+readDeps :: FilePath -> ErrorT String IO (String, [String])
+readDeps path = do
+ txt <- lift $ readFile path
+ case Parse.dependencies txt of
+ Left err -> throwError $ msg ++ show err
+ where msg = "Error resolving dependencies in " ++ path ++ ":\n"
+ Right o -> return o
-getFile :: [FilePath] -> FilePath -> ErrorT String IO (FilePath,String)
-getFile [] path =
- 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." ]
-
-getFile (dir:dirs) path = do
- let path' = dir path
- exists <- liftIO $ doesFileExist path'
- case exists of
- True -> (,) path' `fmap` liftIO (readFile path')
- False -> getFile dirs path
+findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
+findSrcFile 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'
+ if exists
+ then return path'
+ else next
+isNative :: String -> Bool
isNative name = List.isPrefixOf "Native." name
toFilePath :: String -> FilePath
toFilePath name = map swapDots name ++ ext
- where swapDots '.' = '/'
- swapDots c = c
- ext = if isNative name then ".js" else ".elm"
+ where
+ swapDots '.' = '/'
+ swapDots c = c
+ ext = if isNative name then ".js" else ".elm"
diff --git a/compiler/Build/File.hs b/compiler/Build/File.hs
index 371aa6d..c8e3164 100644
--- a/compiler/Build/File.hs
+++ b/compiler/Build/File.hs
@@ -1,93 +1,137 @@
+{-# OPTIONS_GHC -W #-}
module Build.File (build) where
-import Control.Monad (when)
-import qualified Data.Binary as Binary
-import qualified Data.List as List
-import qualified Data.Map as Map
+import Control.Applicative ((<$>))
+import Control.Monad.Error (runErrorT)
+import Control.Monad.RWS.Strict
import System.Directory
import System.Exit
import System.FilePath
import System.IO
+import qualified Data.Binary as Binary
+import qualified Data.Maybe as Maybe
+import qualified Data.Map as Map
+import qualified Data.ByteString.Lazy as L
+
+import qualified Build.Dependencies as Deps
+import qualified Build.Flags as Flag
+import qualified Build.Interface as Interface
+import qualified Build.Print as Print
+import qualified Build.Source as Source
+import qualified Build.Utils as Utils
+import qualified Generate.JavaScript as JS
+import qualified Parse.Module as Parser
+import qualified SourceSyntax.Module as M
import qualified Transform.Canonicalize as Canonical
-import qualified Data.ByteString.Lazy as L
+-- Reader: Runtime flags, always accessible
+-- Writer: Remember the last module to be accessed
+-- State: Build up a map of the module interfaces
+type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
+type Build a = BuildT IO a
-import qualified Build.Utils as Utils
-import qualified Build.Flags as Flag
-import qualified Build.Source as Source
-import qualified Build.Print as Print
-import qualified Generate.JavaScript as JS
-import qualified InterfaceSerialization as IS
-import qualified Parse.Module as Parser
-import qualified SourceSyntax.Module as M
+-- Interfaces, remembering if something was recompiled
+type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
-build :: Flag.Flags -> Int -> M.Interfaces -> String -> [FilePath]
- -> IO (String, M.Interfaces)
-build _ _ interfaces moduleName [] =
- return (moduleName, interfaces)
-build flags numModules interfaces _ (filePath:rest) =
- do (name,interface) <-
- build1 flags (numModules - length rest) numModules interfaces filePath
- let interfaces' = Map.insert name interface interfaces
- build flags numModules interfaces' name rest
+evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
+evalBuild flags interfaces b = do
+ (_, s) <- evalRWST b flags (fmap notUpdated interfaces)
+ return . getLast $ s
+ where
+ notUpdated i = (False, i)
+-- | Builds a list of files, returning the moduleName of the last one.
+-- Returns \"\" if the list is empty
+build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
+build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
-build1 :: Flag.Flags -> Int -> Int -> M.Interfaces -> FilePath
- -> IO (String, M.ModuleInterface)
-build1 flags moduleNum numModules interfaces filePath =
- do compiled <- alreadyCompiled flags filePath
- case compiled of
- False -> compile flags number interfaces filePath
- True -> retrieve flags interfaces filePath
- where
- number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
+buildAll :: [FilePath] -> Build ()
+buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
+ where build1 :: Integer -> FilePath -> Build ()
+ build1 num fname = do
+ shouldCompile <- shouldBeCompiled fname
+ if shouldCompile
+ then compile number fname
+ else retrieve fname
+ where number = join ["[", show num, " of ", show total, "]"]
-alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool
-alreadyCompiled flags filePath = do
- existsi <- doesFileExist (Utils.elmi flags filePath)
- existso <- doesFileExist (Utils.elmo flags filePath)
- if not existsi || not existso
- then return False
- else do tsrc <- getModificationTime filePath
- tint <- getModificationTime (Utils.elmo flags filePath)
- return (tsrc <= tint)
+ total = length fs
-retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath
- -> IO (String, M.ModuleInterface)
-retrieve flags interfaces filePath = do
- bytes <- IS.loadInterface (Utils.elmi flags filePath)
- let binary = IS.interfaceDecode (Utils.elmi flags filePath) =<< bytes
- case IS.validVersion filePath =<< binary of
+shouldBeCompiled :: FilePath -> Build Bool
+shouldBeCompiled filePath = do
+ flags <- ask
+ let alreadyCompiled = liftIO $ do
+ existsi <- doesFileExist (Utils.elmi flags filePath)
+ existso <- doesFileExist (Utils.elmo flags filePath)
+ return $ existsi && existso
+
+ outDated = liftIO $ do
+ tsrc <- getModificationTime filePath
+ tint <- getModificationTime (Utils.elmo flags filePath)
+ return (tsrc > tint)
+
+ dependenciesUpdated = do
+ eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
+ case eDeps of
+ -- Should never actually reach here
+ Left err -> liftIO $ Print.failure err
+ Right (_, deps) -> anyM wasCompiled deps
+
+
+ in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
+
+wasCompiled :: String -> Build Bool
+wasCompiled modul = maybe False fst . Map.lookup modul <$> get
+
+-- Short-circuiting monadic (||)
+infixr 2 `orM`
+orM :: (Monad m) => m Bool -> m Bool -> m Bool
+orM m1 m2 = do b1 <- m1
+ if b1
+ then return b1
+ else m2
+
+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+anyM f = foldr (orM . f) (return False)
+
+retrieve :: FilePath -> Build ()
+retrieve filePath = do
+ flags <- ask
+ iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
+ case Interface.isValid filePath iface of
Right (name, interface) ->
- do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
- return (name, interface)
- Left err ->
- do hPutStrLn stderr err
- exitFailure
+ do binterfaces <- get
+ let interfaces = snd <$> binterfaces
+ liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
+ update name interface False
-compile :: Flag.Flags -> String -> M.Interfaces -> FilePath
- -> IO (String, M.ModuleInterface)
-compile flags number interfaces filePath =
- do source <- readFile filePath
- let name = getName source
- printStatus name
+ Left err -> liftIO $ Print.failure err
- createDirectoryIfMissing True (Flag.cache_dir flags)
- createDirectoryIfMissing True (Flag.build_dir flags)
+compile :: String -> FilePath -> Build ()
+compile number filePath =
+ do flags <- ask
+ binterfaces <- get
+ source <- liftIO $ readFile filePath
+ let interfaces = snd <$> binterfaces
+ name = getName source
+ liftIO $ do
+ printStatus name
+ createDirectoryIfMissing True (Flag.cache_dir flags)
+ createDirectoryIfMissing True (Flag.build_dir flags)
- metaModule <-
- case Source.build (Flag.no_prelude flags) interfaces source of
+ metaModule <-
+ liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
Right modul -> return modul
Left errors -> do Print.errors errors
exitFailure
- when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
-
- let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
- generateCache intermediate metaModule
- return intermediate
+ liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
+
+ let newInters = Canonical.interface name $ M.metaToInterface metaModule
+ generateCache name newInters metaModule
+ update name newInters True
where
getName source = case Parser.getModuleName source of
@@ -99,8 +143,14 @@ compile flags number interfaces filePath =
, replicate (max 1 (20 - length name)) ' '
, "( " ++ filePath ++ " )" ]
- generateCache intermediate metaModule = do
- createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
- writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
- withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
- L.hPut handle (Binary.encode intermediate)
+ generateCache name interfs metaModule = do
+ flags <- ask
+ liftIO $ do
+ createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
+ writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
+ withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
+ L.hPut handle (Binary.encode (name, interfs))
+
+update :: String -> M.ModuleInterface -> Bool -> Build ()
+update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
+ >> tell (Last . Just $ name)
diff --git a/compiler/Build/Interface.hs b/compiler/Build/Interface.hs
new file mode 100644
index 0000000..249c70f
--- /dev/null
+++ b/compiler/Build/Interface.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS_GHC -W #-}
+module Build.Interface (load,isValid) where
+
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Binary as Binary
+
+import qualified Elm.Internal.Version as Version
+import System.Directory (doesFileExist)
+import System.Exit
+import System.IO
+
+import SourceSyntax.Module
+
+load :: Binary.Binary a => FilePath -> IO a
+load filePath =
+ do exists <- doesFileExist filePath
+ case exists of
+ False -> failure $ "Unable to find file " ++ filePath ++ " for deserialization!"
+ True -> do
+ bytes <- L.readFile filePath
+ case Binary.decodeOrFail bytes of
+ Right (_, _, binaryInfo) -> return binaryInfo
+ Left (_, offset, err) -> failure $ msg offset err
+
+ where
+ failure err = do hPutStrLn stderr err
+ exitFailure
+
+ msg offset err = concat
+ [ "Error reading build artifact: ", filePath, "\n"
+ , " '", err, "' at offset ", show offset, "\n"
+ , " The file was generated by a previous build and may be outdated or corrupt.\n"
+ , " Please remove the file and try again."
+ ]
+
+isValid :: FilePath -> (String, ModuleInterface) -> Either String (String, ModuleInterface)
+isValid filePath (name, interface) =
+ let version = iVersion interface in
+ if version == Version.elmVersion
+ then Right (name, interface)
+ else Left $ concat
+ [ "Error reading build artifact: ", filePath, "\n"
+ , " It was generated by version ", show version, " of the compiler,\n"
+ , " but you are using version ", show Version.elmVersion, "\n"
+ , " Please remove the file and try again.\n"
+ ]
diff --git a/compiler/Build/Print.hs b/compiler/Build/Print.hs
index abedfd8..a92f9e4 100644
--- a/compiler/Build/Print.hs
+++ b/compiler/Build/Print.hs
@@ -1,5 +1,8 @@
module Build.Print where
+import System.IO (hPutStrLn, stderr)
+import System.Exit (exitFailure)
+
import qualified Data.Map as Map
import qualified Data.List as List
import qualified SourceSyntax.Module as M
@@ -7,7 +10,7 @@ import qualified SourceSyntax.PrettyPrint as Pretty
import qualified Type.Alias as Alias
import qualified Text.PrettyPrint as P
-metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule () () -> IO ()
+metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule -> IO ()
metaTypes interfaces meta =
types interfaces (M.types meta) (M.aliases meta) (M.imports meta)
@@ -29,4 +32,7 @@ types interfaces types' aliases imports =
errors :: [P.Doc] -> IO ()
errors errs =
- mapM_ print (List.intersperse (P.text " ") errs)
\ No newline at end of file
+ mapM_ print (List.intersperse (P.text " ") errs)
+
+failure :: String -> IO a
+failure msg = hPutStrLn stderr msg >> exitFailure
diff --git a/compiler/Build/Source.hs b/compiler/Build/Source.hs
index bed3f13..27eb2ac 100644
--- a/compiler/Build/Source.hs
+++ b/compiler/Build/Source.hs
@@ -1,19 +1,15 @@
+{-# OPTIONS_GHC -W #-}
module Build.Source (build) where
-import Data.Data
-import Control.Monad.State
-import qualified Data.Graph as Graph
-import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
-import System.Directory
-import System.Exit
import System.FilePath as FP
import Text.PrettyPrint (Doc)
import SourceSyntax.Declaration
import SourceSyntax.Module
import qualified SourceSyntax.Expression as Expr
+import qualified SourceSyntax.Pattern as Pattern
import qualified SourceSyntax.Type as Type
import qualified Parse.Parse as Parse
import qualified Metadata.Prelude as Prelude
@@ -23,42 +19,39 @@ import qualified Type.Inference as TI
import qualified Type.Constrain.Declaration as TcDecl
import qualified Transform.Canonicalize as Canonical
-build :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())
+build :: Bool -> Interfaces -> String -> Either [Doc] MetadataModule
build noPrelude interfaces source =
- do let add = if noPrelude then id else Prelude.add
+ do let add = Prelude.add noPrelude
infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
. concatMap iFixities $ Map.elems interfaces
- modul@(Module _ _ _ decls') <- add `fmap` Parse.program infixes source
-
- -- check for structural errors
- Module names exs ims decls <-
- case Check.mistakes decls' of
- [] -> return modul
- ms -> Left ms
+ Module names exs ims decls <- do
+ modul@(Module _ _ _ decls) <- add `fmap` Parse.program infixes source
+ case Check.mistakes decls of
+ [] -> return modul
+ ms -> Left ms
let exports'
| null exs =
- let get = Set.toList . SD.boundVars in
- concat [ get pattern | Definition (Expr.Def pattern _) <- decls ] ++
- concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
- [ name | TypeAlias name _ (Type.Record _ _) <- decls ]
+ let get = Set.toList . Pattern.boundVars in
+ concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
+ concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++
+ [ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]
| otherwise = exs
- metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
- names = names,
- path = FP.joinPath names,
- exports = exports',
- imports = ims,
+ metaModule <- Canonical.metadataModule interfaces $
+ MetadataModule
+ { names = names
+ , path = FP.joinPath names
+ , exports = exports'
+ , imports = ims
-- reorder AST into strongly connected components
- program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls,
- types = Map.empty,
- datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
- fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
- aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
- foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
- foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
- }
+ , program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls
+ , types = Map.empty
+ , datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ]
+ , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]
+ , aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ]
+ }
types <- TI.infer interfaces metaModule
diff --git a/compiler/Build/Utils.hs b/compiler/Build/Utils.hs
index 3ec0ea0..655e262 100644
--- a/compiler/Build/Utils.hs
+++ b/compiler/Build/Utils.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Build.Utils where
import System.FilePath ((), replaceExtension)
diff --git a/compiler/Compiler.hs b/compiler/Compiler.hs
index 6674dc3..2fefdb4 100644
--- a/compiler/Compiler.hs
+++ b/compiler/Compiler.hs
@@ -1,7 +1,7 @@
+{-# OPTIONS_GHC -W #-}
module Main where
import Control.Monad (foldM)
-import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import Text.Blaze.Html.Renderer.String (renderHtml)
import qualified Data.ByteString.Lazy.Char8 as BS
@@ -31,14 +31,13 @@ compileArgs flags =
build :: Flag.Flags -> FilePath -> IO ()
build flags rootFile =
do let noPrelude = Flag.no_prelude flags
- builtIns <- if noPrelude then return Map.empty else Prelude.interfaces
+ builtIns <- Prelude.interfaces noPrelude
files <- if Flag.make flags
then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
else return [rootFile]
- (moduleName, interfaces) <-
- File.build flags (length files) builtIns "" files
+ moduleName <- File.build flags builtIns files
js <- foldM appendToOutput BS.empty files
diff --git a/compiler/Docs.hs b/compiler/Docs.hs
index cc3d343..f7c5c02 100644
--- a/compiler/Docs.hs
+++ b/compiler/Docs.hs
@@ -7,7 +7,7 @@ import System.FilePath
import System.Exit
import System.IO
-import Control.Applicative ((<$>), (<*>))
+import Control.Applicative ((<$>))
import Data.Aeson
import Data.Aeson.Encode.Pretty
import qualified Data.List as List
@@ -17,8 +17,8 @@ import qualified Data.Text as Text
import SourceSyntax.Helpers (isSymbol)
import SourceSyntax.Type (Type(..))
-import SourceSyntax.Declaration (Declaration(..), Assoc(..))
-import SourceSyntax.Expression (Def(..))
+import qualified SourceSyntax.Expression as E
+import qualified SourceSyntax.Declaration as D
import Text.Parsec hiding (newline,spaces)
import Parse.Declaration (alias,datatype,infixDecl)
@@ -77,10 +77,10 @@ moduleDocs = do
structure <- docComment
return (List.intercalate "." names, exports, structure)
-document :: IParser [(String, Declaration t v, String)]
+document :: IParser [(String, D.ParseDeclaration, String)]
document = onFreshLines (\t ts -> ts ++ [t]) [] docThing
-docThing :: IParser (String, Declaration t v, String)
+docThing :: IParser (String, D.ParseDeclaration, String)
docThing = uncommentable <|> commented <|> uncommented ""
where
uncommentable = do
@@ -93,7 +93,7 @@ docThing = uncommentable <|> commented <|> uncommented ""
uncommented comment
uncommented comment = do
- (src,def) <- withSource $ choice [ alias, datatype, Definition <$> typeAnnotation ]
+ (src,def) <- withSource $ choice [ alias, datatype, D.Definition <$> typeAnnotation ]
return (comment, def, src)
@@ -121,7 +121,7 @@ collect infixes types aliases adts things =
where
nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
addDefaultInfix name pairs
- | all isSymbol name = addInfix (L, 9 :: Int) pairs
+ | all isSymbol name = addInfix (D.L, 9 :: Int) pairs
| otherwise = pairs
customOps = Map.intersectionWith addInfix infixes types
@@ -130,16 +130,18 @@ collect infixes types aliases adts things =
(comment, decl, source) : rest ->
case decl of
- Fixity assoc prec name ->
+ D.Fixity assoc prec name ->
collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
- Definition (TypeAnnotation name tipe) ->
+ D.Definition (E.TypeAnnotation name tipe) ->
collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
- TypeAlias name vars tipe ->
- let fields = ["typeVariables" .= vars, "type" .= tipe ]
+ D.TypeAlias name vars tipe derivations ->
+ let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]
in collect infixes types (insert name fields aliases) adts rest
- Datatype name vars ctors ->
+ D.Datatype name vars ctors derivations ->
let tipe = Data name (map Var vars)
- fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]
+ fields = ["typeVariables" .= vars
+ , "constructors" .= map (ctorToJson tipe) ctors
+ , "deriving" .= derivations ]
in collect infixes types aliases (insert name fields adts) rest
where
insert name fields dict = Map.insert name (obj name fields) dict
@@ -152,12 +154,14 @@ instance ToJSON Type where
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
Var x -> toJSON x
Data name ts -> toJSON (toJSON name : map toJSON ts)
- EmptyRecord -> object []
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
where fields' = case ext of
- EmptyRecord -> fields
- _ -> ("_",ext) : fields
+ Nothing -> fields
+ Just x -> ("_", Var x) : fields
ctorToJson tipe (ctor, tipes) =
object [ "name" .= ctor
- , "type" .= foldr Lambda tipe tipes ]
\ No newline at end of file
+ , "type" .= foldr Lambda tipe tipes ]
+
+instance ToJSON D.Derivation where
+ toJSON = toJSON . show
\ No newline at end of file
diff --git a/compiler/Elm/Internal/Utils.hs b/compiler/Elm/Internal/Utils.hs
index 97b2706..0d0ea40 100644
--- a/compiler/Elm/Internal/Utils.hs
+++ b/compiler/Elm/Internal/Utils.hs
@@ -21,7 +21,7 @@ compile source =
{-# NOINLINE interfaces #-}
interfaces :: M.Interfaces
-interfaces = unsafePerformIO $ Prelude.interfaces
+interfaces = unsafePerformIO $ Prelude.interfaces False
-- |This function extracts the module name of a given source program.
moduleName :: String -> Maybe String
diff --git a/compiler/Generate/Cases.hs b/compiler/Generate/Cases.hs
index ec43f49..0e29644 100644
--- a/compiler/Generate/Cases.hs
+++ b/compiler/Generate/Cases.hs
@@ -1,9 +1,9 @@
module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where
-import Control.Applicative ((<$>),(<*>))
-import Control.Arrow (first,second)
+import Control.Applicative ((<$>))
+import Control.Arrow (first)
import Control.Monad.State
-import Data.List (groupBy,sortBy,lookup)
+import Data.List (groupBy,sortBy)
import Data.Maybe (fromMaybe)
import SourceSyntax.Location
@@ -13,7 +13,7 @@ import SourceSyntax.Expression
import Transform.Substitute
-toMatch :: [(Pattern, LExpr t v)] -> State Int (String, Match t v)
+toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
toMatch patterns = do
v <- newVar
(,) v <$> match [v] (map (first (:[])) patterns) Fail
@@ -23,19 +23,19 @@ newVar = do n <- get
modify (+1)
return $ "_v" ++ show n
-data Match t v
- = Match String [Clause t v] (Match t v)
+data Match
+ = Match String [Clause] Match
| Break
| Fail
- | Other (LExpr t v)
- | Seq [Match t v]
+ | Other LExpr
+ | Seq [Match]
deriving Show
-data Clause t v =
- Clause (Either String Literal) [String] (Match t v)
+data Clause =
+ Clause (Either String Literal) [String] Match
deriving Show
-matchSubst :: [(String,String)] -> Match t v -> Match t v
+matchSubst :: [(String,String)] -> Match -> Match
matchSubst _ Break = Break
matchSubst _ Fail = Fail
matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
@@ -47,7 +47,7 @@ matchSubst pairs (Match n cs m) =
clauseSubst (Clause c vs m) =
Clause c (map varSubst vs) (matchSubst pairs m)
-isCon (p:ps, e) =
+isCon (p:_, _) =
case p of
PData _ _ -> True
PLiteral _ -> True
@@ -55,7 +55,7 @@ isCon (p:ps, e) =
isVar p = not (isCon p)
-match :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)
+match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
match [] [] def = return def
match [] [([],e)] Fail = return $ Other e
match [] [([],e)] Break = return $ Other e
@@ -72,10 +72,10 @@ dealias v c@(p:ps, L s e) =
PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
_ -> c
-matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)
+matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
matchVar (v:vs) cs def = match vs (map subVar cs) def
where
- subVar (p:ps, ce@(L s e)) = (ps, L s $ subOnePattern p e)
+ subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)
where
subOnePattern pattern e =
case pattern of
@@ -84,7 +84,7 @@ matchVar (v:vs) cs def = match vs (map subVar cs) def
PRecord fs ->
foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
-matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)
+matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
where
css = groupBy eq (sortBy cmp cs)
@@ -106,10 +106,10 @@ matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
matchClause :: Either String Literal
-> [String]
- -> [([Pattern],LExpr t v)]
- -> Match t v
- -> State Int (Clause t v)
-matchClause c (v:vs) cs def =
+ -> [([Pattern],LExpr)]
+ -> Match
+ -> State Int Clause
+matchClause c (_:vs) cs def =
do vs' <- getVars
Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def
where
@@ -124,6 +124,6 @@ matchClause c (v:vs) cs def =
(PData _ ps : _, _) -> forM ps (const newVar)
(PLiteral _ : _, _) -> return []
-matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)
+matchMix :: [String] -> [([Pattern],LExpr)] -> 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
\ No newline at end of file
diff --git a/compiler/Generate/JavaScript.hs b/compiler/Generate/JavaScript.hs
index d768795..aae77b4 100644
--- a/compiler/Generate/JavaScript.hs
+++ b/compiler/Generate/JavaScript.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Generate.JavaScript (generate) where
import Control.Arrow (first,(***))
@@ -7,67 +8,49 @@ import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Generate.JavaScript.Helpers
import qualified Generate.Cases as Case
+import qualified Generate.JavaScript.Ports as Port
import qualified Generate.Markdown as MD
import qualified SourceSyntax.Helpers as Help
import SourceSyntax.Literal
-import SourceSyntax.Pattern
+import SourceSyntax.Pattern as Pattern
import SourceSyntax.Location
import SourceSyntax.Expression
import SourceSyntax.Module
-import qualified Transform.SortDefinitions as SD
import Language.ECMAScript3.Syntax
import Language.ECMAScript3.PrettyPrint
import qualified Transform.SafeNames as MakeSafe
-split :: String -> [String]
-split = go []
- where
- go vars str =
- case break (=='.') str of
- (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
- | otherwise -> go (vars ++ [x]) rest
- (x,[]) -> vars ++ [x]
-
-var name = Id () name
-ref name = VarRef () (var name)
-prop name = PropId () (var name)
-f <| x = CallExpr () f [x]
-args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]
-function args stmts = FuncExpr () Nothing (map var args) stmts
-call = CallExpr ()
-string = StringLit ()
-
-dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)
-obj = dotSep . split
-
varDecl :: String -> Expression () -> VarDecl ()
varDecl x expr =
VarDecl () (var x) (Just expr)
+include :: String -> String -> VarDecl ()
include alias moduleName =
varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
+internalImports :: String -> Statement ()
internalImports name =
VarDeclStmt ()
- [ varDecl "N" (obj "Elm.Native")
- , include "_N" "N.Utils"
- , include "_L" "N.List"
- , include "_E" "N.Error"
- , include "_J" "N.JavaScript"
+ [ varDecl "_N" (obj "Elm.Native")
+ , include "_U" "_N.Utils"
+ , include "_L" "_N.List"
+ , include "_E" "_N.Error"
+ , include "_J" "_N.JavaScript"
, varDecl "$moduleName" (string name)
]
literal :: Literal -> Expression ()
literal lit =
case lit of
- Chr c -> obj "_N.chr" <| string [c]
+ Chr c -> obj "_U.chr" <| string [c]
Str s -> string s
IntNum n -> IntLit () n
FloatNum n -> NumLit () n
Boolean b -> BoolLit () b
-expression :: LExpr () () -> State Int (Expression ())
+expression :: LExpr -> State Int (Expression ())
expression (L span expr) =
case expr of
Var x -> return $ ref x
@@ -84,19 +67,19 @@ expression (L span expr) =
Remove e x ->
do e' <- expression e
- return $ obj "_N.remove" `call` [string x, e']
+ return $ obj "_U.remove" `call` [string x, e']
Insert e x v ->
do v' <- expression v
e' <- expression e
- return $ obj "_N.insert" `call` [string x, v', e']
+ return $ obj "_U.insert" `call` [string x, v', e']
Modify e fs ->
do e' <- expression e
fs' <- forM fs $ \(f,v) -> do
v' <- expression v
return $ ArrayLit () [string f, v']
- return $ obj "_N.replace" `call` [ArrayLit () fs', e']
+ return $ obj "_U.replace" `call` [ArrayLit () fs', e']
Record fields ->
do fields' <- forM fields $ \(f,e) -> do
@@ -148,10 +131,10 @@ expression (L span expr) =
_ -> (func, args)
Let defs e ->
- do let (defs',e') = SD.flattenLets defs e
+ do let (defs',e') = flattenLets defs e
stmts <- concat <$> mapM definition defs'
exp <- expression e'
- return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []
+ return $ function [] (stmts ++ [ ret exp ]) `call` []
MultiIf branches ->
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
@@ -192,56 +175,59 @@ expression (L span expr) =
pad = "
"
md = pad ++ MD.toHtml doc ++ pad
-definition :: Def () () -> State Int [Statement ()]
-definition def =
- case def of
- TypeAnnotation _ _ -> return []
+ PortIn name tipe ->
+ return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
- Def pattern expr@(L span _) -> do
- expr' <- expression expr
- let assign x = varDecl x expr'
- case pattern of
- PVar x
- | Help.isOp x ->
- let op = LBracket () (ref "_op") (string x) in
- return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
- | otherwise ->
- return [ VarDeclStmt () [ assign x ] ]
+ PortOut name tipe value ->
+ do value' <- expression value
+ return $ obj "Native.Ports.portOut" `call`
+ [ string name, Port.outgoing tipe, value' ]
- PRecord fields ->
- let setField f = varDecl f (dotSep ["$",f]) in
- return [ VarDeclStmt () (assign "$" : map setField fields) ]
+definition :: Def -> State Int [Statement ()]
+definition (Definition pattern expr@(L span _) _) = do
+ expr' <- expression expr
+ let assign x = varDecl x expr'
+ case pattern of
+ PVar x
+ | Help.isOp x ->
+ let op = LBracket () (ref "_op") (string x) in
+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
+ | otherwise ->
+ return [ VarDeclStmt () [ assign x ] ]
- PData name patterns | vars /= Nothing ->
- case vars of
- Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]
- where
- vars = getVars patterns
- getVars patterns =
- case patterns of
- PVar x : rest -> (x:) `fmap` getVars rest
- [] -> Just []
- _ -> Nothing
+ PRecord fields ->
+ let setField f = varDecl f (dotSep ["$",f]) in
+ return [ VarDeclStmt () (assign "$" : map setField fields) ]
- decl x n = varDecl x (dotSep ["$","_" ++ show n])
- setup vars
- | Help.isTuple name = assign "$" : vars
- | otherwise = assign "$raw" : safeAssign : vars
+ PData 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
+ [] -> Just []
+ _ -> Nothing
- 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)]
+ decl x n = varDecl x (dotSep ["$","_" ++ show n])
+ setup vars
+ | Help.isTuple name = assign "$" : vars
+ | otherwise = assign "$raw" : safeAssign : vars
- _ ->
- do defs' <- concat <$> mapM toDef vars
- return (VarDeclStmt () [assign "$"] : defs')
- where
- vars = Set.toList $ SD.boundVars pattern
- mkVar = L span . Var
- toDef y = definition $
- Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])
+ 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)]
-match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]
+ _ ->
+ do defs' <- concat <$> mapM toDef vars
+ return (VarDeclStmt () [assign "$"] : defs')
+ where
+ vars = Set.toList $ Pattern.boundVars pattern
+ mkVar = L span . Var
+ toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
+ in definition $ Definition (PVar y) expr Nothing
+
+match :: SrcSpan -> Case.Match -> State Int [Statement ()]
match span mtch =
case mtch of
Case.Match name clauses mtch' ->
@@ -263,7 +249,7 @@ match span mtch =
Case.Break -> return [BreakStmt () Nothing]
Case.Other e ->
do e' <- expression e
- return [ ReturnStmt () (Just e') ]
+ return [ ret e' ]
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
where
dropEnd acc [] = acc
@@ -272,6 +258,7 @@ match span mtch =
Case.Other _ -> acc ++ [m]
_ -> dropEnd (acc ++ [m]) ms
+clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
clause span variable (Case.Clause value vars mtch) =
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
where
@@ -286,8 +273,13 @@ clause span variable (Case.Clause value vars mtch) =
[] -> name
is -> drop (last is + 1) name
+flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
+flattenLets defs lexpr@(L _ expr) =
+ case expr of
+ Let ds body -> flattenLets (defs ++ ds) body
+ _ -> (defs, lexpr)
-generate :: MetadataModule () () -> String
+generate :: MetadataModule -> String
generate unsafeModule =
show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
[ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
@@ -295,17 +287,16 @@ generate unsafeModule =
modul = MakeSafe.metadataModule unsafeModule
thisModule = dotSep ("_elm" : names modul ++ ["values"])
programStmts =
- concat [ setup (Just "_elm") (names modul ++ ["values"])
- , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
- , [ internalImports (List.intercalate "." (names modul)) ]
- , concatMap jsImport (imports modul)
- , concatMap importEvent (foreignImports modul)
- , [ assign ["_op"] (ObjectLit () []) ]
- , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
- , map exportEvent $ foreignExports modul
- , [ jsExports ]
- , [ ReturnStmt () (Just thisModule) ]
- ]
+ concat
+ [ 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
+ , [ assign ["_op"] (ObjectLit () []) ]
+ , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
+ , [ jsExports ]
+ , [ ret thisModule ]
+ ]
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
where
@@ -318,7 +309,7 @@ generate unsafeModule =
_ -> ExprStmt () $
AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
- jsImport (modul,_) = setup Nothing path ++ [ include ]
+ jsImport modul = setup Nothing path ++ [ include ]
where
path = split modul
include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
@@ -330,32 +321,7 @@ generate unsafeModule =
Nothing -> tail . init $ List.inits path
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
- addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
-
- importEvent (js,base,elm,_) =
- [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
- , ExprStmt () $
- obj "document.addEventListener" `call`
- [ addId js
- , function ["_e"]
- [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]
- ]
- ]
-
- exportEvent (js,elm,_) =
- ExprStmt () $
- ref "A2" `call`
- [ obj "Signal.lift"
- , function ["_v"]
- [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]
- , ExprStmt () $
- obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
- , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")
- , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"
- , ReturnStmt () (Just $ ref "_v")
- ]
- , ref elm ]
-
+binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
binop span op e1 e2 =
case op of
"Basics.." ->
@@ -382,9 +348,6 @@ binop span op e1 e2 =
L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
_ -> es ++ [e]
- js1 = expression e1
- js2 = expression e2
-
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
| otherwise = dotSep parts
where
@@ -408,8 +371,8 @@ binop span op e1 e2 =
specialOps = concat
[ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
, specialOp "|>" $ flip (<|)
- , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]
- , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])
+ , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
, specialOp "<" $ cmp OpLT 0
, specialOp ">" $ cmp OpGT 0
, specialOp "<=" $ cmp OpLT 1
@@ -417,4 +380,4 @@ binop span op e1 e2 =
, specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
]
- cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)
+ cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)
diff --git a/compiler/Generate/JavaScript/Helpers.hs b/compiler/Generate/JavaScript/Helpers.hs
new file mode 100644
index 0000000..ec12c89
--- /dev/null
+++ b/compiler/Generate/JavaScript/Helpers.hs
@@ -0,0 +1,37 @@
+{-# OPTIONS_GHC -W #-}
+module Generate.JavaScript.Helpers where
+
+import qualified SourceSyntax.Helpers as Help
+import Language.ECMAScript3.Syntax
+
+split :: String -> [String]
+split = go []
+ where
+ go vars str =
+ case break (=='.') str of
+ (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]
+ | otherwise -> go (vars ++ [x]) rest
+ (x,[]) -> vars ++ [x]
+
+var name = Id () name
+ref name = VarRef () (var name)
+prop name = PropId () (var name)
+f <| x = CallExpr () f [x]
+ret e = ReturnStmt () (Just e)
+args ==> e = FuncExpr () Nothing (map var args) [ ret e ]
+function args stmts = FuncExpr () Nothing (map var args) stmts
+call = CallExpr ()
+string = StringLit ()
+
+dotSep vars =
+ case vars of
+ x:xs -> foldl (DotRef ()) (ref x) (map var xs)
+ [] -> error "dotSep must be called on a non-empty list of variables"
+
+obj = dotSep . split
+
+equal a b = InfixExpr () OpStrictEq a b
+instanceof tipe x =
+ InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))
+typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)
+member field x = InfixExpr () OpIn (string field) x
diff --git a/compiler/Generate/JavaScript/Ports.hs b/compiler/Generate/JavaScript/Ports.hs
new file mode 100644
index 0000000..e9d5af7
--- /dev/null
+++ b/compiler/Generate/JavaScript/Ports.hs
@@ -0,0 +1,130 @@
+{-# OPTIONS_GHC -W #-}
+module Generate.JavaScript.Ports (incoming, outgoing) where
+
+import Generate.JavaScript.Helpers
+import qualified SourceSyntax.Helpers as Help
+import SourceSyntax.Type as T
+import Language.ECMAScript3.Syntax
+
+data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]
+ deriving Show
+
+check :: Expression () -> JSType -> Expression () -> Expression ()
+check x jsType continue =
+ CondExpr () (jsFold OpLOr checks x) continue throw
+ where
+ jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)
+ throw = obj "_E.raise" <| InfixExpr () OpAdd msg x
+ msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")
+ checks = case jsType of
+ JSNumber -> [typeof "number"]
+ JSBoolean -> [typeof "boolean"]
+ JSString -> [typeof "string", instanceof "String"]
+ JSArray -> [instanceof "Array"]
+ JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]
+
+incoming :: Type -> Expression ()
+incoming tipe =
+ case tipe of
+ Data "Signal.Signal" [t] ->
+ obj "Native.Ports.incomingSignal" <| incoming t
+ _ -> ["v"] ==> inc tipe (ref "v")
+
+inc :: Type -> Expression () -> Expression ()
+inc tipe x =
+ 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 []
+ | ctor == "Int" -> elm JSNumber
+ | ctor == "Float" -> elm JSNumber
+ | ctor == "Bool" -> elm JSBoolean
+ | ctor == "String" -> elm JSString
+ | ctor == "JavaScript.JSNumber" -> js JSNumber
+ | ctor == "JavaScript.JSBool" -> js JSBoolean
+ | ctor == "JavaScript.JSString" -> js JSString
+ where
+ elm checks = check x checks (obj ("_J.to" ++ ctor) <| x)
+ js checks = check x checks x
+
+ Data ctor [t]
+ | ctor == "Maybe.Maybe" ->
+ CondExpr () (equal x (NullLit ()))
+ (obj "Maybe.Nothing")
+ (obj "Maybe.Just" <| inc t x)
+
+ | ctor == "_List" ->
+ check x JSArray (obj "_J.toList" <| array)
+ where
+ array = DotRef () x (var "map") <| incoming t
+
+ Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
+ where
+ tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
+ values = zipWith convert [0..] ts
+ convert n t = ( PropId () $ var ('_':show n)
+ , inc t (BracketRef () x (IntLit () n)))
+
+ Data _ _ -> error "bad ADT 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
+ where
+ object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
+ keys = map convert fields
+ convert (f,t) = (PropId () (var f), inc t (DotRef () x (var f)))
+
+outgoing tipe =
+ case tipe of
+ Data "Signal.Signal" [t] ->
+ obj "Native.Ports.outgoingSignal" <| outgoing t
+ _ -> ["v"] ==> out tipe (ref "v")
+
+out :: Type -> Expression () -> Expression ()
+out tipe x =
+ case tipe of
+ Lambda _ _
+ | numArgs > 1 && numArgs < 10 ->
+ func (ref ('A':show numArgs) `call` (x:values))
+ | otherwise -> func (foldl (<|) x values)
+ where
+ ts = T.collectLambdas tipe
+ numArgs = length ts - 1
+ args = map (\n -> '_' : show n) [0..]
+ values = zipWith inc (init ts) (map ref args)
+ func body = function (take numArgs args)
+ [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
+ , ret (out (last ts) (ref "_r"))
+ ]
+
+ Var _ -> error "type variables should not be allowed through input ports"
+ Data ctor []
+ | ctor `elem` ["Int","Float","Bool","String"] -> obj ("_J.from" ++ ctor) <| x
+ | ctor `elem` jsPrims -> x
+ where
+ jsPrims = map ("JavaScript.JS"++) ["Number","Bool","String"]
+
+ Data ctor [t]
+ | ctor == "Maybe.Maybe" ->
+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
+ (NullLit ())
+ (DotRef () x (var "_0"))
+
+ | ctor == "_List" ->
+ DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
+
+ Data ctor ts | Help.isTuple ctor ->
+ ArrayLit () $ zipWith convert [0..] ts
+ where
+ convert n t = out t $ DotRef () x $ var ('_':show n)
+
+ Data _ _ -> error "bad ADT got to port generation code"
+
+ Record _ (Just _) -> error "bad record got to port generation code"
+
+ Record fields Nothing ->
+ ObjectLit () keys
+ where
+ keys = map convert fields
+ convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))
diff --git a/compiler/Generate/Noscript.hs b/compiler/Generate/Noscript.hs
index 4560382..7de4373 100644
--- a/compiler/Generate/Noscript.hs
+++ b/compiler/Generate/Noscript.hs
@@ -1,35 +1,34 @@
module Generate.Noscript (noscript) where
import Data.List (isInfixOf)
-import SourceSyntax.Declaration (Declaration(..))
+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 :: Module t v -> String
+noscript :: Extract def => Module def -> String
noscript modul = concat (extract modul)
class Extract a where
extract :: a -> [String]
-instance Extract (Module t v) where
+instance Extract def => Extract (Module def) where
extract (Module _ _ _ stmts) =
map (\s -> "" ++ s ++ "
") (concatMap extract stmts)
-instance Extract (Declaration t v) where
- extract (Definition d) = extract d
+instance Extract def => Extract (D.Declaration' port def) where
+ extract (D.Definition d) = extract d
extract _ = []
-instance Extract (Def t v) where
- extract (Def _ e) = extract e
- extract _ = []
+instance Extract Def where
+ extract (Definition _ e _) = extract e
instance Extract e => Extract (Located e) where
extract (L _ e) = extract e
-instance Extract (Expr t v) where
+instance Extract def => Extract (Expr' def) where
extract expr =
let f = extract in
case expr of
diff --git a/compiler/InterfaceSerialization.hs b/compiler/InterfaceSerialization.hs
deleted file mode 100644
index 83e0c70..0000000
--- a/compiler/InterfaceSerialization.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-module InterfaceSerialization ( loadInterface
- , interfaceDecode
- , validVersion
- ) where
-
-import qualified Data.ByteString.Lazy as L
-import qualified Data.Binary as Binary
-
-import qualified Elm.Internal.Version as Version
-import System.Directory (doesFileExist)
-import System.IO (hPutStrLn, stderr)
-import System.Exit (exitFailure)
-
-import SourceSyntax.Module
-
-loadInterface :: FilePath -> IO (Either String L.ByteString)
-loadInterface filePath = do
- exists <- doesFileExist filePath
- if exists
- then do
- byteString <- L.readFile filePath
- return $ Right byteString
-
- else
- return $ Left $ "Unable to find file " ++ filePath ++
- " for deserialization!"
-
-interfaceDecode :: Binary.Binary a =>
- FilePath -> L.ByteString -> Either String a
-interfaceDecode filePath bytes = do
- case Binary.decodeOrFail bytes of
- Right (_, _, binaryInfo) -> Right binaryInfo
-
- Left (_, offset, err) ->
- Left $ concat [ "Error reading build artifact: ", filePath, "\n"
- , " The exact error was '", err, "' at offset ", show offset, ".\n"
- , " The file was generated by a previous build and may be outdated or corrupt.\n"
- , " Please remove the file and try again."
- ]
-
-validVersion :: FilePath -> (String, ModuleInterface) ->
- Either String (String, ModuleInterface)
-validVersion filePath (name, interface) =
- if iVersion interface == Version.elmVersion then
- Right (name, interface)
- else
- Left $ concat
- [ "Error reading build artifact: ", filePath, "\n"
- , " It was generated by a different version of the compiler: "
- , show (iVersion interface), "\n"
- , " Please remove the file and try again.\n"
- ]
diff --git a/compiler/Metadata/Prelude.hs b/compiler/Metadata/Prelude.hs
index 3b88d5a..28d32e9 100644
--- a/compiler/Metadata/Prelude.hs
+++ b/compiler/Metadata/Prelude.hs
@@ -1,70 +1,59 @@
+{-# OPTIONS_GHC -W #-}
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.Directory
import System.Exit
-import System.FilePath
import System.IO
import SourceSyntax.Module
-import qualified Data.Binary as Binary
-import qualified Data.ByteString.Lazy as BS
+import qualified Build.Interface as Interface
-import qualified InterfaceSerialization as IS
-
-add :: Module t v -> Module t v
-add (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts
+add :: Bool -> Module def -> Module def
+add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
where
- customIms = concatMap addModule prelude
+ customIms = if noPrelude then [] else concatMap addModule prelude
addModule (n, method) = case lookup n ims of
Nothing -> [(n, method)]
- Just (As m) -> [(n, method)]
+ Just (As _) -> [(n, method)]
Just _ -> []
prelude :: [(String, ImportMethod)]
-prelude = text ++ map (\n -> (n, Hiding [])) modules
+prelude = string : text ++ map (\n -> (n, Hiding [])) modules
where
text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
+ string = ("String", As "String")
modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
- , "Graphics.Element", "Color", "Graphics.Collage" ]
+ , "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]
-interfaces :: IO Interfaces
-interfaces = safeReadDocs =<< Path.getDataFileName "interfaces.data"
+interfaces :: Bool -> IO Interfaces
+interfaces noPrelude =
+ if noPrelude
+ then return $ Map.empty
+ else safeReadDocs =<< Path.getDataFileName "interfaces.data"
safeReadDocs :: FilePath -> IO Interfaces
safeReadDocs name =
E.catch (readDocs name) $ \err -> do
let _ = err :: IOError
- putStrLn $ unlines [ "Error reading types for standard library!"
- , " The file should be at " ++ name
- , " If you are using a stable version of Elm,"
- , " please report an issue at github.com/evancz/Elm"
- , " and specify your versions of Elm and your OS" ]
+ hPutStrLn stderr $ unlines $
+ [ "Error reading types for standard library from file " ++ name
+ , " If you are using a stable version of Elm, please report an issue at"
+ , " specifying version numbers for"
+ , " Elm and your OS." ]
exitFailure
-firstModuleInterface :: [(String, ModuleInterface)] ->
- Either String (String, ModuleInterface)
-firstModuleInterface interfaces =
- case interfaces of
- [] -> Left "No interfaces found in serialized Prelude!"
- iface:_ -> Right iface
-
readDocs :: FilePath -> IO Interfaces
readDocs filePath = do
- bytes <- IS.loadInterface filePath
- let interfaces = IS.interfaceDecode filePath =<< bytes
-
- -- Although every ModuleInterface that is deserialized in this collection
- -- contains the compiler version, we only check the first ModuleInterface
- -- since it doesn't make sense that different modules in Prelude would
- -- have been compiled by different compiler versions.
- isValid = IS.validVersion filePath =<< firstModuleInterface =<< interfaces
-
- case (interfaces, isValid) of
- (_, Left err) -> do
+ interfaces <- Interface.load filePath
+ case mapM (Interface.isValid filePath) (interfaces :: [(String, ModuleInterface)]) of
+ Left err -> do
hPutStrLn stderr err
exitFailure
- (Right ifaces, _) -> return $ Map.fromList ifaces
+ Right [] -> do
+ hPutStrLn stderr "No interfaces found in serialized Prelude!"
+ exitFailure
+
+ Right ifaces -> return $ Map.fromList ifaces
diff --git a/compiler/Parse/Binop.hs b/compiler/Parse/Binop.hs
index 375ff22..2027172 100644
--- a/compiler/Parse/Binop.hs
+++ b/compiler/Parse/Binop.hs
@@ -1,12 +1,11 @@
module Parse.Binop (binops, OpTable) where
import Control.Applicative ((<$>))
-import Control.Monad.Error
import Data.List (intercalate)
import qualified Data.Map as Map
import SourceSyntax.Location (merge)
-import SourceSyntax.Expression (LExpr, Expr(Binop))
+import qualified SourceSyntax.Expression as E
import SourceSyntax.Declaration (Assoc(..))
import Text.Parsec
import Parse.Helpers
@@ -17,13 +16,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, LExpr t v) -> Bool
+hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
hasLevel table n (op,_) = opLevel table op == n
-binops :: IParser (LExpr t v)
- -> IParser (LExpr t v)
+binops :: IParser E.LParseExpr
+ -> IParser E.LParseExpr
-> IParser String
- -> IParser (LExpr t v)
+ -> IParser E.LParseExpr
binops term last anyOp =
do e <- term
table <- getState
@@ -39,9 +38,9 @@ binops term last anyOp =
split :: OpTable
-> Int
- -> LExpr t v
- -> [(String, LExpr t v)]
- -> IParser (LExpr t v)
+ -> E.LParseExpr
+ -> [(String, E.LParseExpr)]
+ -> IParser E.LParseExpr
split _ _ e [] = return e
split table n e eops = do
assoc <- getAssoc table n eops
@@ -50,26 +49,26 @@ split table n e eops = do
case assoc of R -> joinR es ops
_ -> joinL es ops
-splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]
- -> [IParser (LExpr t v)]
+splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
+ -> [IParser E.LParseExpr]
splitLevel table n e eops =
case break (hasLevel table n) eops of
(lops, (op,e'):rops) ->
split table (n+1) e lops : splitLevel table n e' rops
(lops, []) -> [ split table (n+1) e lops ]
-joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)
+joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
joinL [e] [] = return e
-joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops
+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 :: [LExpr t v] -> [String] -> IParser (LExpr t v)
+joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
joinR [e] [] = return e
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
- return (merge a e (Binop op a e))
+ return (merge a e (E.Binop op a e))
joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
-getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc
+getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc
getAssoc table n eops
| all (==L) assocs = return L
| all (==R) assocs = return R
diff --git a/compiler/Parse/Declaration.hs b/compiler/Parse/Declaration.hs
index 3c02339..90f13e5 100644
--- a/compiler/Parse/Declaration.hs
+++ b/compiler/Parse/Declaration.hs
@@ -1,36 +1,36 @@
-
+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
module Parse.Declaration where
-import Control.Applicative ((<$>), (<*>))
-import qualified Data.List as List
-import qualified Data.Set as Set
+import Control.Applicative ((<$>))
import Text.Parsec hiding (newline,spaces)
-import Text.Parsec.Indent
import Parse.Helpers
import qualified Parse.Expression as Expr
-import qualified SourceSyntax.Type as T
import qualified Parse.Type as Type
-import SourceSyntax.Declaration (Declaration(..), Assoc(..))
+import qualified SourceSyntax.Declaration as D
-declaration :: IParser (Declaration t v)
-declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition
+declaration :: IParser D.ParseDeclaration
+declaration = alias <|> datatype <|> infixDecl <|> port <|> definition
-definition :: IParser (Declaration t v)
-definition = Definition <$> Expr.def
+definition :: IParser D.ParseDeclaration
+definition = D.Definition <$> Expr.def
-alias :: IParser (Declaration t v)
+alias :: IParser D.ParseDeclaration
alias = do
reserved "type" "type alias (type Point = {x:Int, y:Int})"
forcedWS
- alias <- capVar
- args <- spacePrefix lowVar
+ name <- capVar
+ args <- spacePrefix lowVar
padded equals
tipe <- Type.expr
- return (TypeAlias alias args tipe)
+ json <- option [] $ do
+ try $ padded (reserved "deriving")
+ string "Json"
+ return [D.Json]
+ return (D.TypeAlias name args tipe json)
-datatype :: IParser (Declaration t v)
+datatype :: IParser D.ParseDeclaration
datatype = do
reserved "data" "datatype definition (data T = A | B | ...)"
forcedWS
@@ -38,81 +38,26 @@ datatype = do
args <- spacePrefix lowVar
padded equals
tcs <- pipeSep1 Type.constructor
- return $ Datatype name args tcs
+ return $ D.Datatype name args tcs []
-infixDecl :: IParser (Declaration t v)
+infixDecl :: IParser D.ParseDeclaration
infixDecl = do
- assoc <- choice [ reserved "infixl" >> return L
- , reserved "infix" >> return N
- , reserved "infixr" >> return R ]
+ assoc <- choice [ reserved "infixl" >> return D.L
+ , reserved "infix" >> return D.N
+ , reserved "infixr" >> return D.R ]
forcedWS
n <- digit
forcedWS
- Fixity assoc (read [n]) <$> anyOp
+ D.Fixity assoc (read [n]) <$> anyOp
-foreignDef :: IParser (Declaration t v)
-foreignDef = do
- try (reserved "foreign")
- whitespace
- importEvent <|> exportEvent
-
-exportEvent :: IParser (Declaration t v)
-exportEvent = do
- try (reserved "export") >> padded (reserved "jsevent")
- eventName <- jsVar
- whitespace
- elmVar <- lowVar
- padded hasType
- tipe <- Type.expr
- case tipe of
- T.Data "Signal" [t] ->
- case isExportable t of
- Nothing -> return (ExportEvent eventName elmVar tipe)
- Just err -> fail err
- _ -> fail "When importing foreign events, the imported value must have type Signal."
-
-importEvent :: IParser (Declaration t v)
-importEvent = do
- try (reserved "import") >> padded (reserved "jsevent")
- eventName <- jsVar
- baseValue <- padded Expr.term
- "Base case for imported signal (signals cannot be undefined)"
- elmVar <- lowVar "Name of imported signal"
- padded hasType
- tipe <- Type.expr
- case tipe of
- T.Data "Signal" [t] ->
- case isExportable t of
- Nothing -> return (ImportEvent eventName baseValue elmVar tipe)
- Just err -> fail err
- _ -> fail "When importing foreign events, the imported value must have type Signal."
-
-jsVar :: IParser String
-jsVar = betwixt '"' '"' $ do
- v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')
- if Set.notMember v jsReserveds then return v else
- fail $ "'" ++ v ++
- "' is not a good name for a importing or exporting JS values."
-
-isExportable tipe =
- case tipe of
- T.Lambda _ _ ->
- Just $ "Elm's JavaScript event interface does not yet handle functions. " ++
- "Only simple values can be imported and exported in this release."
-
- T.Data "JSArray" [t] -> isExportable t
-
- T.Data name []
- | any (`List.isSuffixOf` name) jsTypes -> Nothing
- | otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg
-
- T.Data name _ ->
- Just $ "'" ++ name ++ "' is not an exportable type " ++
- "constructor. Only 'JSArray' is an exportable container."
-
- T.Var _ -> Just $ "Cannot export type variables." ++ msg
- where
- msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes
- jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
+port :: IParser D.ParseDeclaration
+port =
+ do try (reserved "port")
+ whitespace
+ name <- lowVar
+ whitespace
+ let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }
+ D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr
+ , port' equals D.PPDef Expr.expr ]
\ No newline at end of file
diff --git a/compiler/Parse/Expression.hs b/compiler/Parse/Expression.hs
index b00fe30..4d37946 100644
--- a/compiler/Parse/Expression.hs
+++ b/compiler/Parse/Expression.hs
@@ -1,6 +1,5 @@
-module Parse.Expression (def,term,typeAnnotation) where
+module Parse.Expression (def,term,typeAnnotation,expr) where
-import Control.Arrow ((***))
import Control.Applicative ((<$>), (<*>))
import Data.List (foldl')
import Text.Parsec hiding (newline,spaces)
@@ -16,26 +15,25 @@ import SourceSyntax.Location as Location
import SourceSyntax.Pattern hiding (tuple,list)
import qualified SourceSyntax.Literal as Literal
import SourceSyntax.Expression
-import SourceSyntax.Declaration (Declaration(Definition))
-------- Basic Terms --------
-varTerm :: IParser (Expr t v)
+varTerm :: IParser ParseExpr
varTerm = toVar <$> var "variable"
-toVar :: String -> Expr t v
+toVar :: String -> ParseExpr
toVar v = case v of "True" -> Literal (Literal.Boolean True)
"False" -> Literal (Literal.Boolean False)
_ -> Var v
-accessor :: IParser (Expr t v)
+accessor :: IParser ParseExpr
accessor = do
(start, lbl, end) <- located (try (string "." >> rLabel))
let loc e = Location.at start end e
return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
-negative :: IParser (Expr t v)
+negative :: IParser ParseExpr
negative = do
(start, nTerm, end) <-
located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
@@ -45,7 +43,7 @@ negative = do
-------- Complex Terms --------
-listTerm :: IParser (Expr t v)
+listTerm :: IParser ParseExpr
listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
where
range = do
@@ -68,7 +66,7 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
string "}}"
return (md ++ span uid (length exprs), exprs ++ [e])
-parensTerm :: IParser (LExpr t v)
+parensTerm :: IParser LParseExpr
parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
where
opFn = do
@@ -91,7 +89,7 @@ parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
[e] -> e
_ -> Location.at start end (tuple es)
-recordTerm :: IParser (LExpr t v)
+recordTerm :: IParser LParseExpr
recordTerm = brackets $ choice [ misc, addLocation record ]
where field = do
label <- rLabel
@@ -124,14 +122,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]
Nothing -> try (insert record) <|> try (modify record)
-term :: IParser (LExpr t v)
+term :: IParser LParseExpr
term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
"basic term (4, x, 'c', etc.)"
-------- Applications --------
-appExpr :: IParser (LExpr t v)
+appExpr :: IParser LParseExpr
appExpr = do
t <- term
ts <- constrainedSpacePrefix term $ \str ->
@@ -142,12 +140,12 @@ appExpr = do
-------- Normal Expressions --------
-binaryExpr :: IParser (LExpr t v)
+binaryExpr :: IParser LParseExpr
binaryExpr = binops appExpr lastExpr anyOp
where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr
-ifExpr :: IParser (Expr t v)
+ifExpr :: IParser ParseExpr
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
where
normal = do
@@ -163,7 +161,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
b <- expr ; padded arrow
(,) b <$> expr
-lambdaExpr :: IParser (LExpr t v)
+lambdaExpr :: IParser LParseExpr
lambdaExpr = do char '\\' <|> char '\x03BB' "anonymous function"
whitespace
args <- spaceSep1 Pattern.term
@@ -171,17 +169,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' "anonymous function"
body <- expr
return (makeFunction args body)
-defSet :: IParser [Def t v]
+defSet :: IParser [ParseDef]
defSet = block (do d <- def ; whitespace ; return d)
-letExpr :: IParser (Expr t v)
+letExpr :: IParser ParseExpr
letExpr = do
reserved "let" ; whitespace
defs <- defSet
padded (reserved "in")
Let defs <$> expr
-caseExpr :: IParser (Expr t v)
+caseExpr :: IParser ParseExpr
caseExpr = do
reserved "case"; e <- padded expr; reserved "of"; whitespace
Case e <$> (with <|> without)
@@ -191,6 +189,7 @@ caseExpr = do
with = brackets (semiSep1 (case_ "cases { x -> ... }"))
without = block (do c <- case_ ; whitespace ; return c)
+expr :: IParser LParseExpr
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr
<|> binaryExpr
@@ -206,7 +205,7 @@ defStart =
where
func pattern =
case pattern of
- PVar v -> (pattern:) <$> spacePrefix Pattern.term
+ PVar _ -> (pattern:) <$> spacePrefix Pattern.term
_ -> do try (lookAhead (whitespace >> string "="))
return [pattern]
@@ -216,18 +215,18 @@ defStart =
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
else [ PVar (o:p), p1, p2 ]
-makeFunction :: [Pattern] -> LExpr t v -> LExpr t v
+makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
makeFunction args body@(L s _) =
foldr (\arg body' -> L s $ Lambda arg body') body args
-definition :: IParser (Def t v)
+definition :: IParser ParseDef
definition = withPos $ do
(name:args) <- defStart
padded equals
body <- expr
return . Def name $ makeFunction args body
-typeAnnotation :: IParser (Def t v)
+typeAnnotation :: IParser ParseDef
typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
where
start = do
@@ -235,5 +234,5 @@ typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
padded hasType
return v
-def :: IParser (Def t v)
+def :: IParser ParseDef
def = typeAnnotation <|> definition
diff --git a/compiler/Parse/Helpers.hs b/compiler/Parse/Helpers.hs
index 6f18718..bdedc77 100644
--- a/compiler/Parse/Helpers.hs
+++ b/compiler/Parse/Helpers.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Parse.Helpers where
import Prelude hiding (until)
@@ -7,13 +8,15 @@ import Control.Monad.State
import Data.Char (isUpper)
import qualified Data.Set as Set
import qualified Data.Map as Map
+import Text.Parsec hiding (newline,spaces,State)
+import Text.Parsec.Indent
+import qualified Text.Parsec.Token as T
+
import SourceSyntax.Helpers as Help
import SourceSyntax.Location as Location
import SourceSyntax.Expression
import SourceSyntax.PrettyPrint
import SourceSyntax.Declaration (Assoc)
-import Text.Parsec hiding (newline,spaces,State)
-import Text.Parsec.Indent
reserveds = [ "if", "then", "else"
, "case", "of"
@@ -22,7 +25,7 @@ reserveds = [ "if", "then", "else"
, "module", "where"
, "import", "as", "hiding", "open"
, "export", "foreign"
- , "deriving" ]
+ , "deriving", "port" ]
jsReserveds :: Set.Set String
jsReserveds = Set.fromList
@@ -45,7 +48,8 @@ jsReserveds = Set.fromList
expecting = flip ()
type OpTable = Map.Map String (Int, Assoc)
-type IParser a = ParsecT String OpTable (State SourcePos) a
+type SourceM = State SourcePos
+type IParser a = ParsecT String OpTable SourceM a
iParse :: IParser a -> String -> Either ParseError a
iParse = iParseWithTable "" Map.empty
@@ -54,23 +58,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE
iParseWithTable sourceName table aParser input =
runIndent sourceName $ runParserT aParser table sourceName input
-readMaybe :: Read a => String -> Maybe a
-readMaybe s =
- case [ x | (x,t) <- reads s, ("","") <- lex t ] of
- [x] -> Just x
- _ -> Nothing
-
-backslashed :: IParser Char
-backslashed = do
- char '\\'
- c <- anyChar
- case readMaybe ['\'','\\',c,'\''] of
- Just chr -> return chr
- Nothing ->
- fail $ "Did not recognize character '\\" ++ [c] ++
- "'. If the backslash is meant to be a character of its own, " ++
- "it should be escaped like this: \"\\\\" ++ [c] ++ "\""
-
var :: IParser String
var = makeVar (letter <|> char '_' "variable")
@@ -206,7 +193,7 @@ located p = do
end <- getPosition
return (start, e, end)
-accessible :: IParser (LExpr t v) -> IParser (LExpr t v)
+accessible :: IParser LParseExpr -> IParser LParseExpr
accessible expr = do
start <- getPosition
ce@(L _ e) <- expr
@@ -325,24 +312,73 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
closeMarkdown (md ++ [c]) stuff
]
-str :: IParser String
-str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote
- , liftM dewindows . expecting "string" . betwixt '"' '"' . many $
- backslashed <|> satisfy (/='"')
- ]
- where
- quote = try (string "\"\"\"")
+--str :: IParser String
+str = expecting "String" $ do
+ s <- choice [ multiStr, singleStr ]
+ processAs T.stringLiteral . sandwich '\"' $ concat s
+ where
+ rawString quote insides =
+ quote >> manyTill insides quote
- -- Remove \r from strings to fix generated JavaScript
- dewindows [] = []
- dewindows cs =
- let (pre, suf) = break (`elem` ['\r','\n']) cs
- in pre ++ case suf of
- ('\r':'\n':rest) -> '\n' : dewindows rest
- ('\n':rest) -> '\n' : dewindows rest
- ('\r':rest) -> '\n' : dewindows rest
- _ -> []
+ multiStr = rawString (try (string "\"\"\"")) multilineStringChar
+ singleStr = rawString (char '"') stringChar
+
+ stringChar :: IParser String
+ stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]
+
+ multilineStringChar :: IParser String
+ multilineStringChar =
+ do noEnd
+ choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]
+ where
+ noEnd = notFollowedBy (string "\"\"\"")
+ expandQuote c = if c == '\"' then "\\\"" else [c]
+
+ newlineChar :: IParser String
+ newlineChar =
+ choice [ char '\n' >> return "\\n"
+ , char '\r' >> return "\\r" ]
+
+sandwich :: Char -> String -> String
+sandwich delim s = delim : s ++ [delim]
+
+escaped :: Char -> IParser String
+escaped delim = try $ do
+ char '\\'
+ c <- char '\\' <|> char delim
+ return ['\\', c]
chr :: IParser Char
-chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
- "character"
\ No newline at end of file
+chr = betwixt '\'' '\'' character "character"
+ where
+ nonQuote = satisfy (/='\'')
+ character = do
+ c <- choice [ escaped '\''
+ , (:) <$> char '\\' <*> many1 nonQuote
+ , (:[]) <$> nonQuote ]
+ processAs T.charLiteral $ sandwich '\'' c
+
+processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a
+processAs processor s = calloutParser s (processor lexer)
+ where
+ calloutParser :: String -> IParser a -> IParser a
+ calloutParser inp p = either (fail . show) return (iParse p inp)
+
+ lexer :: T.GenTokenParser String u SourceM
+ lexer = T.makeTokenParser elmDef
+
+ -- I don't know how many of these are necessary for charLiteral/stringLiteral
+ elmDef :: T.GenLanguageDef String u SourceM
+ elmDef = T.LanguageDef
+ { T.commentStart = "{-"
+ , T.commentEnd = "-}"
+ , T.commentLine = "--"
+ , T.nestedComments = True
+ , T.identStart = undefined
+ , T.identLetter = undefined
+ , T.opStart = undefined
+ , T.opLetter = undefined
+ , T.reservedNames = reserveds
+ , T.reservedOpNames = [":", "->", "<-", "|"]
+ , T.caseSensitive = True
+ }
diff --git a/compiler/Parse/Literal.hs b/compiler/Parse/Literal.hs
index 65b53b9..93ef428 100644
--- a/compiler/Parse/Literal.hs
+++ b/compiler/Parse/Literal.hs
@@ -1,13 +1,12 @@
+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
module Parse.Literal (literal) where
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad
+import Control.Applicative ((<$>))
import Text.Parsec hiding (newline,spaces)
-import Text.Parsec.Indent
-
import Parse.Helpers
import SourceSyntax.Literal
+literal :: IParser Literal
literal = num <|> (Str <$> str) <|> (Chr <$> chr)
num :: IParser Literal
diff --git a/compiler/Parse/Module.hs b/compiler/Parse/Module.hs
index 3d342d4..10bf9fb 100644
--- a/compiler/Parse/Module.hs
+++ b/compiler/Parse/Module.hs
@@ -1,4 +1,3 @@
-
module Parse.Module (moduleDef, getModuleName, imports) where
import Control.Applicative ((<$>), (<*>))
@@ -6,7 +5,7 @@ import Data.List (intercalate)
import Text.Parsec hiding (newline,spaces)
import Parse.Helpers
-import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)
+import SourceSyntax.Module (ImportMethod(..), Imports)
varList :: IParser [String]
varList = parens $ commaSep1 (var <|> parens symOp)
diff --git a/compiler/Parse/Parse.hs b/compiler/Parse/Parse.hs
index afff7da..d5c0e2a 100644
--- a/compiler/Parse/Parse.hs
+++ b/compiler/Parse/Parse.hs
@@ -1,22 +1,19 @@
+{-# OPTIONS_GHC -W #-}
module Parse.Parse (program, dependencies) where
import Control.Applicative ((<$>), (<*>))
-import Control.Monad
-import Data.Char (isSymbol, isDigit)
-import Data.List (foldl',intercalate)
+import qualified Data.List as List
import qualified Data.Map as Map
import Text.Parsec hiding (newline,spaces)
import qualified Text.PrettyPrint as P
-import qualified SourceSyntax.Module as S
-import SourceSyntax.Declaration (Declaration(Fixity))
+import qualified SourceSyntax.Declaration as D
+import qualified SourceSyntax.Module as M
import Parse.Helpers
-import Parse.Binop (OpTable)
-import Parse.Expression
import Parse.Declaration (infixDecl)
-import Parse.Type
import Parse.Module
import qualified Parse.Declaration as Decl
+import Transform.Declaration (combineAnnotations)
freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
freshLine
@@ -25,19 +22,25 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
decls = do d <- Decl.declaration "at least one datatype or variable definition"
(d:) <$> many freshDef
-program :: OpTable -> String -> Either [P.Doc] (S.Module t v)
-program table = setupParserWithTable table $ do
- optional freshLine
- (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
- is <- (do try (lookAhead $ reserved "import")
- imports `followedBy` freshLine) <|> return []
- declarations <- decls
- optional freshLine ; optional spaces ; eof
- return $ S.Module names exports is declarations
+program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)
+program table src =
+ do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src
+ decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)
+ return $ M.Module names exs ims decls
+
+programParser :: IParser (M.Module D.ParseDeclaration)
+programParser =
+ do optional freshLine
+ (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)
+ is <- (do try (lookAhead $ reserved "import")
+ imports `followedBy` freshLine) <|> return []
+ declarations <- decls
+ optional freshLine ; optional spaces ; eof
+ return $ M.Module names exports is declarations
dependencies :: String -> Either [P.Doc] (String, [String])
dependencies =
- let getName = intercalate "." . fst in
+ let getName = List.intercalate "." . fst in
setupParser $ do
optional freshLine
(,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)
@@ -56,12 +59,12 @@ setupParserWithTable table p source =
msg overlap =
P.vcat [ P.text "Parse error:"
, P.text $ "Overlapping definitions for infix operators: " ++
- intercalate " " (Map.keys overlap)
+ List.intercalate " " (Map.keys overlap)
]
parseFixities = do
decls <- onFreshLines (:) [] infixDecl
- return $ Map.fromList [ (op,(lvl,assoc)) | Fixity assoc lvl op <- decls ]
+ return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
setupParser :: IParser a -> String -> Either [P.Doc] a
setupParser p source =
diff --git a/compiler/Parse/Pattern.hs b/compiler/Parse/Pattern.hs
index 0ee9c6d..1bda7ac 100644
--- a/compiler/Parse/Pattern.hs
+++ b/compiler/Parse/Pattern.hs
@@ -1,13 +1,10 @@
-
+{-# OPTIONS_GHC -W #-}
module Parse.Pattern (term, expr) where
-import Control.Applicative ((<$>),(<*>),pure)
-import Control.Monad
-import Control.Monad.State
+import Control.Applicative ((<$>))
import Data.Char (isUpper)
import Data.List (intercalate)
import Text.Parsec hiding (newline,spaces,State)
-import Text.Parsec.Indent
import Parse.Helpers
import Parse.Literal
@@ -20,9 +17,10 @@ basic = choice
[ char '_' >> return PAnything
, do v <- var
return $ case v of
- "True" -> PLiteral (Boolean True)
- "False" -> PLiteral (Boolean False)
- c : _ -> if isUpper c then PData v [] else PVar v
+ "True" -> PLiteral (Boolean True)
+ "False" -> PLiteral (Boolean False)
+ c:_ | isUpper c -> PData v []
+ _ -> PVar v
, PLiteral <$> literal
]
diff --git a/compiler/Parse/Type.hs b/compiler/Parse/Type.hs
index 5c47340..6bd0680 100644
--- a/compiler/Parse/Type.hs
+++ b/compiler/Parse/Type.hs
@@ -1,11 +1,9 @@
+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
module Parse.Type where
-import Control.Applicative ((<$>),(<*>))
-import Control.Monad (liftM,mapM)
-import Data.Char (isLower)
-import Data.List (lookup,intercalate)
+import Control.Applicative ((<$>),(<*>),(<*))
+import Data.List (intercalate)
import Text.Parsec
-import Text.Parsec.Indent
import SourceSyntax.Type as T
import Parse.Helpers
@@ -25,23 +23,24 @@ tuple = do ts <- parens (commaSep expr)
record :: IParser T.Type
record =
do char '{' ; whitespace
- (ext,fs) <- extended <|> normal
+ rcrd <- extended <|> normal
dumbWhitespace ; char '}'
- return (T.Record fs ext)
+ return rcrd
where
- normal = (,) T.EmptyRecord <$> commaSep fields
+ normal = flip T.Record Nothing <$> commaSep field
-- extended record types require at least one field
extended = do
- ext <- try (const <$> tvar <*> (whitespace >> string "|"))
+ ext <- try (lowVar <* (whitespace >> string "|"))
whitespace
- (,) ext <$> commaSep1 fields
+ flip T.Record (Just ext) <$> commaSep1 field
- fields = do
+ field = do
lbl <- rLabel
whitespace >> hasType >> whitespace
(,) lbl <$> expr
+capTypeVar :: IParser String
capTypeVar = intercalate "." <$> dotSep1 capVar
constructor0 :: IParser T.Type
diff --git a/compiler/SourceSyntax/Declaration.hs b/compiler/SourceSyntax/Declaration.hs
index 22ec074..3d6d9be 100644
--- a/compiler/SourceSyntax/Declaration.hs
+++ b/compiler/SourceSyntax/Declaration.hs
@@ -1,21 +1,55 @@
+{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Declaration where
+import Data.Binary
import qualified SourceSyntax.Expression as Expr
-import SourceSyntax.Type
+import qualified SourceSyntax.Type as T
import SourceSyntax.PrettyPrint
import Text.PrettyPrint as P
-data Declaration tipe var
- = Definition (Expr.Def tipe var)
- | Datatype String [String] [(String,[Type])]
- | TypeAlias String [String] Type
- | ImportEvent String (Expr.LExpr tipe var) String Type
- | ExportEvent String String Type
+data Declaration' port def
+ = Definition def
+ | Datatype String [String] [(String,[T.Type])] [Derivation]
+ | TypeAlias String [String] T.Type [Derivation]
+ | Port port
| Fixity Assoc Int String
- deriving (Eq, Show)
+ deriving (Show)
data Assoc = L | N | R
- deriving (Eq)
+ deriving (Eq)
+
+data Derivation = Json | JS | Binary | New
+ deriving (Eq, Show)
+
+data ParsePort
+ = PPAnnotation String T.Type
+ | PPDef String Expr.LParseExpr
+ deriving (Show)
+
+data Port
+ = Out String Expr.LExpr T.Type
+ | In String T.Type
+ deriving (Show)
+
+type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
+type Declaration = Declaration' Port Expr.Def
+
+instance Binary Derivation where
+ get = do n <- getWord8
+ return $ case n of
+ 0 -> Json
+ 1 -> JS
+ 2 -> Binary
+ 3 -> New
+ _ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\
+ \so please report an issue at "
+
+ put derivation =
+ putWord8 $ case derivation of
+ Json -> 0
+ JS -> 1
+ Binary -> 2
+ New -> 3
instance Show Assoc where
show assoc =
@@ -24,24 +58,65 @@ instance Show Assoc where
N -> "non"
R -> "right"
-instance Pretty (Declaration t v) where
+instance Binary Assoc where
+ get = do n <- getWord8
+ return $ case n of
+ 0 -> L
+ 1 -> N
+ 2 -> R
+ _ -> error "Error reading valid associativity from serialized string"
+
+ put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }
+
+instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where
pretty decl =
case decl of
Definition def -> pretty def
- Datatype tipe tvars ctors ->
+ Datatype tipe tvars ctors deriveables ->
P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4
- (P.sep $ zipWith join ("=" : repeat "|") ctors)
+ (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables
where
join c ctor = P.text c <+> prettyCtor ctor
prettyCtor (name, tipes) =
- P.hang (P.text name) 2 (P.sep (map prettyParens tipes))
+ P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
- TypeAlias name tvars tipe ->
- let alias = P.text name <+> P.hsep (map P.text tvars) in
- P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)
+ TypeAlias name tvars tipe deriveables ->
+ alias <+> prettyDeriving deriveables
+ where
+ name' = P.text name <+> P.hsep (map P.text tvars)
+ alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
- -- TODO: Actually write out the contained data in these cases.
- ImportEvent _ _ _ _ -> P.text (show decl)
- ExportEvent _ _ _ -> P.text (show decl)
- Fixity _ _ _ -> P.text (show decl)
+ Port port -> pretty port
+
+ Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op
+ where
+ assoc' = case assoc of
+ L -> P.text "l"
+ N -> P.empty
+ R -> P.text "r"
+
+instance Pretty ParsePort where
+ pretty port =
+ case port of
+ PPAnnotation name tipe -> prettyPort name ":" tipe
+ PPDef name expr -> prettyPort name "=" expr
+
+instance Pretty Port where
+ pretty port =
+ case port of
+ In name tipe -> prettyPort name ":" tipe
+ Out name expr tipe -> P.vcat [ prettyPort name ":" tipe
+ , prettyPort name "=" expr ]
+
+
+prettyPort :: (Pretty a) => String -> String -> a -> Doc
+prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e
+
+prettyDeriving :: [Derivation] -> Doc
+prettyDeriving deriveables =
+ case deriveables of
+ [] -> P.empty
+ [d] -> P.text "deriving" <+> P.text (show d)
+ ds -> P.text "deriving" <+>
+ P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)
\ No newline at end of file
diff --git a/compiler/SourceSyntax/Expression.hs b/compiler/SourceSyntax/Expression.hs
index c11e690..781eb55 100644
--- a/compiler/SourceSyntax/Expression.hs
+++ b/compiler/SourceSyntax/Expression.hs
@@ -1,54 +1,106 @@
+{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Expression where
+{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.
+The first is the fully general version and is labeled with a prime (Expr').
+The others are specialized versions of the AST that represent specific phases
+of the compilation process. I expect there to be more phases as we begin to
+enrich the AST with more information.
+-}
+
-import Data.List (intercalate)
import SourceSyntax.PrettyPrint
import Text.PrettyPrint as P
import qualified SourceSyntax.Helpers as Help
import qualified SourceSyntax.Location as Location
import qualified SourceSyntax.Pattern as Pattern
-import qualified SourceSyntax.Type as Type
+import qualified SourceSyntax.Type as SrcType
import qualified SourceSyntax.Literal as Literal
-type LExpr tipe var = Location.Located (Expr tipe var)
-data Expr t v
+---- GENERAL AST ----
+
+{-| This is a located expression, meaning it is tagged with info about where it
+came from in the source code. Expr' is defined in terms of LExpr' so that the
+location information does not need to be an extra field on every constructor.
+-}
+type LExpr' def = Location.Located (Expr' def)
+
+{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
+"type holes" that allow us to enrich the AST with additional information as we
+move through the compilation process. The type holes let us show these
+structural changes in the types. The only type hole right now is:
+
+ def: Parsing allows two kinds of definitions (type annotations or definitions),
+ but later checks will see that they are well formed and combine them.
+
+-}
+data Expr' def
= Literal Literal.Literal
| Var String
- | Range (LExpr t v) (LExpr t v)
- | ExplicitList [LExpr t v]
- | Binop String (LExpr t v) (LExpr t v)
- | Lambda Pattern.Pattern (LExpr t v)
- | App (LExpr t v) (LExpr t v)
- | MultiIf [(LExpr t v,LExpr t v)]
- | Let [Def t v] (LExpr t v)
- | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]
- | Data String [LExpr t v]
- | Access (LExpr t v) String
- | Remove (LExpr t v) String
- | Insert (LExpr t v) String (LExpr t v)
- | Modify (LExpr t v) [(String, LExpr t v)]
- | Record [(String, LExpr t v)]
- | Markdown String String [LExpr t v]
- deriving (Eq)
+ | Range (LExpr' def) (LExpr' def)
+ | ExplicitList [LExpr' def]
+ | Binop String (LExpr' def) (LExpr' def)
+ | Lambda Pattern.Pattern (LExpr' def)
+ | App (LExpr' def) (LExpr' def)
+ | MultiIf [(LExpr' def,LExpr' def)]
+ | Let [def] (LExpr' def)
+ | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
+ | Data String [LExpr' def]
+ | Access (LExpr' def) String
+ | Remove (LExpr' def) String
+ | Insert (LExpr' def) String (LExpr' def)
+ | Modify (LExpr' def) [(String, LExpr' def)]
+ | Record [(String, LExpr' def)]
+ | Markdown String String [LExpr' def]
+ -- for type checking and code gen only
+ | PortIn String SrcType.Type
+ | PortOut String SrcType.Type (LExpr' def)
-data Def tipe var
- = Def Pattern.Pattern (LExpr tipe var)
- | TypeAnnotation String Type.Type
- deriving (Eq, Show)
+---- SPECIALIZED ASTs ----
+
+{-| Expressions created by the parser. These use a split representation of type
+annotations and definitions, which is how they appear in source code and how
+they are parsed.
+-}
+type ParseExpr = Expr' ParseDef
+type LParseExpr = LExpr' ParseDef
+
+data ParseDef
+ = Def Pattern.Pattern LParseExpr
+ | TypeAnnotation String SrcType.Type
+ deriving (Show)
+
+{-| "Normal" expressions. When the compiler checks that type annotations and
+ports are all paired with definitions in the appropriate order, it collapses
+them into a Def that is easier to work with in later phases of compilation.
+-}
+type LExpr = LExpr' Def
+type Expr = Expr' Def
+
+data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
+ deriving (Show)
+
+
+---- UTILITIES ----
+
+tuple :: [LExpr' def] -> Expr' def
tuple es = Data ("_Tuple" ++ show (length es)) es
+delist :: LExpr' def -> [LExpr' def]
delist (Location.L _ (Data "::" [h,t])) = h : delist t
delist _ = []
+saveEnvName :: String
saveEnvName = "_save_the_environment!!!"
+dummyLet :: Pretty def => [def] -> LExpr' def
dummyLet defs =
Location.none $ Let defs (Location.none $ Var saveEnvName)
-instance Show (Expr t v) where
+instance Pretty def => Show (Expr' def) where
show = render . pretty
-instance Pretty (Expr t v) where
+instance Pretty def => Pretty (Expr' def) where
pretty expr =
case expr of
Literal lit -> pretty lit
@@ -59,8 +111,10 @@ instance Pretty (Expr t v) where
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 ++ "`"
- Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
- in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
+ Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
+ where
+ (ps,body) = collectLambdas (Location.none $ Lambda p e)
+ args = P.sep (map Pattern.prettyParens ps)
App _ _ -> P.hang func 2 (P.sep args)
where func:args = map prettyParens (collectApps (Location.none expr))
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
@@ -73,51 +127,68 @@ instance Pretty (Expr t v) where
P.hang pexpr 2 (P.vcat (map pretty' pats))
where
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
- pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e
+ pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
Data "[]" [] -> P.text "[]"
- Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
+ 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.text "=" <+> pretty v)
+ P.braces (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.text "=" <+> pretty v)
+ P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
Modify e fs ->
P.braces $ P.hang (pretty e <+> P.text "|")
4
(commaSep $ map field fs)
where
- field (x,e) = variable x <+> P.text "<-" <+> pretty e
+ field (k,v) = variable k <+> P.text "<-" <+> pretty v
Record fs ->
P.braces $ P.nest 2 (commaSep $ map field fs)
where
- field (x,e) = variable x <+> P.text "=" <+> pretty e
+ field (x,e) = variable x <+> P.equals <+> pretty e
Markdown _ _ _ -> P.text "[markdown| ... |]"
-instance Pretty (Def t v) where
+ PortIn name _ -> P.text $ ""
+
+ PortOut _ _ signal -> pretty signal
+
+instance Pretty ParseDef where
pretty def =
case def of
TypeAnnotation name tipe ->
- variable name <+> P.text ":" <+> pretty tipe
+ variable name <+> P.colon <+> pretty tipe
Def pattern expr ->
- pretty pattern <+> P.text "=" <+> pretty expr
+ pretty pattern <+> P.equals <+> pretty expr
+instance Pretty Def where
+ pretty (Definition pattern expr maybeTipe) =
+ P.vcat [ annotation, definition ]
+ where
+ definition = pretty pattern <+> P.equals <+> pretty expr
+ annotation = case maybeTipe of
+ Nothing -> P.empty
+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
+
+collectApps :: LExpr' def -> [LExpr' def]
collectApps lexpr@(Location.L _ expr) =
case expr of
App a b -> collectApps a ++ [b]
_ -> [lexpr]
+collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
collectLambdas lexpr@(Location.L _ expr) =
case expr of
- Lambda pattern body ->
- let (ps, body') = collectLambdas body
- in (pretty pattern : ps, body')
+ Lambda pattern body -> (pattern : ps, body')
+ where (ps, body') = collectLambdas body
_ -> ([], lexpr)
+prettyParens :: (Pretty def) => LExpr' def -> Doc
prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
where
needed =
@@ -128,5 +199,5 @@ prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
MultiIf _ -> True
Let _ _ -> True
Case _ _ -> True
- Data name (x:xs) -> name /= "::"
+ Data name (_:_) -> name /= "::"
_ -> False
diff --git a/compiler/SourceSyntax/Helpers.hs b/compiler/SourceSyntax/Helpers.hs
index ab3449b..cbe1c18 100644
--- a/compiler/SourceSyntax/Helpers.hs
+++ b/compiler/SourceSyntax/Helpers.hs
@@ -1,4 +1,4 @@
-
+{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Helpers where
import qualified Data.Char as Char
diff --git a/compiler/SourceSyntax/Literal.hs b/compiler/SourceSyntax/Literal.hs
index a7bdb9d..818f610 100644
--- a/compiler/SourceSyntax/Literal.hs
+++ b/compiler/SourceSyntax/Literal.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Literal where
import SourceSyntax.PrettyPrint
@@ -8,13 +9,13 @@ data Literal = IntNum Int
| Chr Char
| Str String
| Boolean Bool
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show)
instance Pretty Literal where
pretty literal =
case literal of
IntNum n -> PP.int n
FloatNum n -> PP.double n
- Chr c -> PP.quotes (PP.char c)
- Str s -> PP.text (show s)
- Boolean bool -> PP.text (show bool)
\ No newline at end of file
+ Chr c -> PP.text . show $ c
+ Str s -> PP.text . show $ s
+ Boolean bool -> PP.text (show bool)
diff --git a/compiler/SourceSyntax/Module.hs b/compiler/SourceSyntax/Module.hs
index 09094df..63b36f7 100644
--- a/compiler/SourceSyntax/Module.hs
+++ b/compiler/SourceSyntax/Module.hs
@@ -1,21 +1,18 @@
+{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Module where
import Data.Binary
-import Data.List (intercalate)
import qualified Data.Map as Map
import Control.Applicative ((<$>), (<*>))
-import Control.Arrow (second)
import SourceSyntax.Expression (LExpr)
import SourceSyntax.Declaration
import SourceSyntax.Type
-import System.FilePath (joinPath)
-import Control.Monad (liftM)
import qualified Elm.Internal.Version as Version
-data Module tipe var =
- Module [String] Exports Imports [Declaration tipe var]
+data Module def =
+ Module [String] Exports Imports [def]
deriving (Show)
type Exports = [String]
@@ -25,48 +22,47 @@ data ImportMethod = As String | Importing [String] | Hiding [String]
deriving (Eq, Ord, Show)
instance Binary ImportMethod where
- put (As s) = do put (0 :: Word8)
- put s
-
- put (Importing ss) = do put (1 :: Word8)
- put ss
-
- put (Hiding ss) = do put (2 :: Word8)
- put ss
+ put method =
+ let put' n info = putWord8 n >> put info in
+ case method of
+ As s -> put' 0 s
+ Importing ss -> put' 1 ss
+ Hiding ss -> put' 2 ss
get = do tag <- getWord8
case tag of
- 0 -> liftM As get
- 1 -> liftM Importing get
- 2 -> liftM Hiding get
+ 0 -> As <$> get
+ 1 -> Importing <$> get
+ 2 -> Hiding <$> get
_ -> error "Error reading valid ImportMethod type from serialized string"
-data MetadataModule t v = MetadataModule {
- names :: [String],
- path :: FilePath,
- exports :: [String],
- imports :: [(String, ImportMethod)],
- program :: LExpr t v,
- types :: Map.Map String Type,
- fixities :: [(Assoc, Int, String)],
- aliases :: [(String, [String], Type)],
- datatypes :: [ (String, [String], [(String,[Type])]) ],
- foreignImports :: [(String, LExpr t v, String, Type)],
- foreignExports :: [(String, String, Type)]
-} deriving Show
+data MetadataModule =
+ MetadataModule
+ { names :: [String]
+ , path :: FilePath
+ , exports :: [String]
+ , imports :: [(String, ImportMethod)]
+ , program :: LExpr
+ , types :: Map.Map String Type
+ , fixities :: [(Assoc, Int, String)]
+ , aliases :: [Alias]
+ , datatypes :: [ADT]
+ } deriving Show
type Interfaces = Map.Map String ModuleInterface
-type ADT = (String, [String], [(String,[Type])])
+type ADT = (String, [String], [(String,[Type])], [Derivation])
+type Alias = (String, [String], Type, [Derivation])
data ModuleInterface = ModuleInterface {
iVersion :: Version.Version,
iTypes :: Map.Map String Type,
iImports :: [(String, ImportMethod)],
iAdts :: [ADT],
- iAliases :: [(String, [String], Type)],
+ iAliases :: [Alias],
iFixities :: [(Assoc, Int, String)]
} deriving Show
+metaToInterface :: MetadataModule -> ModuleInterface
metaToInterface metaModule =
ModuleInterface
{ iVersion = Version.elmVersion
@@ -86,14 +82,3 @@ instance Binary ModuleInterface where
put (iAdts modul)
put (iAliases modul)
put (iFixities modul)
-
-
-instance Binary Assoc where
- get = do n <- getWord8
- return $ case n of
- 0 -> L
- 1 -> N
- 2 -> R
- _ -> error "Error reading valid associativity from serialized string"
-
- put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }
diff --git a/compiler/SourceSyntax/Pattern.hs b/compiler/SourceSyntax/Pattern.hs
index 0328091..1dd4d46 100644
--- a/compiler/SourceSyntax/Pattern.hs
+++ b/compiler/SourceSyntax/Pattern.hs
@@ -1,9 +1,10 @@
+{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Pattern where
-import Data.List (intercalate)
-import SourceSyntax.Helpers as Help
+import qualified SourceSyntax.Helpers as Help
import SourceSyntax.PrettyPrint
import Text.PrettyPrint as PP
+import qualified Data.Set as Set
import SourceSyntax.Literal as Literal
data Pattern = PData String [Pattern]
@@ -14,11 +15,28 @@ data Pattern = PData String [Pattern]
| PLiteral Literal.Literal
deriving (Eq, Ord, Show)
+cons :: Pattern -> Pattern -> Pattern
cons h t = PData "::" [h,t]
-nil = PData "[]" []
+
+nil :: Pattern
+nil = PData "[]" []
+
+list :: [Pattern] -> Pattern
list = foldr cons nil
+
+tuple :: [Pattern] -> Pattern
tuple es = PData ("_Tuple" ++ show (length es)) es
+boundVars :: Pattern -> Set.Set String
+boundVars pattern =
+ case pattern of
+ PVar x -> Set.singleton x
+ PAlias x p -> Set.insert x (boundVars p)
+ PData _ ps -> Set.unions (map boundVars ps)
+ PRecord fields -> Set.fromList fields
+ PAnything -> Set.empty
+ PLiteral _ -> Set.empty
+
instance Pretty Pattern where
pretty pattern =
@@ -33,14 +51,15 @@ instance Pretty Pattern where
PData "::" _ -> True
_ -> False
PData name ps ->
- if isTuple name then
+ if Help.isTuple name then
PP.parens . commaCat $ map pretty ps
- else sep (PP.text name : map prettyParens ps)
+ else hsep (PP.text name : map prettyParens ps)
+prettyParens :: Pattern -> Doc
prettyParens pattern = parensIf needsThem (pretty pattern)
where
needsThem =
case pattern of
- PData name (_:_) | not (isTuple name) -> True
+ PData name (_:_) | not (Help.isTuple name) -> True
PAlias _ _ -> True
- _ -> False
\ No newline at end of file
+ _ -> False
diff --git a/compiler/SourceSyntax/Type.hs b/compiler/SourceSyntax/Type.hs
index 0a0b422..041ce70 100644
--- a/compiler/SourceSyntax/Type.hs
+++ b/compiler/SourceSyntax/Type.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module SourceSyntax.Type where
import Data.Binary
@@ -10,16 +11,15 @@ import Text.PrettyPrint as P
data Type = Lambda Type Type
| Var String
| Data String [Type]
- | EmptyRecord
- | Record [(String,Type)] Type
- deriving (Eq, Show)
+ | Record [(String,Type)] (Maybe String)
+ deriving (Eq)
fieldMap :: [(String,a)] -> Map.Map String [a]
fieldMap fields =
foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
recordOf :: [(String,Type)] -> Type
-recordOf fields = Record fields EmptyRecord
+recordOf fields = Record fields Nothing
listOf :: Type -> Type
listOf t = Data "_List" [t]
@@ -27,39 +27,39 @@ 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
- Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
- where t:ts = collectLambdas tipe
+ Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
+ where
+ t:ts = map prettyLambda (collectLambdas tipe)
+ prettyLambda t = case t of
+ Lambda _ _ -> P.parens (pretty t)
+ _ -> pretty t
+
Var x -> P.text x
Data "_List" [t] -> P.brackets (pretty t)
Data name tipes
| Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
| otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
- EmptyRecord -> P.braces P.empty
- Record _ _ -> P.braces $ case ext of
- EmptyRecord -> prettyFields
- _ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields
+ Record fields ext ->
+ P.braces $ case ext of
+ Nothing -> prettyFields
+ Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields
where
- (fields, ext) = collectRecords tipe
prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
prettyFields = commaSep . map prettyField $ fields
+collectLambdas :: Type -> [Type]
collectLambdas tipe =
case tipe of
- Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body
- Lambda arg body -> pretty arg : collectLambdas body
- _ -> [pretty tipe]
-
-collectRecords = go []
- where
- go fields tipe =
- case tipe of
- Record fs ext -> go (fs ++ fields) ext
- _ -> (fields, tipe)
+ Lambda arg body -> arg : collectLambdas body
+ _ -> [tipe]
+prettyParens :: Type -> Doc
prettyParens tipe = parensIf needed (pretty tipe)
where
needed =
@@ -79,10 +79,8 @@ instance Binary Type where
putWord8 1 >> put x
Data ctor tipes ->
putWord8 2 >> put ctor >> put tipes
- EmptyRecord ->
- putWord8 3
Record fs ext ->
- putWord8 4 >> put fs >> put ext
+ putWord8 3 >> put fs >> put ext
get = do
n <- getWord8
@@ -90,6 +88,5 @@ instance Binary Type where
0 -> Lambda <$> get <*> get
1 -> Var <$> get
2 -> Data <$> get <*> get
- 3 -> return EmptyRecord
- 4 -> Record <$> get <*> get
+ 3 -> Record <$> get <*> get
_ -> error "Error reading a valid type from serialized string"
diff --git a/compiler/SourceSyntax/Variable.hs b/compiler/SourceSyntax/Variable.hs
deleted file mode 100644
index c16ddca..0000000
--- a/compiler/SourceSyntax/Variable.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-module SourceSyntax.Variable where
-
diff --git a/compiler/Transform/Canonicalize.hs b/compiler/Transform/Canonicalize.hs
index 9cf6e59..03f5d28 100644
--- a/compiler/Transform/Canonicalize.hs
+++ b/compiler/Transform/Canonicalize.hs
@@ -1,7 +1,10 @@
+{-# OPTIONS_GHC -W #-}
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.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
@@ -9,10 +12,8 @@ import qualified Data.Either as Either
import SourceSyntax.Module
import SourceSyntax.Expression
import SourceSyntax.Location as Loc
-import SourceSyntax.Pattern
-import SourceSyntax.Helpers (isOp)
+import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as Type
-import qualified Transform.SortDefinitions as SD
import Text.PrettyPrint as P
interface :: String -> ModuleInterface -> ModuleInterface
@@ -26,11 +27,11 @@ interface moduleName iface =
, iFixities = iFixities iface -- cannot have canonicalized operators while parsing
}
where
- both f g (a,b,c) = (f a, b, g c)
+ both f g (a,b,c,d) = (f a, b, g c, d)
prefix name = moduleName ++ "." ++ name
pair name = (name, moduleName ++ "." ++ name)
- canon (name,_,_) = pair name
+ canon (name,_,_,_) = pair name
canons = Map.fromList $ concat
[ map canon (iAdts iface), map canon (iAliases iface) ]
@@ -39,48 +40,40 @@ interface moduleName iface =
renameType' =
runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)
-renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type
-renameType rename tipe =
- let rnm = renameType rename in
+renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type
+renameType renamer tipe =
+ let rnm = renameType renamer in
case tipe of
- Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b
- Type.Var x -> return tipe
- Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts
- Type.EmptyRecord -> return tipe
- Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext
- where rnm' (f,t) = (,) f `liftM` rnm t
+ Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b
+ Type.Var _ -> return tipe
+ Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts
+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext
+ where rnm' (f,t) = (,) f <$> rnm t
-metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)
+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 ]
+ 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 ]
program' <- rename initialEnv (program modul)
- aliases' <- mapM (third renameType') (aliases modul)
- datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)
- exports' <- mapM (third renameType') (foreignExports modul)
- imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)
+ aliases' <- mapM (three4 renameType') (aliases modul)
+ datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
return $ modul { program = program'
, aliases = aliases'
- , datatypes = datatypes'
- , foreignExports = exports'
- , foreignImports = imports' }
+ , datatypes = datatypes' }
where
- second f (a,b) = (,) a `fmap` f b
- third f (a,b,c) = (,,) a b `fmap` f c
- twoAndFour f g (a,b,c,d) = do b' <- f b
- d' <- g d
- return (a,b',c,d')
+ two2 f (a,b) = (,) a <$> f b
+ three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
renameType' =
Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
- get1 (a,_,_) = a
+ get1 (a,_,_,_) = a
canon (name, importMethod) =
let pair pre var = (pre ++ drop (length name + 1) var, var)
iface = ifaces Map.! name
allNames = concat [ Map.keys (iTypes iface)
, map get1 (iAliases iface)
- , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
+ , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]
in case importMethod of
As alias -> map (pair (alias ++ ".")) allNames
Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
@@ -88,18 +81,19 @@ metadataModule ifaces modul =
Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames
where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars
- pair n = (n,n)
- localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))
- globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
- map (\n -> "_Tuple" ++ show n) [0..9]
+ two n = (n,n)
+ localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))
+ globalEnv =
+ map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++
+ map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)
initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)
type Env = Map.Map String String
-extend :: Env -> Pattern -> Env
+extend :: Env -> P.Pattern -> Env
extend env pattern = Map.union (Map.fromList (zip xs xs)) env
- where xs = Set.toList (SD.boundVars pattern)
+ where xs = Set.toList (P.boundVars pattern)
replace :: String -> Env -> String -> Either String String
@@ -113,76 +107,76 @@ replace variable env v =
msg = if null matches then "" else
"\nClose matches include: " ++ List.intercalate ", " matches
-rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)
-rename env lexpr@(L s expr) =
+rename :: Env -> LExpr -> Either [Doc] LExpr
+rename env (L s expr) =
let rnm = rename env
throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
format = Either.either throw return
+ renameType' env = renameType (format . replace "variable" env)
in
- L s `liftM`
+ L s <$>
case expr of
- Literal lit -> return expr
+ Literal _ -> return expr
- Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2
+ Range e1 e2 -> Range <$> rnm e1 <*> rnm e2
- Access e x -> Access `liftM` rnm e `ap` return x
+ Access e x -> Access <$> rnm e <*> return x
- Remove e x -> flip Remove x `liftM` rnm e
+ Remove e x -> flip Remove x <$> rnm e
- Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v
+ Insert e x v -> flip Insert x <$> rnm e <*> rnm v
Modify e fs ->
- Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
+ Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs
- Record fs -> Record `liftM` mapM frnm fs
- where
- frnm (f,e) = (,) f `liftM` rename env e
+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs
Binop op e1 e2 ->
do op' <- format (replace "variable" env op)
- Binop op' `liftM` rnm e1 `ap` rnm e2
+ Binop op' <$> rnm e1 <*> rnm e2
Lambda pattern e ->
let env' = extend env pattern in
- Lambda `liftM` format (renamePattern env' pattern) `ap` rename env' e
+ Lambda <$> format (renamePattern env' pattern) <*> rename env' e
- App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2
+ App e1 e2 -> App <$> rnm e1 <*> rnm e2
- MultiIf ps -> MultiIf `liftM` mapM grnm ps
- where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e
+ MultiIf ps -> MultiIf <$> mapM grnm ps
+ where grnm (b,e) = (,) <$> rnm b <*> rnm e
- Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e
+ Let defs e -> Let <$> mapM rename' defs <*> rename env' e
where
- env' = foldl extend env [ pattern | Def pattern _ <- defs ]
- rename' def =
- case def of
- Def p exp ->
- Def `liftM` format (renamePattern env' p) `ap` rename env' exp
- TypeAnnotation name tipe ->
- TypeAnnotation name `liftM`
- renameType (format . replace "variable" env') tipe
+ env' = foldl extend env $ map (\(Definition p _ _) -> p) defs
+ rename' (Definition p body mtipe) =
+ Definition <$> format (renamePattern env' p)
+ <*> rename env' body
+ <*> T.traverse (renameType' env') mtipe
- Var x -> Var `liftM` format (replace "variable" env x)
+ Var x -> Var <$> format (replace "variable" env x)
- Data name es -> Data name `liftM` mapM rnm es
+ Data name es -> Data name <$> mapM rnm es
- ExplicitList es -> ExplicitList `liftM` mapM rnm es
+ ExplicitList es -> ExplicitList <$> mapM rnm es
- Case e cases -> Case `liftM` rnm e `ap` mapM branch cases
+ Case e cases -> Case <$> rnm e <*> mapM branch cases
where
- branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)
- `ap` rename (extend env pattern) e
+ branch (pattern,b) = (,) <$> format (renamePattern env pattern)
+ <*> rename (extend env pattern) b
- Markdown uid md es -> Markdown uid md `liftM` mapM rnm es
+ Markdown uid md es -> Markdown uid md <$> mapM rnm es
+
+ PortIn name st -> PortIn name <$> renameType' env st
+
+ PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal
-renamePattern :: Env -> Pattern -> Either String Pattern
+renamePattern :: Env -> P.Pattern -> Either String P.Pattern
renamePattern env pattern =
case pattern of
- PVar _ -> return pattern
- PLiteral _ -> return pattern
- PRecord _ -> return pattern
- PAnything -> return pattern
- PAlias x p -> PAlias x `liftM` renamePattern env p
- PData name ps -> PData `liftM` replace "pattern" env name
- `ap` mapM (renamePattern env) ps
+ P.PVar _ -> return pattern
+ P.PLiteral _ -> return pattern
+ P.PRecord _ -> return pattern
+ P.PAnything -> return pattern
+ P.PAlias x p -> P.PAlias x <$> renamePattern env p
+ P.PData name ps -> P.PData <$> replace "pattern" env name
+ <*> mapM (renamePattern env) ps
diff --git a/compiler/Transform/Check.hs b/compiler/Transform/Check.hs
index e151e43..69885d0 100644
--- a/compiler/Transform/Check.hs
+++ b/compiler/Transform/Check.hs
@@ -1,114 +1,109 @@
+{-# OPTIONS_GHC -Wall #-}
module Transform.Check (mistakes) where
-import Transform.SortDefinitions (boundVars)
-import SourceSyntax.Declaration (Declaration(..))
-import SourceSyntax.Expression
-import SourceSyntax.Pattern
-import SourceSyntax.Location
-import SourceSyntax.PrettyPrint
-import qualified SourceSyntax.Type as T
-import Data.List as List
-import qualified Data.Map as Map
+import qualified Control.Arrow as Arrow
+import qualified Data.List as List
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
+
+import qualified SourceSyntax.Expression as E
+import qualified SourceSyntax.Declaration as D
+import qualified SourceSyntax.Pattern as Pattern
+import qualified SourceSyntax.Type as T
+import qualified Transform.Expression as Expr
+
+import SourceSyntax.PrettyPrint
import Text.PrettyPrint as P
-mistakes :: [Declaration t v] -> [Doc]
+mistakes :: [D.Declaration] -> [Doc]
mistakes decls =
concat [ infiniteTypeAliases decls
, illFormedTypes decls
, map P.text (duplicateConstructors decls)
- , map P.text (concatMap findErrors (getLets decls)) ]
- where
- findErrors defs = duplicates defs ++ badOrder defs
+ , map P.text (duplicates decls)
+ , badDerivations decls ]
-getLets :: [Declaration t v] -> [[Def t v]]
-getLets decls = defs : concatMap defLets defs
- where
- defs = [ d | Definition d <- decls ]
-
- defLets def =
- case def of
- TypeAnnotation _ _ -> []
- Def _ expr -> exprLets expr
-
- exprLets (L _ expr) =
- case expr of
- Var _ -> []
- Lambda p e -> exprLets e
- Binop op e1 e2 -> exprLets e1 ++ exprLets e2
- Case e cases -> exprLets e ++ concatMap (exprLets . snd) cases
- Data name es -> concatMap exprLets es
- Literal _ -> []
- Range e1 e2 -> exprLets e1 ++ exprLets e2
- ExplicitList es -> concatMap exprLets es
- App e1 e2 -> exprLets e1 ++ exprLets e2
- MultiIf branches -> concatMap (\(b,e) -> exprLets b ++ exprLets e) branches
- Access e lbl -> exprLets e
- Remove e lbl -> exprLets e
- Insert e lbl v -> exprLets e ++ exprLets v
- Modify e fields -> exprLets e ++ concatMap (exprLets . snd) fields
- Record fields -> concatMap (exprLets . snd) fields
- Markdown uid md es -> []
- Let defs body -> [defs] ++ exprLets body
-
-dups :: Eq a => [a] -> [a]
-dups = map head . filter ((>1) . length) . List.group
+dups :: Ord a => [a] -> [a]
+dups = map head . filter ((>1) . length) . List.group . List.sort
dupErr :: String -> String -> String
dupErr err x =
"Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."
-duplicates :: [Def t v] -> [String]
-duplicates defs =
- map defMsg (dups definitions) ++ map annMsg (dups annotations)
- where
- annotations = List.sort [ name | TypeAnnotation name _ <- defs ]
- definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]
- defMsg = dupErr "definition of"
- annMsg = dupErr "type annotation for"
+duplicates :: [D.Declaration] -> [String]
+duplicates decls =
+ map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
+ case mapM exprDups (portExprs ++ defExprs) of
+ Left name -> [msg name]
+ Right _ -> []
-duplicateConstructors :: [Declaration t v] -> [String]
+ where
+ msg = dupErr "definition of"
+
+ (defPatterns, defExprs) =
+ unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
+
+ (portNames, portExprs) =
+ Arrow.second concat $ unzip $
+ flip map [ port | D.Port port <- decls ] $ \port ->
+ case port of
+ D.Out name expr _ -> (name, [expr])
+ D.In name _ -> (name, [])
+
+ getNames = Set.toList . Pattern.boundVars
+
+ 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
+ [] -> Right defs
+ name:_ -> Left name
+
+duplicateConstructors :: [D.Declaration] -> [String]
duplicateConstructors decls =
- map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
+ map (dupErr "definition of type constructor") (dups typeCtors) ++
+ map (dupErr "definition of data constructor") (dups dataCtors)
where
- typeCtors = List.sort [ name | Datatype name _ _ <- decls ]
- dataCtors = List.sort . concat $
- [ map fst patterns | Datatype _ _ patterns <- decls ]
- dataMsg = dupErr "definition of data constructor"
- typeMsg = dupErr "definition of type constructor"
+ typeCtors = [ name | D.Datatype name _ _ _ <- decls ]
+ dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
-badOrder :: [Def t v] -> [String]
-badOrder defs = go defs
+badDerivations :: [D.Declaration] -> [Doc]
+badDerivations decls = concatMap badDerivation derivations
where
- msg x = "Syntax Error: The type annotation for '" ++ x ++
- "' must be directly above its definition."
-
- go defs =
- case defs of
- TypeAnnotation name _ : Def (PVar name') _ : rest
- | name == name' -> go rest
-
- TypeAnnotation name _ : rest -> [msg name] ++ go rest
-
- _ : rest -> go rest
+ derivations =
+ [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++
+ [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]
+ badDerivation (decl, tvars, derives) =
+ case (tvars, derives) of
+ (_:_, _)
+ | D.Json `elem` derives -> [report decl D.Json]
+ | D.Binary `elem` derives -> [report decl D.Binary]
_ -> []
-illFormedTypes :: [Declaration t v] -> [Doc]
+ report decl derive =
+ P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."
+ , P.text "Make sure all type variables are replaced with concrete types:"
+ , P.text "\n"
+ , nest 4 (pretty decl)
+ ]
+
+illFormedTypes :: [D.Declaration] -> [Doc]
illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
where
- aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]
- adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]
+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]
freeVars tipe =
case tipe of
T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
T.Var x -> Set.singleton x
T.Data _ ts -> Set.unions (map freeVars ts)
- T.EmptyRecord -> Set.empty
- T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)
+ T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
+ where ext' = maybe Set.empty Set.singleton ext
undeclared tvars tipes = Set.difference used declared
where
@@ -132,7 +127,7 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
addCommas xs
| length xs < 3 = concat xs
- | otherwise = intercalate "," xs
+ | otherwise = List.intercalate "," xs
addAnd xs
| length xs < 2 = xs
@@ -141,29 +136,30 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
quote tvar = "'" ++ tvar ++ "'"
-infiniteTypeAliases :: [Declaration t v] -> [Doc]
+infiniteTypeAliases :: [D.Declaration] -> [Doc]
infiniteTypeAliases decls =
- [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]
+ [ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls
+ , infiniteType name tipe ]
where
- isInfinite name tipe =
- let infinite = isInfinite name in
+ infiniteType name tipe =
+ let infinite = infiniteType name in
case tipe of
T.Lambda a b -> infinite a || infinite b
T.Var _ -> False
T.Data name' ts -> name == name' || any infinite ts
- T.EmptyRecord -> False
- T.Record fields ext -> infinite ext || any (infinite . snd) fields
+ T.Record fields _ -> any (infinite . snd) fields
- report decl@(TypeAlias name args tipe) =
+ indented :: D.Declaration -> Doc
+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"
+
+ report name args tipe derivations =
P.vcat [ P.text $ eightyCharLines 0 msg1
- , indented decl
+ , indented $ D.TypeAlias name args tipe derivations
, P.text $ eightyCharLines 0 msg2
- , indented (Datatype name args [(name,[tipe])])
+ , indented $ D.Datatype name args [(name,[tipe])] derivations
, P.text $ eightyCharLines 0 msg3 ++ "\n"
]
where
- indented decl = P.text "\n " <> pretty decl <> P.text "\n"
-
msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
"Notice that it appears in its own definition, so when \
\you expand it, it just keeps getting bigger:"
diff --git a/compiler/Transform/Declaration.hs b/compiler/Transform/Declaration.hs
new file mode 100644
index 0000000..d441037
--- /dev/null
+++ b/compiler/Transform/Declaration.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -Wall #-}
+module Transform.Declaration where
+
+import Control.Applicative ((<$>))
+import qualified SourceSyntax.Pattern as P
+import SourceSyntax.Expression as E
+import SourceSyntax.Declaration as D
+
+import qualified Transform.Expression as Expr
+import qualified Transform.Definition as Def
+
+
+combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]
+combineAnnotations = go
+ where
+ msg x = "Syntax Error: The type annotation for '" ++ x ++
+ "' must be directly above its definition."
+
+ exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
+
+ go decls =
+ case decls of
+ -- simple cases, pass them through with no changes
+ [] -> return []
+
+ Datatype name tvars ctors ds : rest ->
+ (:) (Datatype name tvars ctors ds) <$> go rest
+
+ TypeAlias name tvars alias ds : rest ->
+ (:) (TypeAlias name tvars alias ds) <$> go rest
+
+ Fixity assoc prec op : rest ->
+ (:) (Fixity assoc prec op) <$> go rest
+
+ -- combine definitions
+ D.Definition def : defRest ->
+ case def of
+ Def pat expr ->
+ do expr' <- exprCombineAnnotations expr
+ let def' = E.Definition pat expr' Nothing
+ (:) (D.Definition def') <$> go defRest
+
+ TypeAnnotation name tipe ->
+ case defRest of
+ D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
+ do expr' <- exprCombineAnnotations expr
+ let def' = E.Definition pat expr' (Just tipe)
+ (:) (D.Definition def') <$> go rest
+
+ _ -> Left (msg name)
+
+ -- combine ports
+ Port port : portRest ->
+ case port of
+ PPDef name _ -> Left (msg name)
+ PPAnnotation name tipe ->
+ case portRest of
+ Port (PPDef name' expr) : rest | name == name' ->
+ do expr' <- exprCombineAnnotations expr
+ (:) (Port (Out name expr' tipe)) <$> go rest
+
+ _ -> (:) (Port (In name tipe)) <$> go portRest
+
diff --git a/compiler/Transform/Definition.hs b/compiler/Transform/Definition.hs
new file mode 100644
index 0000000..fb1de3b
--- /dev/null
+++ b/compiler/Transform/Definition.hs
@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -Wall #-}
+module Transform.Definition where
+
+import Control.Applicative ((<$>))
+import qualified SourceSyntax.Pattern as P
+import SourceSyntax.Expression
+import qualified Transform.Expression as Expr
+
+combineAnnotations :: [ParseDef] -> Either String [Def]
+combineAnnotations = go
+ where
+ msg x = "Syntax Error: The type annotation for '" ++ x ++
+ "' must be directly above its definition."
+
+ exprCombineAnnotations = Expr.crawlLet combineAnnotations
+
+ go defs =
+ case defs of
+ TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
+ do expr' <- exprCombineAnnotations expr
+ let def = Definition pat expr' (Just tipe)
+ (:) def <$> go rest
+
+ TypeAnnotation name _ : _ -> Left (msg name)
+
+ Def pat expr : rest ->
+ do expr' <- exprCombineAnnotations expr
+ let def = Definition pat expr' Nothing
+ (:) def <$> go rest
+
+ [] -> return []
diff --git a/compiler/Transform/Expression.hs b/compiler/Transform/Expression.hs
new file mode 100644
index 0000000..e529f7c
--- /dev/null
+++ b/compiler/Transform/Expression.hs
@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -Wall #-}
+module Transform.Expression (crawlLet, checkPorts) where
+
+import Control.Applicative ((<$>),(<*>))
+import SourceSyntax.Expression
+import SourceSyntax.Location
+import qualified SourceSyntax.Type as ST
+
+crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
+crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
+
+checkPorts :: (String -> ST.Type -> Either a ())
+ -> (String -> ST.Type -> Either a ())
+ -> LExpr
+ -> Either a LExpr
+checkPorts inCheck outCheck expr =
+ crawl inCheck outCheck (mapM checkDef) expr
+ where
+ checkDef def@(Definition _ body _) =
+ do _ <- checkPorts inCheck outCheck body
+ return def
+
+crawl :: (String -> ST.Type -> Either a ())
+ -> (String -> ST.Type -> Either a ())
+ -> ([def] -> Either a [def'])
+ -> LExpr' def
+ -> Either a (LExpr' def')
+crawl portInCheck portOutCheck defsTransform = go
+ where
+ go (L srcSpan expr) =
+ L srcSpan <$>
+ case expr of
+ Var x -> return (Var x)
+ Lambda p e -> Lambda p <$> go e
+ Binop op e1 e2 -> Binop op <$> go e1 <*> go e2
+ Case e cases -> Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases
+ Data name es -> Data name <$> mapM go es
+ Literal lit -> return (Literal lit)
+ Range e1 e2 -> Range <$> go e1 <*> go e2
+ ExplicitList es -> ExplicitList <$> mapM go es
+ App e1 e2 -> App <$> go e1 <*> go e2
+ MultiIf branches -> MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches
+ Access e lbl -> Access <$> go e <*> return lbl
+ Remove e lbl -> Remove <$> go e <*> return lbl
+ Insert e lbl v -> Insert <$> go e <*> return lbl <*> go v
+ Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields
+ Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
+ Markdown uid md es -> Markdown uid md <$> mapM go es
+ Let defs body -> Let <$> defsTransform defs <*> go body
+ PortIn name st ->
+ do portInCheck name st
+ return $ PortIn name st
+ PortOut name st signal ->
+ do portOutCheck name st
+ PortOut name st <$> go signal
diff --git a/compiler/Transform/Optimize.hs b/compiler/Transform/Optimize.hs
deleted file mode 100644
index 1224173..0000000
--- a/compiler/Transform/Optimize.hs
+++ /dev/null
@@ -1,136 +0,0 @@
-module Transform.Optimize (optimize) where
-
-import SourceSyntax.Declaration (Declaration(..))
-import SourceSyntax.Expression
-import SourceSyntax.Literal
-import SourceSyntax.Location
-import SourceSyntax.Module
-import Control.Arrow (second, (***))
-import Data.Char (isAlpha)
-
-optimize (Module name ims exs stmts) =
- Module name ims exs (map optimizeStmt stmts)
-
-optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'
- where stmt' = simp stmt
-
-class Simplify a where
- simp :: a -> a
-
-instance Simplify (Declaration t v) where
- simp (Definition def) = Definition (simp def)
- simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
- simp stmt = stmt
-
-instance Simplify (Def t v) where
- simp (Def name e) = Def name (simp e)
- simp x = x
-
-instance Simplify e => Simplify (Located e) where
- simp (L s e) = L s (simp e)
-
-instance Simplify (Expr t v) where
- simp expr =
- let f = simp in
- case expr of
- Range e1 e2 -> Range (f e1) (f e2)
- Binop op e1 e2 -> binop op (f e1) (f e2)
- Lambda x e -> Lambda x (f e)
- Record fs -> Record (map (second simp) fs)
- App e1 e2 -> App (f e1) (f e2)
- Let defs e -> Let (map simp defs) (f e)
- Data name es -> Data name (map f es)
- MultiIf es -> MultiIf . clipBranches $ map (f *** f) es
- Case e cases -> Case (f e) (map (second f) cases)
- _ -> expr
-
-
-clipBranches [] = []
-clipBranches (e:es) =
- case e of
- (L _ (Literal (Boolean True)), _) -> [e]
- _ -> e : clipBranches es
-
-
-isValue e =
- case e of
- Literal _ -> True
- Var _ -> True
- Data _ _ -> True
- _ -> False
-
-
-binop op ce1@(L s1 e1) ce2@(L s2 e2) =
- let c1 = L s1
- c2 = L s2
- int = Literal . IntNum
- str = Literal . Str
- bool = Literal . Boolean
- in
- case (op, e1, e2) of
- (_, Literal (IntNum n), Literal (IntNum m)) ->
- case op of
- { "+" -> int $ (+) n m
- ; "-" -> int $ (-) n m
- ; "*" -> int $ (*) n m
- ; "^" -> int $ n ^ m
- ; "div" -> int $ div n m
- ; "mod" -> int $ mod n m
- ; "rem" -> int $ rem n m
- ; "<" -> bool $ n < m
- ; ">" -> bool $ n > m
- ; "<=" -> bool $ n <= m
- ; ">=" -> bool $ n >= m
- ; "==" -> bool $ n == m
- ; "/=" -> bool $ n /= m
- ; _ -> Binop op ce1 ce2 }
- {--
- -- flip order to move lone integers to the left
- ("+", _, IntNum n) -> binop "+" ce2 ce1
- ("*", _, IntNum n) -> binop "*" ce2 ce1
-
- ("+", IntNum 0, _) -> e2
- ("+", IntNum n, Binop "+" (L _ (IntNum m)) ce) ->
- binop "+" (c1 $ IntNum (n+m)) ce
- ("+", Binop "+" (L _ (IntNum n)) ce1'
- , Binop "+" (L _ (IntNum m)) ce2') ->
- binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')
-
- ("*", IntNum 0, _) -> e1
- ("*", IntNum 1, _) -> e2
- ("*", IntNum n, Binop "*" (L _ (IntNum m)) ce) ->
- binop "*" (none $ IntNum (n*m)) ce
- ("*", Binop "*" (L _ (IntNum n)) ce1'
- , Binop "*" (L _ (IntNum m)) ce2') ->
- binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')
-
- ("-", _, IntNum 0) -> e1
- ("/", _, IntNum 1) -> e1
- ("div", _, IntNum 1) -> e1
---}
- (_, Literal (Boolean n), Literal (Boolean m)) ->
- case op of
- "&&" -> bool $ n && m
- "||" -> bool $ n || m
- _ -> Binop op ce1 ce2
-
- ("&&", Literal (Boolean True), _) -> e2
- ("&&", Literal (Boolean False), _) -> bool False
- ("||", Literal (Boolean True), _) -> bool True
- ("||", Literal (Boolean False), _) -> e2
-
- ("::", _, _) -> Data "::" [ce1, ce2]
-
- ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2
- ("++", Literal (Str s1), Binop "++" (L _ (Literal (Str s2))) ce) ->
- Binop "++" (c1 . str $ s1 ++ s2) ce
- ("++", Binop "++" e (L _ (Literal (Str s1))), Literal (Str s2)) ->
- Binop "++" e (c1 . str $ s1 ++ s2)
-
- ("++", Data "[]" [], _) -> e2
- ("++", _, Data "[]" []) -> e1
- ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]
-
- _ | isAlpha (head op) || '_' == head op ->
- App (none $ App (none $ Var op) ce1) ce2
- | otherwise -> Binop op ce1 ce2
\ No newline at end of file
diff --git a/compiler/Transform/SafeNames.hs b/compiler/Transform/SafeNames.hs
index 2bb1282..dcfbd06 100644
--- a/compiler/Transform/SafeNames.hs
+++ b/compiler/Transform/SafeNames.hs
@@ -27,7 +27,7 @@ pattern pat =
PAlias x p -> PAlias (var x) (pattern p)
PData name ps -> PData name (map pattern ps)
-expression :: LExpr t v -> LExpr t v
+expression :: LExpr -> LExpr
expression (L loc expr) =
let f = expression in
L loc $
@@ -49,14 +49,14 @@ expression (L loc expr) =
Modify r fs -> Modify (f r) (map (var *** f) fs)
Record fs -> Record (map (var *** f) fs)
Markdown uid md es -> Markdown uid md (map f es)
+ PortIn name st -> PortIn name st
+ PortOut name st signal -> PortOut name st (f signal)
-definition :: Def t v -> Def t v
-definition def =
- case def of
- Def p e -> Def (pattern p) (expression e)
- TypeAnnotation name t -> TypeAnnotation (var name) t
+definition :: Def -> Def
+definition (Definition p e t) =
+ Definition (pattern p) (expression e) t
-metadataModule :: MetadataModule t v -> MetadataModule t v
+metadataModule :: MetadataModule -> MetadataModule
metadataModule modul =
modul
{ names = map var (names modul)
@@ -64,15 +64,9 @@ metadataModule modul =
, imports = map (first var) (imports modul)
, program = expression (program modul)
, aliases =
- let makeSafe (name, tvars, tipe) = (var name, tvars, tipe)
+ let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)
in map makeSafe (aliases modul)
, datatypes =
- let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)
+ let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)
in map makeSafe (datatypes modul)
- , foreignImports =
- let makeSafe (js,expr,elm,tipe) = (js, expression expr, var elm, tipe)
- in map makeSafe (foreignImports modul)
- , foreignExports =
- let makeSafe (js,elm,tipe) = (js, var elm, tipe)
- in map makeSafe (foreignExports modul)
}
\ No newline at end of file
diff --git a/compiler/Transform/SortDefinitions.hs b/compiler/Transform/SortDefinitions.hs
index 115857a..bbd4a05 100644
--- a/compiler/Transform/SortDefinitions.hs
+++ b/compiler/Transform/SortDefinitions.hs
@@ -1,37 +1,25 @@
-
-module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where
+{-# OPTIONS_GHC -Wall #-}
+module Transform.SortDefinitions (sortDefs) where
import Control.Monad.State
-import Control.Applicative ((<$>))
-import qualified Data.Set as Set
+import Control.Applicative ((<$>),(<*>))
import qualified Data.Map as Map
-import qualified SourceSyntax.Type as ST
import SourceSyntax.Expression
import SourceSyntax.Location
-import SourceSyntax.Pattern
+import qualified SourceSyntax.Pattern as P
import qualified Data.Graph as Graph
-import qualified Data.Map as Map
+import qualified Data.Set as Set
import qualified Data.Maybe as Maybe
-boundVars :: Pattern -> Set.Set String
-boundVars pattern =
- case pattern of
- PVar x -> Set.singleton x
- PAlias x p -> Set.insert x (boundVars p)
- PData _ ps -> Set.unions (map boundVars ps)
- PRecord fields -> Set.fromList fields
- PAnything -> Set.empty
- PLiteral _ -> Set.empty
-
-ctors :: Pattern -> [String]
+ctors :: P.Pattern -> [String]
ctors pattern =
case pattern of
- PVar x -> []
- PAlias x p -> ctors p
- PData ctor ps -> ctor : concatMap ctors ps
- PRecord fields -> []
- PAnything -> []
- PLiteral _ -> []
+ P.PVar _ -> []
+ P.PAlias _ p -> ctors p
+ P.PData ctor ps -> ctor : concatMap ctors ps
+ P.PRecord _ -> []
+ P.PAnything -> []
+ P.PLiteral _ -> []
free :: String -> State (Set.Set String) ()
free x = modify (Set.insert x)
@@ -39,68 +27,66 @@ free x = modify (Set.insert x)
bound :: Set.Set String -> State (Set.Set String) ()
bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
-sortDefs :: LExpr t v -> LExpr t v
+sortDefs :: LExpr -> LExpr
sortDefs expr = evalState (reorder expr) Set.empty
-flattenLets defs lexpr@(L _ expr) =
- case expr of
- Let ds body -> flattenLets (defs ++ ds) body
- _ -> (defs, lexpr)
-
-
-reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)
-reorder lexpr@(L s expr) =
- L s `liftM`
+reorder :: LExpr -> State (Set.Set String) LExpr
+reorder (L s expr) =
+ L s <$>
case expr of
-- Be careful adding and restricting freeVars
Var x -> free x >> return expr
Lambda p e ->
- uncurry Lambda `liftM` bindingReorder (p,e)
+ uncurry Lambda <$> bindingReorder (p,e)
Binop op e1 e2 ->
do free op
- Binop op `liftM` reorder e1 `ap` reorder e2
+ Binop op <$> reorder e1 <*> reorder e2
Case e cases ->
- Case `liftM` reorder e `ap` mapM bindingReorder cases
+ Case <$> reorder e <*> mapM bindingReorder cases
Data name es ->
do free name
- Data name `liftM` mapM reorder es
+ Data name <$> mapM reorder es
-- Just pipe the reorder though
Literal _ -> return expr
Range e1 e2 ->
- Range `liftM` reorder e1 `ap` reorder e2
+ Range <$> reorder e1 <*> reorder e2
ExplicitList es ->
- ExplicitList `liftM` mapM reorder es
+ ExplicitList <$> mapM reorder es
App e1 e2 ->
- App `liftM` reorder e1 `ap` reorder e2
+ App <$> reorder e1 <*> reorder e2
MultiIf branches ->
- MultiIf `liftM` mapM reorderPair branches
+ MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches
Access e lbl ->
- Access `liftM` reorder e `ap` return lbl
+ Access <$> reorder e <*> return lbl
Remove e lbl ->
- Remove `liftM` reorder e `ap` return lbl
+ Remove <$> reorder e <*> return lbl
Insert e lbl v ->
- Insert `liftM` reorder e `ap` return lbl `ap` reorder v
+ Insert <$> reorder e <*> return lbl <*> reorder v
Modify e fields ->
- Modify `liftM` reorder e `ap` mapM reorderField fields
+ Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields
Record fields ->
- Record `liftM` mapM reorderField fields
+ Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields
Markdown uid md es -> Markdown uid md <$> mapM reorder es
+ PortOut name st signal -> PortOut name st <$> reorder signal
+
+ PortIn name st -> return $ PortIn name st
+
-- Actually do some reordering
Let defs body ->
do body' <- reorder body
@@ -113,48 +99,24 @@ reorder lexpr@(L s expr) =
let defss = map Graph.flattenSCC sccs
-- remove let-bound variables from the context
- let getPatterns def =
- case def of
- Def pattern _ -> pattern
- TypeAnnotation name _ -> PVar name
- forM (map getPatterns defs) $ \pattern -> do
- bound (boundVars pattern)
+ forM_ defs $ \(Definition pattern _ _) -> do
+ bound (P.boundVars pattern)
mapM free (ctors pattern)
- let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)
- L _ let' = foldr addDefs body' defss
+ let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
return let'
- where
- toDefs def =
- case def of
- (pattern, expr, Nothing) -> [ Def pattern expr ]
- (PVar name, expr, Just tipe) ->
- [ TypeAnnotation name tipe, Def (PVar name) expr ]
- _ -> error $ unlines
- [ "The impossible occurred."
- , "Please report an issue at ."
- , "Be very descriptive because something quite weird probably happened." ]
-
-reorderField (label, expr) =
- (,) label `liftM` reorder expr
-
-reorderPair (e1,e2) =
- (,) `liftM` reorder e1 `ap` reorder e2
-
-bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)
+bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
bindingReorder (pattern,expr) =
do expr' <- reorder expr
- bound (boundVars pattern)
- mapM free (ctors pattern)
+ bound (P.boundVars pattern)
+ mapM_ free (ctors pattern)
return (pattern, expr')
-type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)
-
-reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])
-reorderAndGetDependencies (pattern, expr, mType) =
+reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])
+reorderAndGetDependencies (Definition pattern expr mType) =
do globalFrees <- get
-- work in a fresh environment
put Set.empty
@@ -162,44 +124,30 @@ reorderAndGetDependencies (pattern, expr, mType) =
localFrees <- get
-- merge with global frees
modify (Set.union globalFrees)
- return ((pattern, expr', mType), Set.toList localFrees)
+ return (Definition pattern expr' mType, Set.toList localFrees)
-- This also reorders the all of the sub-expressions in the Def list.
-buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]
+buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]
buildDefDict defs =
- do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)
+ do pdefsDeps <- mapM reorderAndGetDependencies defs
return $ realDeps (addKey pdefsDeps)
where
- getPDefs :: [Def t v] -> [PDef t v]
- getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $
- Map.toList $ go defs Map.empty Map.empty
- where
- go [] ds ts =
- Map.unions [ Map.difference ds ts
- , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]
-
- go (def:defs) ds ts =
- case def of
- Def p e -> go defs (Map.insert p (e, Nothing) ds) ts
- TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)
-
- addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]
+ addKey :: [(Def, [String])] -> [(Def, Int, [String])]
addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
- variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]
- variableToKey ((pattern, _, _), key, _) =
- [ (var, key) | var <- Set.toList (boundVars pattern) ]
+ variableToKey :: (Def, Int, [String]) -> [(String, Int)]
+ variableToKey (Definition pattern _ _, key, _) =
+ [ (var, key) | var <- Set.toList (P.boundVars pattern) ]
- variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int
+ variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int
variableToKeyMap pdefsDeps =
Map.fromList (concatMap variableToKey pdefsDeps)
- realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]
+ realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]
realDeps pdefsDeps = map convert pdefsDeps
where
varDict = variableToKeyMap pdefsDeps
convert (pdef, key, deps) =
(pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)
-
diff --git a/compiler/Transform/Substitute.hs b/compiler/Transform/Substitute.hs
index 376f507..bc9d06f 100644
--- a/compiler/Transform/Substitute.hs
+++ b/compiler/Transform/Substitute.hs
@@ -4,10 +4,10 @@ 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
-import qualified Transform.SortDefinitions as SD
-subst :: String -> Expr t v -> Expr t v -> Expr t v
+subst :: String -> Expr -> Expr -> Expr
subst old new expr =
let f (L s e) = L s (subst old new e) in
case expr of
@@ -15,7 +15,7 @@ subst old new expr =
ExplicitList es -> ExplicitList (map f es)
Binop op e1 e2 -> Binop op (f e1) (f e2)
Lambda p e
- | Set.member old (SD.boundVars p) -> expr
+ | Set.member old (Pattern.boundVars p) -> expr
| otherwise -> Lambda p (f e)
App e1 e2 -> App (f e1) (f e2)
MultiIf ps -> MultiIf (map (f *** f) ps)
@@ -24,12 +24,9 @@ subst old new expr =
| anyShadow -> expr
| otherwise -> Let (map substDef defs) (f body)
where
+ substDef (Definition p e t) = Definition p (f e) t
anyShadow =
- any (Set.member old . SD.boundVars) [ p | Def p _ <- defs ]
- substDef def =
- case def of
- TypeAnnotation _ _ -> def
- Def p e -> Def p (f e)
+ any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
Var x -> if x == old then new else expr
Case e cases -> Case (f e) $ map (second f) cases
@@ -40,4 +37,6 @@ subst old new expr =
Modify r fs -> Modify (f r) (map (second f) fs)
Record fs -> Record (map (second f) fs)
Literal _ -> expr
- Markdown uid md es -> Markdown uid md (map f es)
\ No newline at end of file
+ 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)
\ No newline at end of file
diff --git a/compiler/Type/Alias.hs b/compiler/Type/Alias.hs
index c04fef9..71787a9 100644
--- a/compiler/Type/Alias.hs
+++ b/compiler/Type/Alias.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Type.Alias (realias, rules, canonicalRealias, Rules) where
import Control.Applicative ((<$>),(<*>))
@@ -9,7 +10,7 @@ import qualified Data.List as List
import SourceSyntax.Type
import SourceSyntax.Module
-type Rules = ([(String,[String],Type)], Type -> Type)
+type Rules = ([Alias], Type -> Type)
rules interfaces moduleAliases moduleImports =
(collect interfaces moduleAliases, localizer moduleImports)
@@ -20,7 +21,7 @@ collect interfaces moduleAliases =
rawAliases =
moduleAliases ++ concatMap iAliases (Map.elems interfaces)
- isPrimitive (_,_,tipe) =
+ isPrimitive (_,_,tipe,_) =
case tipe of
Data _ [] -> True
_ -> False
@@ -30,10 +31,9 @@ localizer moduleImports = go
go tipe =
case tipe of
Var _ -> tipe
- EmptyRecord -> tipe
Lambda t1 t2 -> Lambda (go t1) (go t2)
Data name ts -> Data (localize name) (map go ts)
- Record fs ext -> Record (map (second go) fs) (go ext)
+ Record fs ext -> Record (map (second go) fs) ext
byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)
Map.empty moduleImports
@@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)
-- Realias using canonical aliases, so results will have aliases
-- that are fully qualified and possible to compare.
-canonicalRealias :: [(String,[String],Type)] -> Type -> Type
+canonicalRealias :: [Alias] -> Type -> Type
canonicalRealias aliases tipe =
case concatMap tryRealias aliases of
[] -> if tipe == tipe' then tipe else f tipe'
tipes -> f (bestType tipes)
where
- tryRealias (name, args, aliasTipe) =
+ tryRealias (name, args, aliasTipe, _) =
case diff aliasTipe tipe of
Nothing -> []
Just kvs ->
@@ -83,10 +83,9 @@ canonicalRealias aliases tipe =
tipe' =
case tipe of
Var _ -> tipe
- EmptyRecord -> tipe
Lambda t1 t2 -> Lambda (f t1) (f t2)
Data name ts -> Data name (map f ts)
- Record fs ext -> Record (map (second f) fs) (f ext)
+ Record fs ext -> Record (map (second f) fs) ext
allEqual [] = True
allEqual (x:xs) = all (==x) xs
@@ -102,8 +101,7 @@ bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs
Lambda t1 t2 -> numFields t1 + numFields t2
Var _ -> 0
Data _ ts -> sum (map numFields ts)
- EmptyRecord -> 0
- Record fields ext -> length fields + sum (map (numFields . snd) fields) + numFields ext
+ Record fields _ -> length fields + sum (map (numFields . snd) fields)
diff :: Type -> Type -> Maybe [(String,Type)]
diff general specific =
@@ -113,11 +111,11 @@ diff general specific =
(Data gname gts, Data sname sts)
| gname == sname && length gts == length sts ->
concat <$> zipWithM diff gts sts
- (EmptyRecord, EmptyRecord) -> Just []
- (Record _ _, Record _ _) ->
- let (gfs,gext) = collectRecords general
- (sfs,sext) = collectRecords specific
- gfields = collectFields gfs
+ (Record [] Nothing, Record [] Nothing) -> Just []
+ (Record _ _, Record [] Nothing) -> Nothing
+ (Record [] Nothing, Record _ _) -> Nothing
+ (Record gfs gext, Record sfs sext) ->
+ let gfields = collectFields gfs
sfields = collectFields sfs
overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
@@ -126,10 +124,12 @@ diff general specific =
case isAligned of
False -> Nothing
True -> let remaining = Map.difference sfields gfields
- sext' = if Map.null remaining then sext else
- Record (flattenFields remaining) sext
+ sext' = case sext of
+ Just x | Map.null remaining -> Var x
+ _ -> Record (flattenFields remaining) sext
+ gext' = maybe (Record [] Nothing) Var gext
matchMap = Map.intersectionWith (zipWith diff) gfields sfields
- in concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))
+ in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))
(_,_) -> Nothing
collectFields fields =
diff --git a/compiler/Type/Constrain/Declaration.hs b/compiler/Type/Constrain/Declaration.hs
index ed3b1bb..e522a1f 100644
--- a/compiler/Type/Constrain/Declaration.hs
+++ b/compiler/Type/Constrain/Declaration.hs
@@ -1,70 +1,63 @@
+{-# OPTIONS_GHC -Wall #-}
module Type.Constrain.Declaration where
-import Control.Monad
-import Control.Applicative ((<$>))
-
-import qualified Data.Map as Map
-
-import qualified Type.Constrain.Expression as TcExpr
-import qualified Type.Environment as Env
-
import SourceSyntax.Declaration
-import qualified SourceSyntax.Expression as Src
+import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Location as L
import qualified SourceSyntax.Pattern as P
-import qualified SourceSyntax.Type as Type
+import qualified SourceSyntax.Type as T
-toExpr :: [Declaration t v] -> [Src.Def t v]
+toExpr :: [Declaration] -> [E.Def]
toExpr = concatMap toDefs
-toDefs :: Declaration t v -> [Src.Def t v]
+toDefs :: Declaration -> [E.Def]
toDefs decl =
case decl of
Definition def -> [def]
- Datatype name tvars constructors -> concatMap toDefs constructors
+ Datatype name tvars constructors _ -> concatMap toDefs' constructors
where
- toDefs (ctor, tipes) =
+ toDefs' (ctor, tipes) =
let vars = take (length tipes) arguments
- tbody = Type.Data name $ map Type.Var tvars
- body = L.none . Src.Data ctor $ map (L.none . Src.Var) vars
- in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes
- , Src.Def (P.PVar ctor) $ buildFunction body vars
- ]
+ tbody = T.Data name $ map T.Var tvars
+ body = L.none . E.Data ctor $ map (L.none . E.Var) vars
+ in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
- TypeAlias name tvars tipe@(Type.Record fields ext) ->
- [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args
- , Src.Def (P.PVar name) $ buildFunction record vars ]
+ TypeAlias name _ tipe@(T.Record fields ext) _ ->
+ [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
where
- args = case ext of
- Type.EmptyRecord -> map snd fields
- _ -> map snd fields ++ [ext]
+ args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
- var = L.none . Src.Var
+ var = L.none . E.Var
vars = take (length args) arguments
efields = zip (map fst fields) (map var vars)
record = case ext of
- Type.EmptyRecord -> L.none $ Src.Record efields
- _ -> foldl (\r (f,v) -> L.none $ Src.Insert r f v) (var $ last vars) efields
+ Nothing -> L.none $ E.Record efields
+ Just _ -> foldl (\r (f,v) -> L.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 _ _ _ -> []
+ -- TODO: with the ability to derive code, you may need to generate stuff!
+ TypeAlias _ _ _ _ -> []
- ImportEvent _ expr@(L.L s _) name tipe ->
- [ Src.TypeAnnotation name tipe
- , Src.Def (P.PVar name) (L.L s $ Src.App (L.L s $ Src.Var "constant") expr) ]
-
- ExportEvent _ name tipe ->
- [ Src.TypeAnnotation name tipe ]
+ Port port ->
+ case port of
+ Out name expr@(L.L s _) tipe ->
+ [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
+ In name tipe ->
+ [ definition name (L.none $ E.PortIn name tipe) tipe ]
-- no constraints are needed for fixity declarations
Fixity _ _ _ -> []
arguments :: [String]
-arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]
+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
+buildFunction :: E.LExpr -> [String] -> E.LExpr
buildFunction body@(L.L s _) vars =
- foldr (\p e -> L.L s (Src.Lambda p e)) body (map P.PVar vars)
\ No newline at end of file
+ foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
+
+definition :: String -> E.LExpr -> T.Type -> E.Def
+definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
\ No newline at end of file
diff --git a/compiler/Type/Constrain/Expression.hs b/compiler/Type/Constrain/Expression.hs
index c4258e5..3a827d2 100644
--- a/compiler/Type/Constrain/Expression.hs
+++ b/compiler/Type/Constrain/Expression.hs
@@ -1,18 +1,16 @@
+{-# 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.Arrow (second)
-import Control.Applicative ((<$>),(<*>))
+import Control.Applicative ((<$>))
import qualified Control.Monad as Monad
import Control.Monad.Error
-import Control.Monad.State
-import Data.Traversable (traverse)
import qualified Text.PrettyPrint as PP
import SourceSyntax.Location as Loc
-import SourceSyntax.Pattern (Pattern(PVar))
+import SourceSyntax.Pattern (Pattern(PVar), boundVars)
import SourceSyntax.Expression
import qualified SourceSyntax.Type as SrcT
import Type.Type hiding (Descriptor(..))
@@ -20,10 +18,8 @@ import Type.Fragment
import qualified Type.Environment as Env
import qualified Type.Constrain.Literal as Literal
import qualified Type.Constrain.Pattern as Pattern
-import qualified Transform.SortDefinitions as SD
-
-constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint
+constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
constrain env (L span expr) tipe =
let list t = Env.get env Env.types "_List" <| t
and = L span . CAnd
@@ -145,13 +141,17 @@ constrain env (L span expr) tipe =
(schemes, rqs, fqs, header, c2, c1) <-
Monad.foldM (constrainDef env)
([], [], [], Map.empty, true, true)
- (collapseDefs defs)
+ (concatMap expandPattern defs)
return $ clet schemes
(clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
(c1 /\ c))
+ PortIn _ _ -> return true
-constrainDef env info (pattern, expr, maybeTipe) =
+ PortOut _ _ signal ->
+ constrain env signal tipe
+
+constrainDef env info (Definition pattern expr maybeTipe) =
let qs = [] -- should come from the def, but I'm not sure what would live there...
(schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
in
@@ -188,33 +188,18 @@ constrainDef env info (pattern, expr, maybeTipe) =
, c /\ c2
, c1 )
-expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)
- -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
-expandPattern triple@(pattern, lexpr@(L s _), maybeType) =
- case pattern of
- PVar _ -> [triple]
- _ -> (PVar x, lexpr, maybeType) : map toDef vars
- where
- vars = Set.toList $ SD.boundVars pattern
- x = "$" ++ concat vars
- var = L s . Var
- toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)
+ _ -> error (show pattern)
-collapseDefs :: [Def t v] -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
-collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
- where
- go output defs typs [] =
- output ++ concatMap Map.elems [
- Map.intersectionWithKey (\k v t -> (PVar k, v, Just t)) defs typs,
- Map.mapWithKey (\k v -> (PVar k, v, Nothing)) (Map.difference defs typs) ]
- go output defs typs (d:ds) =
- case d of
- Def (PVar name) body ->
- go output (Map.insert name body defs) typs ds
- Def pattern body ->
- go ((pattern, body, Nothing) : output) defs typs ds
- TypeAnnotation name typ ->
- go output defs (Map.insert name typ typs) ds
+expandPattern :: Def -> [Def]
+expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
+ case pattern of
+ PVar _ -> [def]
+ _ -> Definition (PVar x) lexpr maybeType : map toDef vars
+ where
+ vars = Set.toList $ boundVars pattern
+ x = "$" ++ concat vars
+ mkVar = L s . Var
+ toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
try span computation = do
diff --git a/compiler/Type/Constrain/Pattern.hs b/compiler/Type/Constrain/Pattern.hs
index 335166a..222e4d7 100644
--- a/compiler/Type/Constrain/Pattern.hs
+++ b/compiler/Type/Constrain/Pattern.hs
@@ -5,8 +5,6 @@ import Control.Arrow (second)
import Control.Applicative ((<$>))
import qualified Control.Monad as Monad
import Control.Monad.Error
-import qualified Data.List as List
-import qualified Data.Maybe as Maybe
import qualified Data.Map as Map
import qualified Text.PrettyPrint as PP
diff --git a/compiler/Type/Environment.hs b/compiler/Type/Environment.hs
index 279cda0..8ee016c 100644
--- a/compiler/Type/Environment.hs
+++ b/compiler/Type/Environment.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Type.Environment where
import Control.Applicative ((<$>), (<*>))
@@ -9,11 +10,10 @@ import qualified Control.Monad.State as State
import qualified Data.Traversable as Traverse
import qualified Data.Map as Map
import Data.List (isPrefixOf)
-import qualified Data.UnionFind.IO as UF
import qualified Text.PrettyPrint as PP
import qualified SourceSyntax.Type as Src
-import SourceSyntax.Module (ADT)
+import SourceSyntax.Module (ADT, Alias)
import Type.Type
type TypeDict = Map.Map String Type
@@ -26,10 +26,10 @@ data Environment = Environment {
value :: TypeDict
}
-initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment
+initialEnvironment :: [ADT] -> [Alias] -> IO Environment
initialEnvironment datatypes aliases = do
types <- makeTypes datatypes
- let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
+ let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases
env = Environment {
constructor = Map.empty,
value = Map.empty,
@@ -42,9 +42,9 @@ makeTypes :: [ADT] -> IO TypeDict
makeTypes datatypes =
Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
where
- nameAndKind (name, tvars, _) = (name, length tvars)
+ nameAndKind (name, tvars, _, _) = (name, length tvars)
- makeCtor (name, kind) = do
+ makeCtor (name, _) = do
ctor <- VarN <$> namedVar Constant name
return (name, ctor)
@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins
ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
-ctorToType env (name, tvars, ctors) =
+ctorToType env (name, tvars, ctors, _) =
zip (map fst ctors) (map inst ctors)
where
inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
@@ -94,7 +94,7 @@ ctorToType env (name, tvars, ctors) =
go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)
- go (ctor, args) = do
+ go (_, args) = do
types <- mapM (instantiator env) args
returnType <- instantiator env (Src.Data name (map Src.Var tvars))
return (types, returnType)
@@ -162,7 +162,9 @@ instantiator env sourceType = go sourceType
_ -> error $ "\nCould not find type constructor '" ++
name ++ "' while checking types."
- Src.EmptyRecord -> return (TermN EmptyRecord1)
-
- Src.Record fields ext ->
- TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)
+ Src.Record fields ext -> do
+ fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)
+ ext' <- case ext of
+ Nothing -> return $ TermN EmptyRecord1
+ Just x -> go (Src.Var x)
+ return $ TermN (Record1 fields' ext')
\ No newline at end of file
diff --git a/compiler/Type/ExtraChecks.hs b/compiler/Type/ExtraChecks.hs
index aec885f..f720e2a 100644
--- a/compiler/Type/ExtraChecks.hs
+++ b/compiler/Type/ExtraChecks.hs
@@ -1,10 +1,12 @@
+{-# OPTIONS_GHC -W #-}
+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.
-module Type.ExtraChecks (extraChecks, occursCheck) where
import Control.Applicative ((<$>),(<*>))
import Control.Monad.State
+import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.UnionFind.IO as UF
import Type.Type ( Variable, structure, Term1(..), toSrcType )
@@ -12,33 +14,106 @@ import qualified Type.State as TS
import qualified Type.Alias as Alias
import Text.PrettyPrint as P
import SourceSyntax.PrettyPrint (pretty)
-import SourceSyntax.Type (Type)
-import qualified SourceSyntax.Location as Location
-import qualified SourceSyntax.Expression as Expr
+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
-extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))
-extraChecks rules env =
- mainCheck rules <$> Traverse.traverse toSrcType env
+throw err = Left [ P.vcat err ]
-mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
-mainCheck rules env =
- let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in
- case Map.lookup "main" env of
- Nothing -> Right env
- Just tipe
- | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->
- Right env
- | otherwise ->
- Left [ P.vcat [ P.text "Type Error:"
- , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"
- , P.text "Instead 'main' has type:\n"
- , P.nest 4 . pretty $ Alias.realias rules tipe
- , P.text " " ]
- ]
+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
+mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
+ where
+ mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
+ mainCheck rules env =
+ case Map.lookup "main" env of
+ Nothing -> Right env
+ Just mainType
+ | tipe `elem` acceptable -> Right env
+ | otherwise -> throw err
+ where
+ acceptable = [ "Graphics.Element.Element"
+ , "Signal.Signal Graphics.Element.Element" ]
-occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()
-occursCheck (name, variable) =
+ tipe = P.render . pretty $ 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.text " " ]
+
+data Direction = In | Out
+
+portTypes :: Alias.Rules -> E.LExpr -> 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
+ | isJs ctor || isElm ctor -> mapM_ valid ts
+ | ctor == "Signal.Signal" -> handleSignal ts
+ | otherwise -> err' True "an unsupported type"
+
+ T.Var _ -> err "free type variables"
+
+ T.Lambda _ _ ->
+ case direction of
+ In -> err "functions"
+ Out | seenFunc -> err "higher-order functions"
+ | seenSignal -> err "signals that contain functions"
+ | otherwise ->
+ forM_ (T.collectLambdas tipe)
+ (isValid' True seenSignal direction name)
+
+ T.Record _ (Just _) -> err "extended records with free type variables"
+
+ T.Record fields Nothing ->
+ mapM_ (\(k,v) -> (,) k <$> valid v) fields
+
+ where
+ isValid' = isValid False
+ valid = isValid' seenFunc seenSignal direction name
+
+ isJs ctor =
+ List.isPrefixOf "JavaScript." ctor
+ && length (filter (=='.') ctor) == 1
+
+ isElm ctor =
+ ctor `elem` ["Int","Float","String","Bool","Maybe.Maybe","_List"]
+ || Help.isTuple ctor
+
+ handleSignal ts
+ | seenFunc = err "functions that involve signals"
+ | seenSignal = err "signals-of-signals"
+ | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts
+ | otherwise = err "a signal within a data stucture"
+
+ dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
+ txt = P.text . concat
+
+ err = err' False
+ err' couldBeAlias kind =
+ throw $
+ [ 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"
+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"
+ , " ports include JavaScript values and" ]
+ , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
+ , txt [ "Lists, Tuples, ", dir "" "first-order functions, ", "and concrete records." ]
+ ] ++ if couldBeAlias then aliasWarning else []
+
+ aliasWarning =
+ [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]
+ , 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 (name, variable) =
do vars <- liftIO $ infiniteVars [] variable
case vars of
[] -> return ()
@@ -47,10 +122,10 @@ occursCheck (name, variable) =
case structure desc of
Nothing ->
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
- Just struct ->
+ Just _ ->
do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
var' <- liftIO $ UF.fresh desc
- TS.addError (Location.NoSpan name) (Just msg) var var'
+ TS.addError (L.NoSpan name) (Just msg) var var'
where
msg = "Infinite types are not allowed"
fallback _ = return $ P.text msg
diff --git a/compiler/Type/Inference.hs b/compiler/Type/Inference.hs
index ccdd0b3..6327f38 100644
--- a/compiler/Type/Inference.hs
+++ b/compiler/Type/Inference.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Type.Inference where
import qualified Data.Map as Map
@@ -5,27 +6,23 @@ import qualified Data.Map as Map
import qualified Type.Type as T
import qualified Type.Environment as Env
import qualified Type.Constrain.Expression as TcExpr
-import qualified Type.Constrain.Declaration as TcDecl
import qualified Type.Solve as Solve
import SourceSyntax.Module as Module
-import qualified SourceSyntax.Expression as Expr
-import SourceSyntax.Location (Located, noneNoDocs)
-import SourceSyntax.PrettyPrint
+import SourceSyntax.Location (noneNoDocs)
import SourceSyntax.Type (Type)
import Text.PrettyPrint
import qualified Type.State as TS
-import Type.ExtraChecks (extraChecks)
+import qualified Type.ExtraChecks as Check
import Control.Monad.State (execStateT, forM)
import Control.Monad.Error (runErrorT, liftIO)
-import Control.Arrow (second)
import qualified Type.Alias as Alias
import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
-- the IO monad. I don't think that'd be worthwhile.
-infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)
+infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)
infer interfaces modul = unsafePerformIO $ do
env <- Env.initialEnvironment
(datatypes modul ++ concatMap iAdts (Map.elems interfaces))
@@ -55,4 +52,6 @@ infer interfaces modul = unsafePerformIO $ do
let rules = Alias.rules interfaces (aliases modul) (imports modul)
case TS.sErrors state of
errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
- [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)
+ [] -> case Check.portTypes rules (program modul) of
+ Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)
+ Left err -> return (Left err)
diff --git a/compiler/Type/Solve.hs b/compiler/Type/Solve.hs
index 69ea227..06cf57b 100644
--- a/compiler/Type/Solve.hs
+++ b/compiler/Type/Solve.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Type.Solve (solve) where
import Control.Monad
@@ -5,14 +6,11 @@ import Control.Monad.State
import qualified Data.UnionFind.IO as UF
import qualified Data.Map as Map
import qualified Data.Traversable as Traversable
-import qualified Data.Maybe as Maybe
import qualified Data.List as List
import Type.Type
import Type.Unify
-import qualified Type.ExtraChecks as EC
-import qualified Type.Environment as Env
+import qualified Type.ExtraChecks as Check
import qualified Type.State as TS
-import qualified Text.PrettyPrint as P
import SourceSyntax.Location (Located(L), SrcSpan)
@@ -122,7 +120,7 @@ solve (L span constraint) =
headers <- Map.unions `fmap` mapM (solveScheme span) schemes
TS.modifyEnv $ \env -> Map.union headers env
solve constraint'
- mapM EC.occursCheck $ Map.toList headers
+ mapM Check.occurs $ Map.toList headers
TS.modifyEnv (\_ -> oldEnv)
CInstance name term -> do
diff --git a/compiler/Type/State.hs b/compiler/Type/State.hs
index 5060115..a91c857 100644
--- a/compiler/Type/State.hs
+++ b/compiler/Type/State.hs
@@ -1,9 +1,8 @@
+{-# OPTIONS_GHC -W #-}
module Type.State where
import Type.Type
import qualified Data.Map as Map
-import qualified Data.List as List
-import qualified Type.Environment as Env
import qualified Data.UnionFind.IO as UF
import Control.Monad.State
import Control.Applicative ((<$>),(<*>), Applicative)
@@ -11,7 +10,6 @@ import qualified Data.Traversable as Traversable
import Text.PrettyPrint as P
import SourceSyntax.PrettyPrint
import SourceSyntax.Location
-import qualified SourceSyntax.Type as Src
import qualified Type.Alias as Alias
-- Pool
@@ -64,8 +62,8 @@ addError span hint t1 t2 =
]
location = case span of
- NoSpan msg -> ""
- Span p1 p2 msg ->
+ 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)
diff --git a/compiler/Type/Type.hs b/compiler/Type/Type.hs
index 8375e2c..f52ea25 100644
--- a/compiler/Type/Type.hs
+++ b/compiler/Type/Type.hs
@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
infixl 8 /\
(/\) :: Constraint a b -> Constraint a b -> Constraint a b
-a@(L s1 c1) /\ b@(L s2 c2) =
+a@(L _ c1) /\ b@(L _ c2) =
case (c1, c2) of
(CTrue, _) -> b
(_, CTrue) -> a
@@ -95,6 +95,7 @@ data Flex = Rigid | Flexible | Constant | Is SuperType
data SuperType = Number | Comparable | Appendable
deriving (Show, Eq)
+namedVar :: Flex -> String -> IO Variable
namedVar flex name = UF.fresh $ Descriptor {
structure = Nothing,
rank = noRank,
@@ -104,6 +105,7 @@ namedVar flex name = UF.fresh $ Descriptor {
mark = noMark
}
+var :: Flex -> IO Variable
var flex = UF.fresh $ Descriptor {
structure = Nothing,
rank = noRank,
@@ -113,6 +115,7 @@ var flex = UF.fresh $ Descriptor {
mark = noMark
}
+structuredVar :: Term1 Variable -> IO Variable
structuredVar structure = UF.fresh $ Descriptor {
structure = Just structure,
rank = noRank,
@@ -361,15 +364,19 @@ toSrcType variable = do
return (Src.Data name (ts ++ [b']))
Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b
Var1 a -> toSrcType a
- EmptyRecord1 -> return Src.EmptyRecord
- Record1 fs ext -> do
- fs' <- traverse (mapM toSrcType) fs
- let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]
- Src.Record fs'' <$> toSrcType ext
+ EmptyRecord1 -> return $ Src.Record [] Nothing
+ Record1 tfields extension -> do
+ fields' <- traverse (mapM toSrcType) tfields
+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
+ ext' <- toSrcType extension
+ return $ case ext' of
+ Src.Record fs ext -> Src.Record (fs ++ fields) ext
+ Src.Var x -> Src.Record fields (Just x)
+ _ -> error "Used toSrcType on a type that is not well-formed"
Nothing ->
case name desc of
- Just x@(c:cs) | Char.isLower c -> return (Src.Var x)
- | otherwise -> return (Src.Data x [])
+ Just x@(c:_) | Char.isLower c -> return (Src.Var x)
+ | otherwise -> return (Src.Data x [])
_ -> error $ concat
[ "Problem converting the following type "
, "from a type-checker type to a source-syntax type:"
@@ -383,12 +390,12 @@ collectApps variable = go [] variable
go vars variable = do
desc <- UF.descriptor variable
case (structure desc, vars) of
- (Nothing, [v] ) -> case name desc of
+ (Nothing, [v]) -> case name desc of
Just "_List" -> return (List v)
_ -> return Other
- (Nothing, vs ) -> case name desc of
+ (Nothing, vs) -> case name desc of
Just ctor | isTuple ctor -> return (Tuple vs)
_ -> return Other
- (Just term, vs) -> case term of
- App1 a b -> go (vars ++ [b]) a
- _ -> return Other
+ (Just term, _) -> case term of
+ App1 a b -> go (vars ++ [b]) a
+ _ -> return Other
diff --git a/compiler/Type/Unify.hs b/compiler/Type/Unify.hs
index 9b4cfe0..2474a99 100644
--- a/compiler/Type/Unify.hs
+++ b/compiler/Type/Unify.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -W #-}
module Type.Unify (unify) where
import Type.Type
@@ -5,7 +6,6 @@ import qualified Data.UnionFind.IO as UF
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Type.State as TS
-import Control.Arrow (first,second)
import Control.Monad.State
import SourceSyntax.Location
import Type.PrettyPrint
@@ -193,8 +193,8 @@ actuallyUnify span variable1 variable2 = do
unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a
- eat (x:xs) (y:ys) = eat xs ys
- eat xs ys = xs
+ eat (_:xs) (_:ys) = eat xs ys
+ eat xs _ = xs
_ -> TS.addError span Nothing variable1 variable2
diff --git a/libraries/Basics.elm b/libraries/Basics.elm
index 6728978..0b5952c 100644
--- a/libraries/Basics.elm
+++ b/libraries/Basics.elm
@@ -43,7 +43,7 @@ which happen to be radians.
@docs fst, snd
# Higher-Order Helpers
-@docs id, (<|), (|>), (.), flip, curry, uncurry
+@docs id, (<|), (|>), (.), always, flip, curry, uncurry
-}
@@ -313,6 +313,22 @@ infixl 0 |>
id : a -> a
id x = x
+{-| Creates a [constant function](http://en.wikipedia.org/wiki/Constant_function),
+a function that *always* returns the same value regardless of what input you give.
+It is defined as:
+
+ always a b = a
+
+It totally ignores the second argument, so `always 42` is a function that always
+returns in 42. When you are dealing with higher-order functions, this comes in
+handy more often than you might expect. For example, creating a zeroed out list
+of length ten would be:
+
+ map (always 0) [0..9]
+-}
+always : a -> b -> a
+always a _ = a
+
{-| Given a 2-tuple, returns the first value. -}
fst : (a,b) -> a
fst (a,_) = a
diff --git a/libraries/Dict.elm b/libraries/Dict.elm
index 9937d58..1f8e25c 100644
--- a/libraries/Dict.elm
+++ b/libraries/Dict.elm
@@ -34,15 +34,35 @@ Insert, remove, and query operations all take *O(log n)* time.
import open Basics
import open Maybe
import Native.Error
-import List as List
+import List
+import String
import Native.Utils
-- BBlack and NBlack should only be used during the deletion
-- algorithm. Any other occurrence is a bug and should fail an assert.
-data NColor = Red | Black
- | BBlack | NBlack
+data NColor = Red
+ | Black
+ -- ^ Double Black, counts as 2 blacks for the invariant
+ | BBlack
+ -- ^ Negative Black, counts as -1 blacks for the invariant
+ | NBlack
-data LeafColor = LBlack | LBBlack
+
+showNColor : NColor -> String
+showNColor c = case c of
+ Red -> "Red"
+ Black -> "Black"
+ BBlack -> "BBlack"
+ NBlack -> "NBlack"
+
+data LeafColor = LBlack
+ -- ^ Double Black, counts as 2
+ | LBBlack
+
+showLColor : LeafColor -> String
+showLColor c = case c of
+ LBlack -> "LBlack"
+ LBBlack -> "LBBlack"
data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)
| RBEmpty LeafColor
@@ -93,51 +113,6 @@ member : comparable -> Dict comparable v -> Bool
-- Does t contain k?
member k t = isJust <| lookup k t
-rotateLeft : Dict k v -> Dict k v
-rotateLeft t =
- case t of
- RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c
- _ -> Native.Error.raise "rotateLeft of a node without enough children"
-
--- rotateRight -- the reverse, and
--- makes Y have Z's color, and makes Z Red.
-rotateRight : Dict k v -> Dict k v
-rotateRight t =
- case t of
- RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)
- _ -> Native.Error.raise "rotateRight of a node without enough children"
-
-rotateLeftIfNeeded : Dict k v -> Dict k v
-rotateLeftIfNeeded t =
- case t of
- RBNode _ _ _ _ (RBNode Red _ _ _ _) -> rotateLeft t
- _ -> t
-
-rotateRightIfNeeded : Dict k v -> Dict k v
-rotateRightIfNeeded t =
- case t of
- RBNode _ _ _ (RBNode Red _ _ (RBNode Red _ _ _ _) _) _ -> rotateRight t
- _ -> t
-
-otherColor c = case c of { Red -> Black ; Black -> Red }
-
-color_flip : Dict k v -> Dict k v
-color_flip t =
- case t of
- RBNode c1 bk bv (RBNode c2 ak av la ra) (RBNode c3 ck cv lc rc) ->
- RBNode (otherColor c1) bk bv
- (RBNode (otherColor c2) ak av la ra)
- (RBNode (otherColor c3) ck cv lc rc)
- _ -> Native.Error.raise "color_flip called on a Empty or Node with a Empty child"
-
-color_flipIfNeeded : Dict k v -> Dict k v
-color_flipIfNeeded t =
- case t of
- RBNode _ _ _ (RBNode Red _ _ _ _) (RBNode Red _ _ _ _) -> color_flip t
- _ -> t
-
-fixUp t = color_flipIfNeeded (rotateRightIfNeeded (rotateLeftIfNeeded t))
-
ensureBlackRoot : Dict k v -> Dict k v
ensureBlackRoot t =
case t of
@@ -158,6 +133,11 @@ remove k t = let u _ = Nothing in
update k u t
data Flag = Insert | Remove | Same
+showFlag : Flag -> String
+showFlag f = case f of
+ Insert -> "Insert"
+ Remove -> "Remove"
+ Same -> "Same"
{-| Update the value of a dictionary for a specific key with a given function. -}
update : comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v
@@ -168,76 +148,87 @@ update k u t =
Just v -> (Insert, RBNode Red k v empty empty)
RBNode c k' v l r -> case Native.Utils.compare k k' of
EQ -> case u (Just v) of
- Nothing -> (Remove, rem t)
+ Nothing -> (Remove, rem c l r)
Just v' -> (Same, RBNode c k' v' l r)
LT -> let (fl, l') = up l in
case fl of
Same -> (Same, RBNode c k' v l' r)
- Insert -> (Insert, fixUp <| RBNode c k' v l' r)
+ Insert -> (Insert, balance c k' v l' r)
Remove -> (Remove, bubble c k' v l' r)
GT -> let (fl, r') = up r in
case fl of
Same -> (Same, RBNode c k' v l r')
- Insert -> (Insert, fixUp <| RBNode c k' v l r')
+ Insert -> (Insert, balance c k' v l r')
Remove -> (Remove, bubble c k' v l r')
(fl, t') = up t
in case fl of
Same -> t'
Insert -> ensureBlackRoot t'
Remove -> blacken t'
-
+
{-| Create a dictionary with one key-value pair. -}
singleton : comparable -> v -> Dict comparable v
singleton k v = insert k v (RBEmpty LBlack)
-{- Remove helpers: everything from here to remove should only be used
- internally by remove as they would otherwise break rb-invariants -}
-
isBBlack : Dict k v -> Bool
isBBlack t = case t of
- RBNode c _ _ _ _ -> case c of
- BBlack -> True
- _ -> False
+ RBNode BBlack _ _ _ _ -> True
RBEmpty LBBlack -> True
_ -> False
moreBlack : NColor -> NColor
moreBlack c = case c of
- BBlack -> BBlack
Black -> BBlack
Red -> Black
NBlack -> Red
+ BBlack -> Native.Error.raise "Can't make a double black node more black!"
+
lessBlack : NColor -> NColor
lessBlack c = case c of
BBlack -> Black
Black -> Red
Red -> NBlack
- NBlack -> NBlack
-
-moreBlackTree : Dict k v -> Dict k v
-moreBlackTree t = case t of
- RBNode c k v l r -> RBNode (moreBlack c) k v l r
- RBEmpty _ -> RBEmpty LBBlack
+ NBlack -> Native.Error.raise "Can't make a negative black node less black!"
lessBlackTree : Dict k v -> Dict k v
lessBlackTree t = case t of
RBNode c k v l r -> RBNode (lessBlack c) k v l r
- RBEmpty _ -> RBEmpty LBlack
+ RBEmpty LBBlack -> RBEmpty LBlack
+
+reportRemBug : String -> NColor -> String -> String -> a
+reportRemBug msg c lgot rgot =
+ Native.Error.raise . String.concat <| [
+ "Internal red-black tree invariant violated, expected ",
+ msg,
+ "and got",
+ showNColor c,
+ " ",
+ lgot,
+ " ",
+ rgot,
+ "\nPlease report this bug to https://github.com/evancz/Elm/issues"
+ ]
-- Remove the top node from the tree, may leave behind BBlacks
-rem : Dict k v -> Dict k v
-rem t = case t of
- RBNode c k v (RBEmpty _) (RBEmpty _) -> case c of
- Red -> RBEmpty LBlack
+rem : NColor -> Dict k v -> Dict k v -> Dict k v
+rem c l r = case (l, r) of
+ ((RBEmpty _), (RBEmpty _)) -> case c of
+ Red -> RBEmpty LBlack
Black -> RBEmpty LBBlack
- RBNode Black _ _ (RBEmpty _) (RBNode _ k v l r) ->
- RBNode Black k v l r
- RBNode Black _ _ (RBNode _ k v l r) (RBEmpty _) ->
- RBNode Black k v l r
+ ((RBEmpty cl), (RBNode cr k' v' l' r')) ->
+ case (c, cl, cr) of
+ (Black, LBlack, Red) -> RBNode Black k' v' l' r'
+ _ -> reportRemBug "Black, LBlack, Red" c (showLColor cl) (showNColor cr)
+ ((RBNode cl k' v' l' r'), (RBEmpty cr)) ->
+ case (c, cl, cr) of
+ (Black, Red, LBlack) -> RBNode Black k' v' l' r'
+ _ -> reportRemBug "Black, Red, LBlack" c (showNColor cl) (showLColor cr)
-- l and r are both RBNodes
- RBNode c _ _ l r ->
- let (k, v) = max l
- l' = remove_max l
+ ((RBNode cl kl vl ll rl), (RBNode cr kr vr lr rr)) ->
+ let l = RBNode cl kl vl ll rl
+ r = RBNode cr kr vr lr rr
+ (k, v) = max l
+ l' = remove_max cl kl vl ll rl
in bubble c k v l' r
-- Kills a BBlack or moves it upward, may leave behind NBlack
@@ -245,19 +236,24 @@ bubble : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v
bubble c k v l r = if isBBlack l || isBBlack r
then balance (moreBlack c) k v (lessBlackTree l) (lessBlackTree r)
else RBNode c k v l r
-
+
-- Removes rightmost node, may leave root as BBlack
-remove_max : Dict k v -> Dict k v
-remove_max t = case t of
- RBNode c k v l (RBEmpty _) -> rem t
- RBNode c k v l r -> bubble c k v l (remove_max r)
+remove_max : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v
+remove_max c k v l r = case r of
+ RBEmpty _ -> rem c l r
+ RBNode cr kr vr lr rr
+ -> bubble c k v l (remove_max cr kr vr lr rr)
-- generalized tree balancing act
balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v
-balance c k v l r = balance_node (RBNode c k v l r)
+balance c k v l r =
+
+ balance_node (RBNode c k v l r)
blackish : Dict k v -> Bool
-blackish (RBNode c _ _ _ _) = c == Black || c == BBlack
+blackish t = case t of
+ RBNode c _ _ _ _ -> c == Black || c == BBlack
+ RBEmpty _ -> True
balance_node : Dict k v -> Dict k v
balance_node t =
@@ -286,9 +282,7 @@ balance_node t =
(RBNode Black _ _ _ _) ->
RBNode Black yk yv (balance Black xk xv (redden a) b) (RBNode Black zk zv c d)
_ -> t
-
_ -> t
-
else t
-- make the top node black
diff --git a/libraries/Native/JavaScript.js b/libraries/Native/JavaScript.js
index 35592e3..ffa52fb 100644
--- a/libraries/Native/JavaScript.js
+++ b/libraries/Native/JavaScript.js
@@ -34,7 +34,7 @@ Elm.Native.JavaScript.make = function(elm) {
function toJS(v) {
var type = typeof v;
- if (type === 'number' || type === 'boolean') return v;
+ if (type === 'number' || type === 'boolean' || type === 'string') return v;
if (type === 'object' && '_' in v) {
var obj = {};
for (var k in v) {
diff --git a/libraries/Native/Ports.js b/libraries/Native/Ports.js
new file mode 100644
index 0000000..aab956f
--- /dev/null
+++ b/libraries/Native/Ports.js
@@ -0,0 +1,83 @@
+Elm.Native.Ports = {};
+Elm.Native.Ports.make = function(elm) {
+ elm.Native = elm.Native || {};
+ elm.Native.Ports = elm.Native.Ports || {};
+ if (elm.Native.Ports.values) return elm.Native.Ports.values;
+
+ var Signal = Elm.Signal.make(elm);
+
+ function incomingSignal(converter) {
+ converter.isSignal = true;
+ return converter;
+ }
+
+ function outgoingSignal(converter) {
+ return function(signal) {
+ var subscribers = []
+ function subscribe(handler) {
+ subscribers.push(handler);
+ }
+ function unsubscribe(handler) {
+ subscribers.pop(subscribers.indexOf(handler));
+ }
+ A2( Signal.lift, function(value) {
+ var val = converter(value);
+ var len = subscribers.length;
+ for (var i = 0; i < len; ++i) {
+ subscribers[i](val);
+ }
+ }, signal);
+ return { subscribe:subscribe, unsubscribe:unsubscribe };
+ }
+ }
+
+ function portIn(name, converter) {
+ var jsValue = elm.ports.incoming[name];
+ if (jsValue === undefined) {
+ throw new Error("Initialization Error: port '" + name +
+ "' was not given an input!");
+ }
+ elm.ports.uses[name] += 1;
+ try {
+ var elmValue = converter(jsValue);
+ } catch(e) {
+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);
+ }
+
+ // just return a static value if it is not a signal
+ if (!converter.isSignal) {
+ return elmValue;
+ }
+
+ // create a signal if necessary
+ var signal = Signal.constant(elmValue);
+ function send(jsValue) {
+ try {
+ var elmValue = converter(jsValue);
+ } catch(e) {
+ throw new Error("Error sending to port '" + name + "': \n" + e.message);
+ }
+ setTimeout(function() {
+ elm.notify(signal.id, elmValue);
+ }, 0);
+ }
+ elm.ports.outgoing[name] = { send:send };
+ return signal;
+ }
+
+ function portOut(name, converter, value) {
+ try {
+ elm.ports.outgoing[name] = converter(value);
+ } catch(e) {
+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);
+ }
+ return value;
+ }
+
+ return elm.Native.Ports.values = {
+ incomingSignal: incomingSignal,
+ outgoingSignal: outgoingSignal,
+ portOut: portOut,
+ portIn: portIn
+ };
+};
diff --git a/runtime/Init.js b/runtime/Init.js
index 1aa5653..70cdf6f 100644
--- a/runtime/Init.js
+++ b/runtime/Init.js
@@ -2,7 +2,7 @@
(function() {
'use strict';
-Elm.fullscreen = function(module) {
+Elm.fullscreen = function(module, ports) {
var style = document.createElement('style');
style.type = 'text/css';
style.innerHTML = "html,head,body { padding:0; margin:0; }" +
@@ -10,24 +10,24 @@ Elm.fullscreen = function(module) {
document.head.appendChild(style);
var container = document.createElement('div');
document.body.appendChild(container);
- return init(ElmRuntime.Display.FULLSCREEN, container, module);
+ return init(ElmRuntime.Display.FULLSCREEN, container, module, ports || {});
};
-Elm.embed = function(module, container) {
+Elm.embed = function(module, container, ports) {
var tag = container.tagName;
if (tag !== 'DIV') {
throw new Error('Elm.node must be given a DIV, not a ' + tag + '.');
} else if (container.hasChildNodes()) {
throw new Error('Elm.node must be given an empty DIV. No children allowed!');
}
- return init(ElmRuntime.Display.COMPONENT, container, module);
+ return init(ElmRuntime.Display.COMPONENT, container, module, ports || {});
};
-Elm.worker = function(module) {
- return init(ElmRuntime.Display.NONE, {}, module);
+Elm.worker = function(module, ports) {
+ return init(ElmRuntime.Display.NONE, {}, module, ports || {});
};
-function init(display, container, module, moduleToReplace) {
+function init(display, container, module, ports, moduleToReplace) {
// defining state needed for an instance of the Elm RTS
var inputs = [];
@@ -59,6 +59,10 @@ function init(display, container, module, moduleToReplace) {
listeners.push(listener);
}
+ var portUses = {}
+ for (var key in ports) {
+ portUses[key] = 0;
+ }
// create the actual RTS. Any impure modules will attach themselves to this
// object. This permits many Elm programs to be embedded per document.
var elm = {
@@ -67,34 +71,15 @@ function init(display, container, module, moduleToReplace) {
display:display,
id:ElmRuntime.guid(),
addListener:addListener,
- inputs:inputs
+ inputs:inputs,
+ ports: { incoming:ports, outgoing:{}, uses:portUses }
};
- // Set up methods to communicate with Elm program from JS.
- function send(name, value) {
- if (typeof value === 'undefined') return function(v) { return send(name,v); };
- var e = document.createEvent('Event');
- e.initEvent(name + '_' + elm.id, true, true);
- e.value = value;
- document.dispatchEvent(e);
- }
- function recv(name, handler) {
- document.addEventListener(name + '_' + elm.id, handler);
- }
-
- recv('log', function(e) {console.log(e.value)});
- recv('title', function(e) {document.title = e.value});
- recv('redirect', function(e) {
- if (e.value.length > 0) { window.location = e.value; }
- });
-
function swap(newModule) {
removeListeners(listeners);
var div = document.createElement('div');
- var newElm = init(display, div, newModule, elm);
+ var newElm = init(display, div, newModule, ports, elm);
inputs = [];
- // elm.send = newElm.send;
- // elm.recv = newElm.recv;
// elm.swap = newElm.swap;
return newElm;
}
@@ -103,6 +88,7 @@ function init(display, container, module, moduleToReplace) {
var reportAnyErrors = function() {};
try {
Module = module.make(elm);
+ checkPorts(elm);
} catch(e) {
var directions = "
Open the developer console for more details."
Module.main = Elm.Text.make(elm).text('' + e.message + directions + '');
@@ -110,6 +96,7 @@ function init(display, container, module, moduleToReplace) {
}
inputs = ElmRuntime.filterDeadInputs(inputs);
filterListeners(inputs, listeners);
+ addReceivers(elm.ports.outgoing);
if (display !== ElmRuntime.Display.NONE) {
var graphicsNode = initGraphics(elm, Module);
}
@@ -123,9 +110,27 @@ function init(display, container, module, moduleToReplace) {
}
reportAnyErrors();
- return { send:send, recv:recv, swap:swap };
+ return { swap:swap, ports:elm.ports.outgoing };
};
+function checkPorts(elm) {
+ var portUses = elm.ports.uses;
+ for (var key in portUses) {
+ var uses = portUses[key]
+ if (uses === 0) {
+ throw new Error(
+ "Initialization Error: provided port '" + key +
+ "' to a module that does not take it as in input.\n" +
+ "Remove '" + key + "' from the module initialization code.");
+ } else if (uses > 1) {
+ throw new Error(
+ "Initialization Error: port '" + key +
+ "' has been declared multiple times in the Elm code.\n" +
+ "Remove declarations until there is exactly one.");
+ }
+ }
+}
+
function filterListeners(inputs, listeners) {
loop:
for (var i = listeners.length; i--; ) {
@@ -146,6 +151,57 @@ function removeListeners(listeners) {
}
}
+// add receivers for built-in ports if they are defined
+function addReceivers(ports) {
+ if ('log' in ports) {
+ ports.log.subscribe(function(v) { console.log(v) });
+ }
+ if ('stdout' in ports) {
+ var process = process || {};
+ var handler = process.stdout
+ ? function(v) { process.stdout.write(v); }
+ : function(v) { console.log(v); };
+ ports.stdout.subscribe(handler);
+ }
+ if ('stderr' in ports) {
+ var process = process || {};
+ var handler = process.stderr
+ ? function(v) { process.stderr.write(v); }
+ : function(v) { console.log('Error:' + v); };
+ ports.stderr.subscribe(handler);
+ }
+ if ('title' in ports) {
+ if (typeof ports.title === 'string') {
+ document.title = ports.title;
+ } else {
+ ports.title.subscribe(function(v) { document.title = v; });
+ }
+ }
+ if ('redirect' in ports) {
+ ports.redirect.subscribe(function(v) {
+ if (v.length > 0) window.location = v;
+ });
+ }
+ if ('favicon' in ports) {
+ if (typeof ports.favicon === 'string') {
+ changeFavicon(ports.favicon);
+ } else {
+ ports.favicon.subscribe(changeFavicon);
+ }
+ }
+ function changeFavicon(src) {
+ var link = document.createElement('link');
+ var oldLink = document.getElementById('elm-favicon');
+ link.id = 'elm-favicon';
+ link.rel = 'shortcut icon';
+ link.href = src;
+ if (oldLink) {
+ document.head.removeChild(oldLink);
+ }
+ document.head.appendChild(link);
+ }
+}
+
function initGraphics(elm, Module) {
if (!('main' in Module))
throw new Error("'main' is missing! What do I display?!");
diff --git a/runtime/Utils.js b/runtime/Utils.js
index 9f0f0a3..51e03b7 100644
--- a/runtime/Utils.js
+++ b/runtime/Utils.js
@@ -34,18 +34,18 @@ ElmRuntime.filterDeadInputs = function(inputs) {
// define the draw function
var vendors = ['ms', 'moz', 'webkit', 'o'];
-var window = window || {};
-for (var i = 0; i < vendors.length && !window.requestAnimationFrame; ++i) {
- window.requestAnimationFrame = window[vendors[i]+'RequestAnimationFrame'];
- window.cancelAnimationFrame = window[vendors[i]+'CancelAnimationFrame'] ||
- window[vendors[i]+'CancelRequestAnimationFrame'];
+var win = window || {};
+for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {
+ win.requestAnimationFrame = win[vendors[i]+'RequestAnimationFrame'];
+ win.cancelAnimationFrame = win[vendors[i]+'CancelAnimationFrame'] ||
+ win[vendors[i]+'CancelRequestAnimationFrame'];
}
-if (window.requestAnimationFrame && window.cancelAnimationFrame) {
+if (win.requestAnimationFrame && win.cancelAnimationFrame) {
var previous = 0;
ElmRuntime.draw = function(callback) {
- window.cancelAnimationFrame(previous);
- previous = window.requestAnimationFrame(callback);
+ win.cancelAnimationFrame(previous);
+ previous = win.requestAnimationFrame(callback);
};
} else {
ElmRuntime.draw = function(callback) { callback(); };
diff --git a/tests/Main.hs b/tests/Main.hs
index 4119223..72c3021 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,22 +1,11 @@
module Main where
-import System.Directory
-import System.Exit (exitWith)
-import System.Environment (getArgs)
-import Test.Framework.TestManager
-import Test.Framework.BlackBoxTest
+import Test.Framework
+
+import Tests.Compiler
+import Tests.Property
main :: IO ()
-main = do
- args <- getArgs
- tests <- blackBoxTests "tests" "dist/build/elm/elm" ".elm" bbtArgs
- code <- runTestWithArgs args tests
- removeDirectoryRecursive "cache"
- removeDirectoryRecursive "build"
- exitWith code
-
-bbtArgs = defaultBBTArgs { bbtArgs_stdoutDiff = ignoreDiff
- , bbtArgs_stderrDiff = ignoreDiff }
-
-ignoreDiff :: Diff
-ignoreDiff _ _ = return Nothing
\ No newline at end of file
+main = defaultMain [ compilerTests
+ , propertyTests
+ ]
diff --git a/tests/Tests/Compiler.hs b/tests/Tests/Compiler.hs
new file mode 100644
index 0000000..64b7bc9
--- /dev/null
+++ b/tests/Tests/Compiler.hs
@@ -0,0 +1,45 @@
+module Tests.Compiler (compilerTests)
+ where
+
+import Data.Functor ((<$>))
+import Data.Traversable (traverse)
+import System.FilePath (())
+import System.FilePath.Find (find, (==?), extension)
+import Test.Framework
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit (Assertion, assertFailure, assertBool)
+import Text.Parsec (ParseError)
+
+import Elm.Internal.Utils as Elm
+
+compilerTests :: Test
+compilerTests = buildTest $ do
+ goods <- mkTests goodCompile =<< getElms "good"
+ bads <- mkTests badCompile =<< getElms "bad"
+ return $ testGroup "Compile Tests"
+ [
+ testGroup "Good Tests" goods
+ , testGroup "Bad Tests" bads
+ ]
+
+ where getElms :: FilePath -> IO [FilePath]
+ getElms fname = find (return True) (extension ==? ".elm") (testsDir fname)
+
+ mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]
+ mkTests h = traverse setupTest
+ where setupTest f = testCase f . mkCompileTest h <$> readFile f
+
+ testsDir = "tests" "test-files"
+
+goodCompile :: Either String String -> Assertion
+goodCompile (Left err) = assertFailure err
+goodCompile (Right _) = assertBool "" True
+
+badCompile :: Either String String -> Assertion
+badCompile (Left _) = assertBool "" True
+badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"
+
+mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler
+ -> String -- ^ File Contents
+ -> Assertion
+mkCompileTest handle = handle . Elm.compile
diff --git a/tests/Tests/Property.hs b/tests/Tests/Property.hs
new file mode 100644
index 0000000..f51b2ca
--- /dev/null
+++ b/tests/Tests/Property.hs
@@ -0,0 +1,54 @@
+module Tests.Property where
+
+import Control.Applicative ((<*))
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+import Test.HUnit (assert)
+import Test.QuickCheck
+import Text.Parsec.Combinator (eof)
+import Text.PrettyPrint as P
+
+import SourceSyntax.Literal as Lit
+import SourceSyntax.Pattern as Pat
+import SourceSyntax.PrettyPrint (Pretty, pretty)
+import Parse.Helpers (IParser, iParse)
+import Parse.Literal (literal)
+import qualified Parse.Pattern as Pat (expr)
+import qualified Parse.Type as Type (expr)
+import Tests.Property.Arbitrary
+
+propertyTests :: Test
+propertyTests =
+ testGroup "Parse/Print Agreement Tests"
+ [
+ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)
+ , testProperty "Literal test" $ prop_parse_print literal
+ , testProperty "Pattern test" $ prop_parse_print Pat.expr
+ , testProperty "Type test" $ prop_parse_print Type.expr
+ ]
+
+ where
+ -- This test was autogenerated from the Pattern test and should be
+ -- left in all its ugly glory.
+ longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
+ , Pat.PRecord [
+ "q7yclkcm7k_ikstrczv_"
+ , "wQRv6gKsvvkjw4b5F"
+ ,"c9'eFfhk9FTvsMnwF_D"
+ ,"yqxhEkHvRFwZ"
+ ,"o"
+ ,"nbUlCn3y3NnkVoxhW"
+ ,"iJ0MNy3KZ_lrs"
+ ,"ug"
+ ,"sHHsX"
+ ,"mRKs9d"
+ ,"o2KiCX5'ZRzHJfRi8" ]
+ , Pat.PVar "su'BrrbPUK6I33Eq" ]
+
+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
diff --git a/tests/Tests/Property/Arbitrary.hs b/tests/Tests/Property/Arbitrary.hs
new file mode 100644
index 0000000..f58b5c7
--- /dev/null
+++ b/tests/Tests/Property/Arbitrary.hs
@@ -0,0 +1,113 @@
+{-# OPTIONS_GHC -W -fno-warn-orphans #-}
+module Tests.Property.Arbitrary where
+
+import Control.Applicative ((<$>), (<*>), pure)
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Gen
+
+import qualified Data.Set as Set
+import qualified Parse.Helpers (reserveds)
+
+import SourceSyntax.Literal
+import SourceSyntax.Pattern
+import SourceSyntax.Type hiding (listOf)
+
+instance Arbitrary Literal where
+ arbitrary = oneof [ IntNum <$> arbitrary
+ , FloatNum <$> (arbitrary `suchThat` noE)
+ , Chr <$> arbitrary
+ -- This is too permissive
+ , Str <$> arbitrary
+ -- Booleans aren't actually source syntax
+ -- , Boolean <$> arbitrary
+ ]
+ shrink l = case l of
+ IntNum n -> IntNum <$> shrink n
+ FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
+ Chr c -> Chr <$> shrink c
+ Str s -> Str <$> shrink s
+ Boolean b -> Boolean <$> shrink b
+
+noE :: Double -> Bool
+noE = notElem 'e' . show
+
+
+instance Arbitrary Pattern where
+ arbitrary = sized pat
+ where pat :: Int -> Gen Pattern
+ pat n = oneof [ pure PAnything
+ , PVar <$> lowVar
+ , PRecord <$> (listOf1 lowVar)
+ , PLiteral <$> arbitrary
+ , PAlias <$> lowVar <*> pat (n-1)
+ , PData <$> capVar <*> sizedPats
+ ]
+ where sizedPats = do
+ len <- choose (0,n)
+ let m = n `div` (len + 1)
+ vectorOf len $ pat m
+
+ shrink pat = case pat of
+ PAnything -> []
+ PVar v -> PVar <$> shrinkWHead v
+ PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
+ PLiteral l -> PLiteral <$> shrink l
+ PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
+ PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
+
+shrinkWHead :: Arbitrary a => [a] -> [[a]]
+shrinkWHead [] = error "Should be nonempty"
+shrinkWHead (x:xs) = (x:) <$> shrink xs
+
+instance Arbitrary Type where
+ arbitrary = sized tipe
+ where tipe :: Int -> Gen Type
+ tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
+ , Var <$> lowVar
+ , Data <$> capVar <*> depthTipes
+ , Record <$> fields <*> pure Nothing
+ , Record <$> fields1 <*> (Just <$> lowVar)
+ ]
+ where depthTipe = choose (0,n) >>= tipe
+ depthTipes = do
+ len <- choose (0,n)
+ let m = n `div` (len + 1)
+ vectorOf len $ tipe m
+
+ field = (,) <$> lowVar <*> depthTipe
+ fields = do
+ len <- choose (0,n)
+ let m = n `div` (len + 1)
+ vectorOf len $ (,) <$> lowVar <*> tipe m
+ fields1 = (:) <$> field <*> fields
+
+ shrink tipe = case tipe of
+ 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']
+
+capVar :: Gen String
+capVar = notReserved $ (:) <$> upper <*> listOf varLetter
+ where upper = elements ['A'..'Z']
+
+varLetter :: Gen Char
+varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
+
+notReserved :: Gen String -> Gen String
+notReserved = flip exceptFor Parse.Helpers.reserveds
+
+exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
+exceptFor g xs = g `suchThat` notAnX
+ where notAnX = flip Set.notMember xset
+ xset = Set.fromList xs
diff --git a/tests/bad/BBTArgs b/tests/test-files/bad/BBTArgs
similarity index 100%
rename from tests/bad/BBTArgs
rename to tests/test-files/bad/BBTArgs
diff --git a/tests/bad/InfiniteType.elm b/tests/test-files/bad/InfiniteType.elm
similarity index 100%
rename from tests/bad/InfiniteType.elm
rename to tests/test-files/bad/InfiniteType.elm
diff --git a/tests/bad/NonElementMain.elm b/tests/test-files/bad/NonElementMain.elm
similarity index 100%
rename from tests/bad/NonElementMain.elm
rename to tests/test-files/bad/NonElementMain.elm
diff --git a/tests/test-files/bad/Strings/ExtraClose.elm b/tests/test-files/bad/Strings/ExtraClose.elm
new file mode 100644
index 0000000..f00a493
--- /dev/null
+++ b/tests/test-files/bad/Strings/ExtraClose.elm
@@ -0,0 +1,4 @@
+
+s = " " "
+
+main = plainText s
diff --git a/tests/good/AliasSubstitution.elm b/tests/test-files/good/AliasSubstitution.elm
similarity index 100%
rename from tests/good/AliasSubstitution.elm
rename to tests/test-files/good/AliasSubstitution.elm
diff --git a/tests/good/NoExpressions.elm b/tests/test-files/good/NoExpressions.elm
similarity index 100%
rename from tests/good/NoExpressions.elm
rename to tests/test-files/good/NoExpressions.elm
diff --git a/tests/good/Otherwise.elm b/tests/test-files/good/Otherwise.elm
similarity index 100%
rename from tests/good/Otherwise.elm
rename to tests/test-files/good/Otherwise.elm
diff --git a/tests/test-files/good/Ports.elm b/tests/test-files/good/Ports.elm
new file mode 100644
index 0000000..4fea749
--- /dev/null
+++ b/tests/test-files/good/Ports.elm
@@ -0,0 +1,17 @@
+
+-- incoming
+port userID : String
+port signal : Signal Int
+port tuple : (Float,Bool)
+port array : [Int]
+port record : { x:Float, y:Float }
+
+-- outgoing
+port fortyTwo : Int
+port fortyTwo = 42
+
+port time : Signal Float
+port time = every second
+
+port students : Signal [{name:String, age:Int}]
+port students = constant []
\ No newline at end of file
diff --git a/tests/good/QuotesAndComments.elm b/tests/test-files/good/QuotesAndComments.elm
similarity index 100%
rename from tests/good/QuotesAndComments.elm
rename to tests/test-files/good/QuotesAndComments.elm
diff --git a/tests/good/Soundness/Apply.elm b/tests/test-files/good/Soundness/Apply.elm
similarity index 100%
rename from tests/good/Soundness/Apply.elm
rename to tests/test-files/good/Soundness/Apply.elm
diff --git a/tests/good/Soundness/ApplyAnnotated.elm b/tests/test-files/good/Soundness/ApplyAnnotated.elm
similarity index 100%
rename from tests/good/Soundness/ApplyAnnotated.elm
rename to tests/test-files/good/Soundness/ApplyAnnotated.elm
diff --git a/tests/good/Soundness/Id.elm b/tests/test-files/good/Soundness/Id.elm
similarity index 100%
rename from tests/good/Soundness/Id.elm
rename to tests/test-files/good/Soundness/Id.elm
diff --git a/tests/good/Soundness/IdAnnotated.elm b/tests/test-files/good/Soundness/IdAnnotated.elm
similarity index 100%
rename from tests/good/Soundness/IdAnnotated.elm
rename to tests/test-files/good/Soundness/IdAnnotated.elm
diff --git a/tests/good/Soundness/TrickyId.elm b/tests/test-files/good/Soundness/TrickyId.elm
similarity index 100%
rename from tests/good/Soundness/TrickyId.elm
rename to tests/test-files/good/Soundness/TrickyId.elm
diff --git a/tests/good/Soundness/TrickyIdAnnotated.elm b/tests/test-files/good/Soundness/TrickyIdAnnotated.elm
similarity index 100%
rename from tests/good/Soundness/TrickyIdAnnotated.elm
rename to tests/test-files/good/Soundness/TrickyIdAnnotated.elm
diff --git a/tests/test-files/good/Strings/Multiline.elm b/tests/test-files/good/Strings/Multiline.elm
new file mode 100644
index 0000000..018b76e
--- /dev/null
+++ b/tests/test-files/good/Strings/Multiline.elm
@@ -0,0 +1,6 @@
+s = """
+here's a quote: "
+
+"""
+
+main = plainText s
diff --git a/tests/test-files/good/Strings/MultilineNormal.elm b/tests/test-files/good/Strings/MultilineNormal.elm
new file mode 100644
index 0000000..b6a2b15
--- /dev/null
+++ b/tests/test-files/good/Strings/MultilineNormal.elm
@@ -0,0 +1,6 @@
+s = "
+here's a quote: \"
+
+"
+
+main = plainText s
diff --git a/tests/good/Unify/LockedVars.elm b/tests/test-files/good/Unify/LockedVars.elm
similarity index 100%
rename from tests/good/Unify/LockedVars.elm
rename to tests/test-files/good/Unify/LockedVars.elm
diff --git a/tests/good/Unify/NonHomogeneousRecords.elm b/tests/test-files/good/Unify/NonHomogeneousRecords.elm
similarity index 100%
rename from tests/good/Unify/NonHomogeneousRecords.elm
rename to tests/test-files/good/Unify/NonHomogeneousRecords.elm