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

Merge branch 'dev'

Browse source
This commit is contained in:
Evan Czaplicki 2014-01-18 20:34:08 +01:00
commit 892464e94d
86 changed files with 2236 additions and 1523 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -10,3 +10,4 @@ cabal-dev
data
*/ElmFiles/*
.DS_Store
*~

3
.travis.yml Normal file
View file

@ -0,0 +1,3 @@
language: haskell
ghc:
- 7.6

58
Elm.cabal
View file

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

1
README.md
View file

@ -1,5 +1,6 @@
Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).
[![Build Status](https://travis-ci.org/evancz/Elm.png)](https://travis-ci.org/evancz/Elm)
## Install

94
compiler/Build/Dependencies.hs
View file

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

192
compiler/Build/File.hs
View file

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

46
compiler/Build/Interface.hs Normal file
View file

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

10
compiler/Build/Print.hs
View file

@ -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)
mapM_ print (List.intersperse (P.text " ") errs)
failure :: String -> IO a
failure msg = hPutStrLn stderr msg >> exitFailure

57
compiler/Build/Source.hs
View file

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

1
compiler/Build/Utils.hs
View file

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -W #-}
module Build.Utils where
import System.FilePath ((</>), replaceExtension)

7
compiler/Compiler.hs
View file

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

38
compiler/Docs.hs
View file

@ -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 ]
, "type" .= foldr Lambda tipe tipes ]
instance ToJSON D.Derivation where
toJSON = toJSON . show

2
compiler/Elm/Internal/Utils.hs
View file

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

42
compiler/Generate/Cases.hs
View file

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

211
compiler/Generate/JavaScript.hs
View file

@ -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 = "<div style=\"height:0;width:0;\">&nbsp;</div>"
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)

37
compiler/Generate/JavaScript/Helpers.hs Normal file
View file

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

130
compiler/Generate/JavaScript/Ports.hs Normal file
View file

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

17
compiler/Generate/Noscript.hs
View file

@ -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 -> "<p>" ++ s ++ "</p>") (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

52
compiler/InterfaceSerialization.hs
View file

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

65
compiler/Metadata/Prelude.hs
View file

@ -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"
, " <http://github.com/evancz/Elm/issues> 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

31
compiler/Parse/Binop.hs
View file

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

117
compiler/Parse/Declaration.hs
View file

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

45
compiler/Parse/Expression.hs
View file

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

116
compiler/Parse/Helpers.hs
View file

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

7
compiler/Parse/Literal.hs
View file

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

3
compiler/Parse/Module.hs
View file

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

43
compiler/Parse/Parse.hs
View file

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

14
compiler/Parse/Pattern.hs
View file

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

21
compiler/Parse/Type.hs
View file

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

115
compiler/SourceSyntax/Declaration.hs
View file

@ -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 <https://github.com/evancz/Elm/issues>"
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)

153
compiler/SourceSyntax/Expression.hs
View file

@ -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 $ "<port:" ++ name ++ ">"
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

2
compiler/SourceSyntax/Helpers.hs
View file

@ -1,4 +1,4 @@
{-# OPTIONS_GHC -Wall #-}
module SourceSyntax.Helpers where
import qualified Data.Char as Char

9
compiler/SourceSyntax/Literal.hs
View file

@ -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)
Chr c -> PP.text . show $ c
Str s -> PP.text . show $ s
Boolean bool -> PP.text (show bool)

71
compiler/SourceSyntax/Module.hs
View file

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

33
compiler/SourceSyntax/Pattern.hs
View file

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

49
compiler/SourceSyntax/Type.hs
View file

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

2
compiler/SourceSyntax/Variable.hs
View file

@ -1,2 +0,0 @@
module SourceSyntax.Variable where

152
compiler/Transform/Canonicalize.hs
View file

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

176
compiler/Transform/Check.hs
View file

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

63
compiler/Transform/Declaration.hs Normal file
View file

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

31
compiler/Transform/Definition.hs Normal file
View file

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

55
compiler/Transform/Expression.hs Normal file
View file

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

136
compiler/Transform/Optimize.hs
View file

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

24
compiler/Transform/SafeNames.hs
View file

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

152
compiler/Transform/SortDefinitions.hs
View file

@ -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 <https://github.com/evancz/Elm/issues>."
, "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)

17
compiler/Transform/Substitute.hs
View file

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

36
compiler/Type/Alias.hs
View file

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

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

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

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

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

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

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

26
compiler/Type/Environment.hs
View file

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

127
compiler/Type/ExtraChecks.hs
View file

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

15
compiler/Type/Inference.hs
View file

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

8
compiler/Type/Solve.hs
View file

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

8
compiler/Type/State.hs
View file

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

33
compiler/Type/Type.hs
View file

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

6
compiler/Type/Unify.hs
View file

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

18
libraries/Basics.elm
View file

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

168
libraries/Dict.elm
View file

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

2
libraries/Native/JavaScript.js
View file

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

83
libraries/Native/Ports.js Normal file
View file

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

116
runtime/Init.js
View file

@ -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 = "<br/>&nbsp; &nbsp; Open the developer console for more details."
Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');
@ -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?!");

16
runtime/Utils.js
View file

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

25
tests/Main.hs
View file

@ -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
main = defaultMain [ compilerTests
, propertyTests
]

45
tests/Tests/Compiler.hs Normal file
View file

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

54
tests/Tests/Property.hs Normal file
View file

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

113
tests/Tests/Property/Arbitrary.hs Normal file
View file

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

0
tests/bad/BBTArgs → tests/test-files/bad/BBTArgs
View file

0
tests/bad/InfiniteType.elm → tests/test-files/bad/InfiniteType.elm
View file

0
tests/bad/NonElementMain.elm → tests/test-files/bad/NonElementMain.elm
View file

4
tests/test-files/bad/Strings/ExtraClose.elm Normal file
View file

@ -0,0 +1,4 @@
s = " " "
main = plainText s

0
tests/good/AliasSubstitution.elm → tests/test-files/good/AliasSubstitution.elm
View file

0
tests/good/NoExpressions.elm → tests/test-files/good/NoExpressions.elm
View file

0
tests/good/Otherwise.elm → tests/test-files/good/Otherwise.elm
View file

17
tests/test-files/good/Ports.elm Normal file
View file

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

0
tests/good/QuotesAndComments.elm → tests/test-files/good/QuotesAndComments.elm
View file

0
tests/good/Soundness/Apply.elm → tests/test-files/good/Soundness/Apply.elm
View file

0
tests/good/Soundness/ApplyAnnotated.elm → tests/test-files/good/Soundness/ApplyAnnotated.elm
View file

0
tests/good/Soundness/Id.elm → tests/test-files/good/Soundness/Id.elm
View file

0
tests/good/Soundness/IdAnnotated.elm → tests/test-files/good/Soundness/IdAnnotated.elm
View file

0
tests/good/Soundness/TrickyId.elm → tests/test-files/good/Soundness/TrickyId.elm
View file

0
tests/good/Soundness/TrickyIdAnnotated.elm → tests/test-files/good/Soundness/TrickyIdAnnotated.elm
View file

6
tests/test-files/good/Strings/Multiline.elm Normal file
View file

@ -0,0 +1,6 @@
s = """
here's a quote: "
"""
main = plainText s

6
tests/test-files/good/Strings/MultilineNormal.elm Normal file
View file

@ -0,0 +1,6 @@
s = "
here's a quote: \"
"
main = plainText s

0
tests/good/Unify/LockedVars.elm → tests/test-files/good/Unify/LockedVars.elm
View file

0
tests/good/Unify/NonHomogeneousRecords.elm → tests/test-files/good/Unify/NonHomogeneousRecords.elm
View file