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

Merge branch 'master' into dev

Browse source
This commit is contained in:
Evan Czaplicki 2013-08-19 11:23:12 -07:00
commit 476e87ffc6
68 changed files with 547 additions and 582 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -7,5 +7,6 @@ cabal-dev
*.aes
*.elmi
*.elmo
data
*/ElmFiles/*
.DS_Store

8
Elm.cabal
View file

@ -1,5 +1,5 @@
Name: Elm
Version: 0.8.0.3
Version: 0.9.0.2
Synopsis: The Elm language module.
Description: Elm aims to make client-side web-development more pleasant.
It is a statically/strongly typed, functional reactive
@ -21,7 +21,7 @@ Category: Compiler, Language
Build-type: Custom
Extra-source-files: changelog.txt
Data-dir: dist/data
Data-dir: data
Data-files: elm-runtime.js interfaces.data
Cabal-version: >=1.9
@ -167,5 +167,5 @@ Executable elm
Test-Suite test-elm
Type: exitcode-stdio-1.0
Hs-Source-Dirs: tests
Main-is: Everything.hs
build-depends: base
Main-is: Main.hs
build-depends: base, directory, HTF

8
README.md
View file

@ -3,14 +3,6 @@ Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/)
## Install
#### On Mac OSX
Use [the installer](https://dl.dropboxusercontent.com/u/5850974/Elm/Elm.pkg) and you are done.
Let us know on [the list](https://groups.google.com/forum/?fromgroups#!forum/elm-discuss)
if you have any trouble.
#### On any platform
Download the [Haskell Platform 2012.2.0.0](http://hackage.haskell.org/platform/).
Elm definitely works with GHC 7.4, so newer versions of the Haskell Platform may work too.
Once the Haskell Platform is installed:

29
Setup.hs
View file

@ -11,6 +11,7 @@ import System.Process
import Control.Monad
import qualified Data.Binary as Binary
import qualified Data.ByteString.Lazy as BS
-- Part 1
-- ------
@ -32,10 +33,10 @@ import qualified Data.Binary as Binary
-- Elm.cabal expects the generated files to end up in dist/data
-- git won't look in dist + cabal will clean it
rtsDir :: LocalBuildInfo -> FilePath
rtsDir lbi = buildDir lbi </> ".." </> "data"
rtsDir lbi = "data"
tempDir :: LocalBuildInfo -> FilePath
tempDir lbi = buildDir lbi </> ".." </> "temp"
tempDir lbi = "temp"
-- The runtime is called:
rts :: LocalBuildInfo -> FilePath
@ -95,24 +96,25 @@ myPostBuild as bfs pd lbi = do
buildInterfaces lbi elmis
putStrLn "Custom build step: build elm-runtime.js"
buildRuntime lbi elmos
removeDirectoryRecursive ("dist" </> "temp")
removeDirectoryRecursive (tempDir lbi)
postBuild simpleUserHooks as bfs pd lbi
compileLibraries lbi = do
let temp = tempDir lbi -- dist/temp
rts = rtsDir lbi -- dist/data
let temp = tempDir lbi -- temp
rts = rtsDir lbi -- data
createDirectoryIfMissing True temp
createDirectoryIfMissing True rts
out_c <- canonicalizePath temp -- dist/temp (root folder)
out_c <- canonicalizePath temp -- temp (root folder)
elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm
rtd_c <- canonicalizePath rts -- dist/data (for docs.json)
rtd_c <- canonicalizePath rts -- data
let make file = do
-- replace 'system' call with 'runProcess' which handles args better
-- and allows env variable "Elm_datadir" which is used by LoadLibraries
-- to find docs.json
let args = ["--only-js","--make","--no-prelude","--output-directory="++out_c,file]
let args = [ "--only-js", "--make", "--no-prelude"
, "--cache-dir="++out_c, "--build-dir="++out_c, file ]
arg = Just [("Elm_datadir", rtd_c)]
handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing
exitCode <- waitForProcess handle
@ -130,8 +132,15 @@ buildInterfaces :: LocalBuildInfo -> [FilePath] -> IO ()
buildInterfaces lbi elmis = do
createDirectoryIfMissing True (rtsDir lbi)
let ifaces = interfaces lbi
Binary.encodeFile ifaces (length elmis)
mapM_ (\elmi -> readFile elmi >>= appendFile ifaces) elmis
ifaceHandle <- openBinaryFile ifaces WriteMode
BS.hPut ifaceHandle (Binary.encode (length elmis))
let append file = do
handle <- openBinaryFile file ReadMode
bits <- hGetContents handle
length bits `seq` hPutStr ifaceHandle bits
hClose handle
mapM_ append elmis
hClose ifaceHandle
buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()
buildRuntime lbi elmos = do

15
changelog.txt
View file

@ -6,7 +6,11 @@ Build Improvements:
* Major speed improvements to type-checker
* Type-checker should catch _all_ type errors now
* Module-level compilation, only re-compile if necessary
* Import type aliases between modules
* Import types and type aliases between modules
* Intermediate files are generated to avoid unneeded recompilation
and shorten compile time. These files go in ElmFiles/ by default
* Generated files are placed in ElmFiles/ by default, replicating
the directory structure of your source code.
Error Messages:
* Cross-module type errors
@ -22,14 +26,21 @@ Syntax:
* Record Constructors
* Record type aliases can be closed on the zeroth column
* (,,) syntax in types
* "(+) = " is permitted
* Allow infix op definitions without args: (*) = add
* Unparenthesized if, let, case, lambda at end of binary expressions
elm-server:
* Build multi-module projects
* Report all errors in browser
Libraries:
* Detect hovering over any Element
* Set alpha of arbitrary forms in collages
* Switch Text.height to use px instead of em
Bug Fixes:
* Many bug fixes for collage, especially when rendering Elements.
Website:
* Hot-swapping
* Much faster page load with pre-compiled Elm files (Max New)

82
compiler/Compiler.hs
View file

@ -10,16 +10,19 @@ import System.Console.CmdArgs hiding (program)
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import GHC.Conc
import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
import qualified Text.Blaze.Html.Renderer.String as Normal
import qualified Text.Jasmine as JS
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.ByteString.Lazy as L
import qualified Metadata.Prelude as Prelude
import qualified Transform.Canonicalize as Canonical
import SourceSyntax.Module
import Parse.Module (getModuleName)
import Initialize (buildFromSource, getSortedDependencies)
import Generate.JavaScript (jsModule)
import Generate.Html (createHtml, JSStyle(..), JSSource(..))
@ -40,7 +43,8 @@ data Flags =
, scripts :: [FilePath]
, no_prelude :: Bool
, minify :: Bool
, output_directory :: FilePath
, cache_dir :: FilePath
, build_dir :: FilePath
}
deriving (Data,Typeable,Show,Eq)
@ -62,8 +66,10 @@ flags = Flags
&= help "Do not import Prelude by default, used only when compiling standard libraries."
, minify = False
&= help "Minify generated JavaScript and HTML"
, output_directory = "ElmFiles" &= typFile
&= help "Output files to directory specified. Defaults to ElmFiles/ directory."
, cache_dir = "cache" &= typFile
&= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
, build_dir = "build" &= typFile
&= help "Directory for generated HTML and JS files. Defaults to build/ directory."
} &= help "Compile Elm programs to HTML, CSS, and JavaScript."
&= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
@ -78,25 +84,32 @@ compileArgs flags =
fs -> mapM_ (build flags) fs
file :: Flags -> FilePath -> String -> FilePath
file flags filePath ext = output_directory flags </> replaceExtension filePath ext
buildPath :: Flags -> FilePath -> String -> FilePath
buildPath flags filePath ext = build_dir flags </> replaceExtension filePath ext
cachePath :: Flags -> FilePath -> String -> FilePath
cachePath flags filePath ext = cache_dir flags </> replaceExtension filePath ext
elmo :: Flags -> FilePath -> FilePath
elmo flags filePath = file flags filePath "elmo"
elmo flags filePath = cachePath flags filePath "elmo"
elmi :: Flags -> FilePath -> FilePath
elmi flags filePath = file flags filePath "elmi"
elmi flags filePath = cachePath flags filePath "elmi"
buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO ModuleInterface
buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String,ModuleInterface)
buildFile flags moduleNum numModules interfaces filePath =
do compiled <- alreadyCompiled
if not compiled then compile
else getInterface `fmap` Binary.decodeFile (elmi flags filePath)
case compiled of
False -> compile
True -> do
handle <- openBinaryFile (elmi flags filePath) ReadMode
bits <- L.hGetContents handle
let info :: (String, ModuleInterface)
info = Binary.decode bits
L.length bits `seq` hClose handle
return info
where
getInterface :: (String, ModuleInterface) -> ModuleInterface
getInterface = snd
alreadyCompiled :: IO Bool
alreadyCompiled = do
existsi <- doesFileExist (elmi flags filePath)
@ -110,16 +123,18 @@ buildFile flags moduleNum numModules interfaces filePath =
number :: String
number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
name :: String
name = List.intercalate "." (splitDirectories (dropExtensions filePath))
compile :: IO ModuleInterface
compile :: IO (String,ModuleInterface)
compile = do
source <- readFile filePath
let name = case getModuleName source of
Just n -> n
Nothing -> "Main"
putStrLn $ concat [ number, " Compiling ", name
, replicate (max 1 (20 - length name)) ' '
, "( " ++ filePath ++ " )" ]
source <- readFile filePath
createDirectoryIfMissing True (output_directory flags)
createDirectoryIfMissing True (cache_dir flags)
createDirectoryIfMissing True (build_dir flags)
metaModule <-
case buildFromSource (no_prelude flags) interfaces source of
Left errors -> do
@ -139,9 +154,11 @@ buildFile flags moduleNum numModules interfaces filePath =
iAliases = aliases metaModule
}
createDirectoryIfMissing True . dropFileName $ elmi flags filePath
Binary.encodeFile (elmi flags filePath) (name,interface)
handle <- openBinaryFile (elmi flags filePath) WriteMode
L.hPut handle (Binary.encode (name,interface))
hClose handle
writeFile (elmo flags filePath) (jsModule metaModule)
return interface
return (name,interface)
printTypes metaModule = do
putStrLn ""
@ -161,18 +178,20 @@ build flags rootFile = do
let noPrelude = no_prelude flags
files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]
let ifaces = if noPrelude then Map.empty else Prelude.interfaces
interfaces <- buildFiles flags (length files) ifaces files
(moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files
js <- foldM appendToOutput "" files
case only_js flags of
True -> do
putStr "Generating JavaScript ... "
writeFile (file flags rootFile "js") (genJs js)
writeFile (buildPath flags rootFile "js") (genJs js)
putStrLn "Done"
False -> do
putStr "Generating HTML ... "
runtime <- getRuntime flags
let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) ""
writeFile (file flags rootFile "html") html
let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) moduleName ""
htmlFile = buildPath flags rootFile "html"
createDirectoryIfMissing True (takeDirectory htmlFile)
writeFile htmlFile html
putStrLn "Done"
where
@ -187,10 +206,9 @@ build flags rootFile = do
[ Source (if minify flags then Minified else Readable) js ]
buildFiles :: Flags -> Int -> Interfaces -> [FilePath] -> IO Interfaces
buildFiles _ _ interfaces [] = return interfaces
buildFiles flags numModules interfaces (filePath:rest) = do
interface <- buildFile flags (numModules - length rest) numModules interfaces filePath
let moduleName = List.intercalate "." . splitDirectories $ dropExtensions filePath
interfaces' = Map.insert moduleName interface interfaces
buildFiles flags numModules interfaces' rest
buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
buildFiles flags numModules interfaces _ (filePath:rest) = do
(name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath
let interfaces' = Map.insert name interface interfaces
buildFiles flags numModules interfaces' name rest

26
compiler/Generate/Html.hs
View file

@ -40,27 +40,10 @@ generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browse
-> String -- ^ The page title
-> String -- ^ The elm source code.
-> H.Html
generateHtml libLoc title source = H.span "broken for now"
{--
case buildFromSource True source of
Right modul -> createHtml libLoc title [] "" title [modul]
Left err -> createHtml Readable libLoc title (Right $ showErr err)
(H.noscript "") "Main"
--}
{--
modulesToHtml :: FilePath -> String -> []
modulesToHtml libLoc title scripts nscrpt modules =
createHtml jsStyle libLoc title' js noscript altTitle
where
js = Right $ jss ++ concatMap jsModule modules
noscript = if nscrpt then extractNoscript $ last modules else ""
title' = if null title then altTitle else title
altTitle = intercalate "." names
where Module names _ _ _ = last modules
--}
generateHtml libLoc title source = error "function 'generateHtml' is unimplemented for now"
createHtml :: FilePath -> String -> [JSSource] -> String -> H.Html
createHtml libLoc title scripts noscript =
createHtml :: FilePath -> String -> [JSSource] -> String -> String -> H.Html
createHtml libLoc title scripts moduleName noscript =
H.docTypeHtml $ do
H.head $ do
H.meta ! A.charset "UTF-8"
@ -68,5 +51,6 @@ createHtml libLoc title scripts noscript =
makeScript (Link libLoc)
mapM_ makeScript scripts
H.body $ do
H.script ! A.type_ "text/javascript" $ preEscapedToMarkup ("Elm.fullscreen(Elm.Main)" :: String)
H.script ! A.type_ "text/javascript" $
preEscapedToMarkup ("Elm.fullscreen(Elm." ++ moduleName ++ ")")
H.noscript $ preEscapedToMarkup noscript

59
compiler/Generate/JavaScript.hs
View file

@ -1,4 +1,4 @@
module Generate.JavaScript (showErr, jsModule) where
module Generate.JavaScript (jsModule) where
import Control.Arrow (first,second)
import Control.Monad (liftM,(<=<),join,ap)
@ -15,15 +15,6 @@ import SourceSyntax.Everything
import SourceSyntax.Location
import qualified Transform.SortDefinitions as SD
deprime :: String -> String
deprime = map (\c -> if c == '\'' then '$' else c)
showErr :: String -> String
showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
where msg = show . concatMap (++"<br>") . lines $ err
body = "var T = Elm.Text(elm);\n\
\return { main : T.text(T.monospace(" ++ msg ++ ")) };"
indent = concatMap f
where f '\n' = "\n "
f c = [c]
@ -84,7 +75,7 @@ jsModule modul =
jsExports = setup ("elm" : names modul) ++
ret (assign' ("elm." ++ modName) (brackets exs))
where
exs = indent . commaSep . concatMap (pair . deprime) $ "_op" : exports modul
exs = indent . commaSep . concatMap pair $ "_op" : exports modul
pair x | isOp x = []
| otherwise = ["\n" ++ x ++ " : " ++ x]
@ -129,14 +120,13 @@ instance ToJS (Def t v) where
-- TODO: Make this handle patterns besides plain variables
toJS (Def (PVar x) e)
| isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e
| otherwise = assign (deprime x) `liftM` toJS' e
| otherwise = assign x `liftM` toJS' e
toJS (Def pattern e@(L s _)) =
do n <- guid
let x = "_" ++ show n
var = L s . Var
toDef y' = let y = deprime y' in
Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])
stmt <- assign x `liftM` toJS' e
vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern
return (stmt ++ vars)
@ -154,18 +144,18 @@ toJS' (L span expr) =
Case e cases -> caseToJS span e cases
_ -> toJS expr
remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"
addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"
remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"
access x e = e ++ "." ++ deprime x
where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
access x e = e ++ "." ++ x
makeRecord kvs = record `liftM` collect kvs
where
combine r (k,v) = Map.insertWith (++) k v r
collect = liftM (List.foldl' combine Map.empty) . mapM prep
prep (k, e) =
do v <- toJS' e
return (deprime k, [v])
return (k, [v])
fields fs =
brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
hidden = fields . map (second jsList) .
@ -186,7 +176,7 @@ instance ToJS Literal where
instance ToJS (Expr t v) where
toJS expr =
case expr of
Var x -> return (deprime x)
Var x -> return x
Literal lit -> toJS lit
Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
Access e x -> access x `liftM` toJS' e
@ -197,16 +187,19 @@ instance ToJS (Expr t v) where
Record fs -> makeRecord fs
Binop op e1 e2 -> binop op e1 e2
Lambda p e@(L s _) -> liftM (fastFunc . ret) (toJS' body)
Lambda p e@(L s _) -> liftM fastFunc (toJS' body)
where
fastFunc body
| length args < 2 || length args > 9 = foldr jsFunc body args
| otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)
| length args < 2 || length args > 9 =
foldr (\arg bod -> jsFunc arg (ret bod)) body args
| otherwise =
"F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret body))
(args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])
depattern (pattern,n) (args, body) =
case pattern of
PVar x -> (deprime x : args, body)
PVar x -> (x : args, body)
_ -> let arg = "arg" ++ show n
in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))
@ -274,7 +267,7 @@ caseToJS span e ps = do
(tempVar,match) <- caseToMatch ps
e' <- toJS' e
let (match',stmt) = case e of
L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")
L _ (Var x) -> (matchSubst [(tempVar,x)] match, "")
_ -> (match, assign tempVar e')
matches <- matchToJS span match'
return $ jsFunc "" (stmt ++ matches) ++ "()"
@ -304,14 +297,14 @@ matchToJS span match =
clauseToJS span var (Clause value vars e) = do
let vars' = map (\n -> var ++ "._" ++ show n) [0..]
s <- matchToJS span $ matchSubst (zip vars vars') e
return $ concat [ "\ncase ", case value of
Right (Boolean True) -> "true"
Right (Boolean False) -> "false"
Right lit -> show lit
Left name -> quoted $ case List.elemIndices '.' name of
[] -> name
is -> drop (last is + 1) name
, ":", indent s ]
pattern <- case value of
Right (Boolean True) -> return "true"
Right (Boolean False) -> return "false"
Right lit -> toJS lit
Left name -> return . quoted $ case List.elemIndices '.' name of
[] -> name
is -> drop (last is + 1) name
return $ concat [ "\ncase ", pattern, ":", indent s ]
jsNil = "_L.Nil"
jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"

21
compiler/Language/Elm.hs
View file

@ -1,27 +1,21 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{- | This module exports the functions necessary for compiling Elm code into the
respective HTML, CSS, and JS code.
The documentation for the Elm language is available at
<http://elm-lang.org/Documentation.elm>, and many interactive examples are
available at <http://elm-lang.org/Examples.elm>
Example implementations using Yesod and Happstack are available
at <https://github.com/tazjin/Elm/tree/master/Examples>
-}
module Language.Elm (compile, toHtml, moduleName, runtime, docs) where
module Language.Elm (compile, moduleName, runtime) where
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Version (showVersion)
import Generate.JavaScript (showErr, jsModule)
import Generate.JavaScript (jsModule)
import Generate.Html (generateHtml)
import Initialize (buildFromSource)
import Parse.Helpers
import Parse.Module (moduleDef)
import Parse.Module (getModuleName)
import SourceSyntax.Module
import Text.Blaze.Html (Html)
import Text.Parsec (option,optional)
import qualified Text.PrettyPrint as P
import qualified Metadata.Prelude as Prelude
import Paths_Elm
@ -36,14 +30,7 @@ compile source =
-- |This function extracts the module name of a given source program.
moduleName :: String -> Maybe String
moduleName source = case iParse getModuleName "" source of
Right name -> Just name
Left _ -> Nothing
where
getModuleName = do
optional freshLine
(names, _) <- moduleDef
return (List.intercalate "." names)
moduleName = getModuleName
-- |This function compiles Elm code into a full HTML page.
toHtml :: String -- ^ Location of elm-min.js as expected by the browser

12
compiler/Metadata/Prelude.hs
View file

@ -6,9 +6,11 @@ import qualified Paths_Elm as Path
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import SourceSyntax.Module
import qualified Data.Binary as Binary
import qualified Data.ByteString.Lazy as BS
add :: Module t v -> Module t v
@ -47,5 +49,11 @@ safeReadDocs name =
readDocs :: FilePath -> IO Interfaces
readDocs name = do
exists <- doesFileExist name
if exists then Map.fromList `fmap` Binary.decodeFile name
else ioError . userError $ "File Not Found"
case exists of
False -> ioError . userError $ "File Not Found"
True -> do
handle <- openBinaryFile name ReadMode
bits <- BS.hGetContents handle
let ifaces = Map.fromList (Binary.decode bits)
BS.length bits `seq` hClose handle
return ifaces

14
compiler/Parse/Binop.hs
View file

@ -80,25 +80,27 @@ splitLevel table n e eops =
joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)
joinL [e] [] = return e
joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops
joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)
joinR [e] [] = return e
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
return (merge a e (Binop op a e))
joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc
getAssoc table n eops
| all (==L) assocs = return L
| all (==R) assocs = return R
| all (==N) assocs = case assocs of [_] -> return N
_ -> fail msg
_ -> failure (msg "precedence")
| otherwise = failure (msg "associativity")
where levelOps = filter (hasLevel table n) eops
assocs = map (opAssoc table . fst) levelOps
msg = concat [ "Conflicting precedence for binary operators ("
, intercalate ", " (map fst eops), "). "
, "Consider adding parentheses to disambiguate." ]
msg problem =
concat [ "Conflicting " ++ problem ++ " for binary operators ("
, intercalate ", " (map fst eops), "). "
, "Consider adding parentheses to disambiguate." ]
infixStmt :: IParser (Int, Assoc, String)
infixStmt =

24
compiler/Parse/Helpers.hs
View file

@ -49,10 +49,13 @@ rLabel = lowVar
innerVarChar :: IParser Char
innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
deprime :: String -> String
deprime = map (\c -> if c == '\'' then '$' else c)
makeVar :: IParser Char -> IParser String
makeVar p = do v <- (:) <$> p <*> many innerVarChar
guard (v `notElem` reserveds)
return v
return (deprime v)
reserved :: String -> IParser String
reserved word =
@ -110,11 +113,20 @@ spaceSep1 p = (:) <$> p <*> spacePrefix p
spacePrefix p = constrainedSpacePrefix p (\_ -> return ())
constrainedSpacePrefix p constraint =
many . try $ do
n <- whitespace
constraint n
indented
p
many $ choice [ try (spacing >> lookAhead (oneOf "[({")) >> p
, try (spacing >> p)
]
where
spacing = do
n <- whitespace
constraint n
indented
failure msg = do
inp <- getInput
setInput ('x':inp)
anyToken
fail msg
followedBy a b = do x <- a ; b ; return x

22
compiler/Parse/Literal.hs
View file

@ -19,13 +19,25 @@ num = fmap toLit (preNum <?> "number")
string "."
('.':) <$> many1 digit
chr :: IParser Literal
chr = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
<?> "character"
str :: IParser Literal
str = choice [ let quote = try (string "\"\"\"")
in quote >> Str <$> manyTill (backslashed <|> anyChar) quote
str = choice [ quote >> str <$> manyTill (backslashed <|> anyChar) quote
, liftM Str . expecting "string" . betwixt '"' '"' . many $
backslashed <|> satisfy (/='"')
]
where
quote = try (string "\"\"\"")
str = Str . dewindows
chr :: IParser Literal
chr = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
<?> "character"
-- 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
_ -> []

13
compiler/Parse/Module.hs
View file

@ -1,5 +1,5 @@
module Parse.Module (moduleDef, imports) where
module Parse.Module (moduleDef, getModuleName, imports) where
import Control.Applicative ((<$>), (<*>))
import Data.List (intercalate)
@ -11,6 +11,17 @@ import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)
varList :: IParser [String]
varList = parens $ commaSep1 (var <|> parens symOp)
getModuleName :: String -> Maybe String
getModuleName source =
case iParse getModuleName "" source of
Right name -> Just name
Left _ -> Nothing
where
getModuleName = do
optional freshLine
(names, _) <- moduleDef
return (intercalate "." names)
moduleDef :: IParser ([String], [String])
moduleDef = do
try (reserved "module")

68
compiler/Parse/Pattern.hs
View file

@ -64,71 +64,3 @@ expr :: IParser Pattern
expr = do
patterns <- consSep1 (patternConstructor <|> term)
asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
{--
extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
extract pattern body@(L t s _) =
let loc = L t s in
let fn x e = (x,e) in
case pattern of
PAnything -> return $ fn "_" body
PVar x -> return $ fn x body
PAlias x PAnything -> return $ fn x body
PAlias x p -> do
(x', body') <- extract p body
return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')
PData name ps -> do
x <- guid
let a = '_' : show x
return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]
PRecord fs -> do
x <- guid
let a = '_' : show x
toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
return . fn a . loc $ Let (map toDef fs) body
extracts :: [Pattern] -> LExpr t v -> Unique ([String], LExpr t v)
extracts ps body = go [] (reverse ps) body
where go args [] body = return (args, body)
go args (p:ps) body = do (x,e) <- extract p body
go (x:args) ps e
flatten :: [Pattern] -> LExpr t v -> Unique (IParser [Def t v])
flatten patterns exp@(L t s _) =
let loc = L t s in
case patterns of
PVar f : args -> do
(as,e) <- extracts args exp
return . return $
if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]
else [ FnDef f as e ]
[p] -> return `liftM` matchSingle p exp p
_ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++
") cannot be used on the left-hand side of an assign statement."
matchSingle :: Pattern -> LExpr t v -> Pattern -> Unique [Def t v]
matchSingle pat exp@(L t s _) p =
let loc = L t s in
case p of
PData _ ps -> do
x <- guid
let v = '_' : show x
dss <- mapM (matchSingle pat . loc $ Var v) ps
return (FnDef v [] exp : concat dss)
PVar x ->
return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
PAlias x p' -> do
subPat <- matchSingle p' (loc $ Var x) p'
return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat
PRecord fs -> do
a <- (\x -> '_' : show x) `liftM` guid
let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
return (FnDef a [] exp : map toDef fs)
PAnything -> return []
--}

2
compiler/Parse/Type.hs
View file

@ -64,7 +64,7 @@ expr :: IParser T.Type
expr =
do t1 <- app <|> term
whitespace
arr <- optionMaybe arrow
arr <- optionMaybe (try arrow)
whitespace
case arr of
Just _ -> T.Lambda t1 <$> expr

12
compiler/SourceSyntax/Expression.hs
View file

@ -75,24 +75,24 @@ instance Pretty (Expr t v) where
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))
Access e x -> prettyParens e <> P.text "." <> P.text x
Remove e x -> P.braces (pretty e <+> P.text "-" <+> P.text x)
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 "-" <+> P.text y <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)
P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.text "=" <+> pretty v)
Insert e x v ->
P.braces (pretty e <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)
P.braces (pretty e <+> P.text "|" <+> variable x <+> P.text "=" <+> pretty v)
Modify e fs ->
P.braces $ P.hang (pretty e <+> P.text "|")
4
(commaSep $ map field fs)
where
field (x,e) = P.text x <+> P.text "<-" <+> pretty e
field (x,e) = variable x <+> P.text "<-" <+> pretty e
Record fs ->
P.braces $ P.nest 2 (commaSep $ map field fs)
where
field (x,e) = P.text x <+> P.text "=" <+> pretty e
field (x,e) = variable x <+> P.text "=" <+> pretty e
Markdown _ -> P.text "[markdown| ... |]"

2
compiler/SourceSyntax/Location.hs
View file

@ -49,7 +49,7 @@ instance Show SrcSpan where
Span start end _ ->
case line start == line end of
False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
True -> "line " ++ show (line end) ++ ", column " ++
True -> "on line " ++ show (line end) ++ ", column " ++
show (column start) ++ " to " ++ show (column end)
instance Show e => Show (Located e) where

4
compiler/SourceSyntax/Pattern.hs
View file

@ -27,8 +27,8 @@ instance Pretty Pattern where
case pattern of
PVar x -> variable x
PLiteral lit -> pretty lit
PRecord fs -> PP.braces (commaCat $ map PP.text fs)
PAlias x p -> prettyParens p <+> PP.text "as" <+> PP.text x
PRecord fs -> PP.braces (commaCat $ map variable fs)
PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
PAnything -> PP.text "_"
PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
where isCons = case hd of

7
compiler/SourceSyntax/PrettyPrint.hs
View file

@ -15,4 +15,9 @@ commaSep docs = sep (punctuate comma docs)
parensIf bool doc = if bool then parens doc else doc
variable x = parensIf (Help.isOp x) (text x)
variable x =
if Help.isOp x then parens (text x)
else text (reprime x)
reprime :: String -> String
reprime = map (\c -> if c == '$' then '\'' else c)

19
compiler/Transform/Canonicalize.hs
View file

@ -61,7 +61,7 @@ metadataModule ifaces modul =
second f (a,b) = (,) a `fmap` f b
third f (a,b,c) = (,,) a b `fmap` f c
renameType' =
Either.either (\err -> Left [P.text err]) return . renameType (replace initialEnv)
Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
get1 (a,_,_) = a
canon (name, importMethod) =
@ -92,12 +92,12 @@ extend env pattern = Map.union (Map.fromList (zip xs xs)) env
where xs = Set.toList (SD.boundVars pattern)
replace :: Env -> String -> Either String String
replace env v =
replace :: String -> Env -> String -> Either String String
replace variable env v =
if List.isPrefixOf "Native." v then return v else
case Map.lookup v env of
Just v' -> return v'
Nothing -> Left $ "Could not find variable '" ++ v ++ "'." ++ msg
Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg
where
matches = filter (List.isInfixOf v) (Map.keys env)
msg = if null matches then "" else
@ -129,12 +129,12 @@ rename env lexpr@(L s expr) =
frnm (f,e) = (,) f `liftM` rename env e
Binop op e1 e2 ->
do op' <- format (replace env op)
do op' <- format (replace "variable" env op)
Binop op' `liftM` rnm e1 `ap` rnm e2
Lambda pattern e ->
let env' = extend env pattern in
Lambda pattern `liftM` rename env' e
Lambda `liftM` format (renamePattern env' pattern) `ap` rename env' e
App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2
@ -149,9 +149,10 @@ rename env lexpr@(L s expr) =
Def p exp ->
Def `liftM` format (renamePattern env' p) `ap` rename env' exp
TypeAnnotation name tipe ->
TypeAnnotation name `liftM` renameType (format . replace env') tipe
TypeAnnotation name `liftM`
renameType (format . replace "variable" env') tipe
Var x -> Var `liftM` format (replace env x)
Var x -> Var `liftM` format (replace "variable" env x)
Data name es -> Data name `liftM` mapM rnm es
@ -173,5 +174,5 @@ renamePattern env pattern =
PRecord _ -> return pattern
PAnything -> return pattern
PAlias x p -> PAlias x `liftM` renamePattern env p
PData name ps -> PData `liftM` replace env name
PData name ps -> PData `liftM` replace "pattern" env name
`ap` mapM (renamePattern env) ps

4
compiler/Transform/Check.hs
View file

@ -39,8 +39,8 @@ duplicates defs =
dups = map head . filter ((>1) . length) . List.group
msg = "Syntax Error: There can only be one "
defMsg x = msg ++ " definition of '" ++ x ++ "'."
annMsg x = msg ++ " type annotation for '" ++ x ++ "'."
defMsg x = msg ++ "definition of '" ++ x ++ "'."
annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
badOrder :: [Def t v] -> [String]

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

@ -6,6 +6,7 @@ import qualified Data.Set as Set
import Control.Arrow (second)
import Control.Applicative ((<$>),(<*>))
import qualified Control.Monad as Monad
import Control.Monad.Error (ErrorT, runErrorT)
import Control.Monad.State
import Data.Traversable (traverse)
@ -33,7 +34,8 @@ constrain env (L span expr) tipe =
case expr of
Literal lit -> Literal.constrain env span lit tipe
Var name -> return (name <? tipe)
Var name | name == saveEnvName -> return (L span CSaveEnv)
| otherwise -> return (name <? tipe)
Range lo hi ->
exists $ \x -> do
@ -56,7 +58,7 @@ constrain env (L span expr) tipe =
Lambda p e ->
exists $ \t1 ->
exists $ \t2 -> do
fragment <- Pattern.constrain env p t1
fragment <- try span $ Pattern.constrain env p t1
c2 <- constrain env e t2
let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
(typeConstraint fragment /\ c2 ))
@ -80,18 +82,16 @@ constrain env (L span expr) tipe =
exists $ \t -> do
ce <- constrain env exp t
let branch (p,e) = do
fragment <- Pattern.constrain env p t
fragment <- try span $ Pattern.constrain env p t
clet [toScheme fragment] <$> constrain env e tipe
and . (:) ce <$> mapM branch branches
Data name exprs ->
do pairs <- mapM pair exprs
do vars <- forM exprs $ \_ -> var Flexible
let pairs = zip exprs (map VarN vars)
(ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
return (cs /\ name <? ctipe)
return $ ex vars (cs /\ name <? ctipe)
where
pair e = do v <- var Flexible -- needs an ex
return (e, VarN v)
step (t,c) (e,x) = do
c' <- constrain env e x
return (x ==> t, c /\ c')
@ -137,9 +137,7 @@ constrain env (L span expr) tipe =
return ("Graphics.Element.markdown" <? tipe)
Let defs body ->
do c <- case body of
L _ (Var name) | name == saveEnvName -> return (L span CSaveEnv)
_ -> constrain env body tipe
do c <- constrain env body tipe
(schemes, rqs, fqs, header, c2, c1) <-
Monad.foldM (constrainDef env)
([], [], [], Map.empty, true, true)
@ -152,9 +150,11 @@ constrainDef env info (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
case (pattern, maybeTipe) of
(PVar name, Just tipe) ->
do flexiVars <- mapM (\_ -> var Flexible) qs
do rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.
-- Currently, qs is always the empty list.
case (pattern, maybeTipe) of
(PVar name, Just tipe) -> do
flexiVars <- mapM (\_ -> var Flexible) qs
let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
(vars, typ) <- Env.instantiateType env tipe Map.empty
@ -168,12 +168,10 @@ constrainDef env info (pattern, expr, maybeTipe) =
, flexibleQuantifiers
, headers
, c2
, fl rigidQuantifiers c /\ c1 )
, fl rigidVars c /\ c1 )
(PVar name, Nothing) ->
do v <- var Flexible
rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.
-- Currently, qs is always the empty list.
(PVar name, Nothing) -> do
v <- var Flexible
let tipe = VarN v
inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
@ -194,7 +192,7 @@ expandPattern triple@(pattern, lexpr@(L s _), maybeType) =
_ -> (PVar x, lexpr, maybeType) : map toDef vars
where
vars = Set.toList $ SD.boundVars pattern
x = concat vars
x = "$" ++ concat vars
var = L s . Var
toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)
@ -213,3 +211,10 @@ collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
go ((pattern, body, Nothing) : output) defs typs ds
TypeAnnotation name typ ->
go output defs (Map.insert name typ typs) ds
try :: SrcSpan -> ErrorT String IO a -> IO a
try span computation = do
result <- runErrorT computation
case result of
Left msg -> error $ "\nType error " ++ show span ++ "\n" ++ msg
Right value -> return value

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

@ -3,6 +3,7 @@ module Type.Constrain.Pattern where
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
@ -17,7 +18,7 @@ import Type.Environment as Env
import qualified Type.Constrain.Literal as Literal
constrain :: Environment -> Pattern -> Type -> IO Fragment
constrain :: Environment -> Pattern -> Type -> ErrorT String IO Fragment
constrain env pattern tipe =
let span = Loc.NoSpan (render $ pretty pattern)
t1 === t2 = Loc.L span (CEqual t1 t2)
@ -27,11 +28,11 @@ constrain env pattern tipe =
PAnything -> return emptyFragment
PLiteral lit -> do
c <- Literal.constrain env span lit tipe
c <- liftIO $ Literal.constrain env span lit tipe
return $ emptyFragment { typeConstraint = c }
PVar name -> do
v <- var Flexible
v <- liftIO $ var Flexible
return $ Fragment {
typeEnv = Map.singleton name (VarN v),
vars = [v],
@ -46,11 +47,11 @@ constrain env pattern tipe =
}
PData name patterns -> do
(kind, cvars, args, result) <- freshDataScheme env name
(kind, cvars, args, result) <- liftIO $ freshDataScheme env name
let msg = concat [ "Constructor '", name, "' expects ", show kind
, " argument", if kind == 1 then "" else "s"
, " but was given ", show (length patterns), "." ]
if length patterns /= kind then error msg else do
if length patterns /= kind then throwError msg else do
fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
return $ fragment {
typeConstraint = typeConstraint fragment /\ tipe === result,
@ -58,9 +59,9 @@ constrain env pattern tipe =
}
PRecord fields -> do
pairs <- mapM (\name -> (,) name <$> var Flexible) fields
pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
let tenv = Map.fromList (map (second VarN) pairs)
c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
c <- liftIO . exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
return $ Fragment {
typeEnv = tenv,
vars = map snd pairs,

56
compiler/Type/Environment.hs
View file

@ -99,7 +99,7 @@ ctorToType env (name, tvars, ctors) =
get :: Environment -> (Environment -> Map.Map String a) -> String -> a
get env subDict key = Map.findWithDefault err key (subDict env)
where
err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."
freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
@ -122,38 +122,40 @@ instantiator env sourceType = go sourceType
Src.Var x -> do
(dict, aliases) <- State.get
case Map.lookup x dict of
Just var -> return (VarN var)
Nothing ->
case Map.lookup x aliases of
Just t -> return t
Nothing ->
do var <- State.liftIO $ namedVar flex x
State.put (Map.insert x var dict, aliases)
return (VarN var)
where
flex | "number" `isPrefixOf` x = Is Number
| "comparable" `isPrefixOf` x = Is Comparable
| "appendable" `isPrefixOf` x = Is Appendable
| otherwise = Flexible
case (Map.lookup x dict, Map.lookup x aliases) of
(_, Just t) -> return t
(Just v, _) -> return (VarN v)
_ ->
do var <- State.liftIO $ namedVar flex x
State.put (Map.insert x var dict, aliases)
return (VarN var)
where
flex | "number" `isPrefixOf` x = Is Number
| "comparable" `isPrefixOf` x = Is Comparable
| "appendable" `isPrefixOf` x = Is Appendable
| otherwise = Flexible
Src.Data "String" [] ->
return (get env types "_List" <| get env types "Char")
Src.Data name ts -> do
ts' <- mapM go ts
case Map.lookup name (types env) of
Just t -> return $ foldl (<|) t ts'
Nothing ->
case Map.lookup name (aliases env) of
Nothing -> error $ "Could not find type constructor '" ++ name ++ "' while checking types."
Just (tvars, t) ->
let msg = "Type alias '" ++ name ++ "' expects " ++ show (length tvars) ++
" but was given " ++ show (length ts')
in if length ts' /= length tvars then error msg else
do (dict, aliases) <- State.get
State.put (dict, Map.union aliases . Map.fromList $ zip tvars ts')
go t
case (Map.lookup name (types env), Map.lookup name (aliases env)) of
(Just t, _) -> return $ foldl (<|) t ts'
(_, Just (tvars, t)) ->
let tvarLen = length tvars
msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++
" type argument" ++ (if tvarLen == 1 then "" else "s") ++
" but was given " ++ show (length ts')
in if length ts' /= length tvars then error msg else
do (dict, aliases) <- State.get
let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases
State.put (dict, aliases')
t' <- go t
State.put (dict, aliases)
return t'
_ -> error $ "\nCould not find type constructor '" ++
name ++ "' while checking types."
Src.EmptyRecord -> return (TermN EmptyRecord1)

5
compiler/Type/PrettyPrint.hs
View file

@ -2,6 +2,7 @@
module Type.PrettyPrint where
import Text.PrettyPrint
import qualified SourceSyntax.PrettyPrint as Src
data ParensWhen = Fn | App | Never
@ -10,4 +11,6 @@ class PrettyType a where
commaSep docs = sep (punctuate comma docs)
parensIf bool doc = if bool then parens doc else doc
parensIf bool doc = if bool then parens doc else doc
reprime = Src.reprime

19
compiler/Type/Solve.hs
View file

@ -49,16 +49,17 @@ generalize youngPool = do
-- otherwise generalize
let registerIfLowerRank var = do
isRedundant <- liftIO $ UF.redundant var
if isRedundant then return () else do
case isRedundant of
True -> return ()
False -> do
desc <- liftIO $ UF.descriptor var
if rank desc < youngRank
then TS.register var >> return ()
else let flex' = if flex desc == Flexible then Rigid else flex desc
in liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
mapM registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
return ()
case rank desc < youngRank of
True -> TS.register var >> return ()
False -> do
let flex' = case flex desc of { Flexible -> Rigid ; other -> other }
liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })
mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
-- adjust the ranks of variables such that ranks never increase as you

7
compiler/Type/State.hs
View file

@ -62,9 +62,11 @@ addError span message t1 t2 =
NoSpan msg -> display msg
Span _ _ msg -> display msg
defaultMessage = "Something weird is happening with this value:"
makeError pt1 pt2 =
P.vcat [ P.text $ "Type error" ++ location ++ ":"
, if null message then empty else P.vcat . map P.text $ lines message
, P.vcat . map P.text . lines $ if null message then defaultMessage else message
, P.text src
, P.text " Expected Type:" <+> pt1
, P.text " Actual Type:" <+> pt2 <> P.text "\n"
@ -137,7 +139,8 @@ makeCopy alreadyCopied variable = do
() | mark desc == alreadyCopied ->
case copy desc of
Just v -> return v
Nothing -> error "This should be impossible."
Nothing -> error $ "Error copying type variable. This should be impossible." ++
" Please report an error to the github repo!"
| rank desc /= noRank || flex desc == Constant ->
return variable

10
compiler/Type/Type.hs
View file

@ -176,7 +176,7 @@ instance PrettyType a => PrettyType (Term1 a) where
prettyExt = prty ext
extend | P.render prettyExt == "{}" = P.empty
| otherwise = prettyExt <+> P.text "|"
mkPretty f t = P.text f <+> P.text ":" <+> prty t
mkPretty f t = P.text (reprime f) <+> P.text ":" <+> prty t
prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
@ -191,7 +191,7 @@ instance PrettyType Descriptor where
pretty when desc =
case (structure desc, name desc) of
(Just term, _) -> pretty when term
(_, Just name) -> if not (isTuple name) then P.text name else
(_, Just name) -> if not (isTuple name) then P.text (reprime name) else
P.parens . P.text $ replicate (read (drop 6 name) - 1) ','
_ -> P.text "?"
@ -277,7 +277,11 @@ addNames value = do
Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))
Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))
Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))
_ -> (Just $ head vars, (tail vars, a, b, c))
other -> (Just $ head vars, (tail vars, a, b, c))
where mark = case other of
Flexible -> ""
Rigid -> "!"
Constant -> "#"
type CrawlState = ([String], Int, Int, Int)

20
compiler/Type/Unify.hs
View file

@ -7,6 +7,8 @@ import qualified Type.State as TS
import Control.Arrow (first,second)
import Control.Monad.State
import SourceSyntax.Location
import Type.PrettyPrint
import Text.PrettyPrint (render)
unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
unify span variable1 variable2 = do
@ -75,7 +77,7 @@ actuallyUnify span variable1 variable2 = do
unify' variable1 variable2
unifyNumber svar name
| name `elem` ["Int","Float"] = flexAndUnify svar
| name `elem` ["Int","Float","number"] = flexAndUnify svar
| otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2
comparableError str = TS.addError span (str ++ msg) variable1 variable2
@ -83,7 +85,7 @@ actuallyUnify span variable1 variable2 = do
"Int, Float, Char, or a list or tuple of comparables."
unifyComparable var name
| name `elem` ["Int","Float","Char"] = flexAndUnify var
| name `elem` ["Int","Float","Char","comparable"] = flexAndUnify var
| otherwise = comparableError ""
unifyComparableStructure varSuper varFlex =
@ -106,6 +108,12 @@ actuallyUnify span variable1 variable2 = do
List _ -> flexAndUnify varSuper
_ -> comparableError ""
rigidError variable = TS.addError span msg variable1 variable2
where
msg = concat
[ "Cannot unify rigid type variable '", render (pretty Never variable), "'.\n"
, "It is likely that a type annotation is not general enough." ]
superUnify =
case (flex desc1, flex desc2, name desc1, name desc2) of
(Is super1, Is super2, _, _)
@ -126,6 +134,8 @@ actuallyUnify span variable1 variable2 = do
(Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
(_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
(Rigid, _, _, _) -> rigidError variable1
(_, Rigid, _, _) -> rigidError variable2
_ -> TS.addError span "" variable1 variable2
case (structure desc1, structure desc2) of
@ -158,7 +168,7 @@ actuallyUnify span variable1 variable2 = do
(Record1 fields1 ext1, Record1 fields2 ext2) ->
do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify') fields1 fields2
let mkRecord fs ext = liftIO . structuredVar $ Record1 fs ext
let mkRecord fs ext = fresh . Just $ Record1 fs ext
case (Map.null fields1', Map.null fields2') of
(True , True ) -> unify' ext1 ext2
(True , False) -> do
@ -168,8 +178,8 @@ actuallyUnify span variable1 variable2 = do
record1' <- mkRecord fields1' ext1
unify' record1' ext2
(False, False) -> do
record1' <- mkRecord fields1' =<< liftIO (var Flexible)
record2' <- mkRecord fields2' =<< liftIO (var Flexible)
record1' <- mkRecord fields1' =<< fresh Nothing
record2' <- mkRecord fields2' =<< fresh Nothing
unify' record1' ext2
unify' ext1 record2'
where

4
libraries/Automaton.elm
View file

@ -80,12 +80,12 @@ average : Int -> Automaton Float Float
average k =
let step n (ns,len,sum) =
if len == k then stepFull n (ns,len,sum)
else ((enqueue n ns, len+1, sum+n), (sum+n) / (len+1))
else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))
stepFull n (ns,len,sum) =
case dequeue ns of
Nothing -> ((ns,len,sum), 0)
Just (m,ns') -> let sum' = sum + n - m
in ((enqueue n ns', len, sum'), sum' / len)
in ((enqueue n ns', len, sum'), sum' / toFloat len)
in hiddenState (empty,0,0) step

58
libraries/Color.elm
View file

@ -14,23 +14,35 @@ rgba = Color
rgb : Int -> Int -> Int -> Color
rgb r g b = Color r g b 1
red : Color
red = Color 255 0 0 1
lime : Color
lime = Color 0 255 0 1
blue : Color
blue = Color 0 0 255 1
lightYellow = Color 255 233 79 1
yellow = Color 237 212 0 1
darkYellow = Color 196 160 0 1
yellow : Color
yellow = Color 255 255 0 1
cyan : Color
cyan = Color 0 255 255 1
magenta : Color
magenta = Color 255 0 255 1
lightOrange = Color 252 175 62 1
orange = Color 245 121 0 1
darkOrange = Color 206 92 0 1
lightBrown = Color 233 185 110 1
brown = Color 193 125 17 1
darkBrown = Color 143 89 2 1
lightGreen = Color 138 226 52 1
green = Color 115 210 22 1
darkGreen = Color 78 154 6 1
lightBlue = Color 114 159 207 1
blue = Color 52 101 164 1
darkBlue = Color 32 74 135 1
lightPurple = Color 173 127 168 1
purple = Color 117 80 123 1
darkPurple = Color 92 53 102 1
lightRed = Color 239 41 41 1
red = Color 204 0 0 1
darkRed = Color 164 0 0 1
black : Color
black = Color 0 0 0 1
white : Color
white = Color 255 255 255 1
gray : Color
@ -38,23 +50,6 @@ gray = Color 128 128 128 1
grey : Color
grey = Color 128 128 128 1
maroon : Color
maroon = Color 128 0 0 1
navy : Color
navy = Color 0 0 128 1
green : Color
green = Color 0 128 0 1
teal : Color
teal = Color 0 128 128 1
purple : Color
purple = Color 128 0 128 1
violet : Color
violet = Color 238 130 238 1
forestGreen : Color
forestGreen = Color 34 139 34 1
-- Produce a &ldquo;complementary color&rdquo;.
-- The two colors will accent each other.
complement : Color -> Color
@ -67,6 +62,7 @@ hsva = Native.Color.hsva
-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV).
-- This is very convenient for creating colors that cycle and shift.
-- Hue is an angle and should be given in standard Elm angles (radians).
--
-- hsv (degrees 240) 1 1 == blue
hsv : Float -> Float -> Float -> Color

30
libraries/Graphics/Collage.elm
View file

@ -128,27 +128,27 @@ groupTransform matrix fs = form (FGroup matrix fs)
-- Rotate a form by a given angle. Rotate takes standard Elm angles (radians)
-- and turns things counterclockwise. So to turn `form` 30&deg; to the left
-- you would say, `(rotate (degrees 30) form)`.
rotate : Float -> Form -> Form
rotate : number -> Form -> Form
rotate t f = { f | theta <- f.theta + t }
-- Scale a form by a given factor. Scaling by 2 doubles the size.
scale : Float -> Form -> Form
scale : number -> Form -> Form
scale s f = { f | scale <- f.scale * s }
-- Move a form by the given amount. This is a relative translation so
-- `(move (10,10) form)` would move `form` ten pixels up and ten pixels to the
-- right.
move : (Float,Float) -> Form -> Form
move : (number,number) -> Form -> Form
move (x,y) f = { f | x <- f.x + x, y <- f.y + y }
-- Move a shape in the x direction. This is relative so `(moveX 10 form)` moves
-- `form` 10 pixels to the right.
moveX : Float -> Form -> Form
moveX : number -> Form -> Form
moveX x f = { f | x <- f.x + x }
-- Move a shape in the y direction. This is relative so `(moveY 10 form)` moves
-- `form` upwards by 10 pixels.
moveY : Float -> Form -> Form
moveY : number -> Form -> Form
moveY y f = { f | y <- f.y + y }
-- Set the alpha of a `Form`. The default is 1, and 0 is totally transparent.
@ -161,36 +161,36 @@ collage : Int -> Int -> [Form] -> Element
collage = Native.Graphics.Collage.collage
type Path = [(Float,Float)]
type Path = [(number,number)]
-- Create a path that follows a sequence of points.
path : [(Float,Float)] -> Path
path : [(number,number)] -> Path
path ps = ps
-- Create a path along a given line segment.
segment : (Float,Float) -> (Float,Float) -> Path
segment : (number,number) -> (number,number) -> Path
segment p1 p2 = [p1,p2]
type Shape = [(Float,Float)]
type Shape = [(number,number)]
-- Create an arbitrary polygon by specifying its corners in order.
-- `polygon` will automatically close all shapes, so the given list
-- of points does not need to start and end with the same position.
polygon : [(Float,Float)] -> Shape
polygon : [(number,number)] -> Shape
polygon points = points
-- A rectangle with a given width and height.
rect : Float -> Float -> Shape
rect : number -> number -> Shape
rect w h = let hw = w/2
hh = h/2
in [ (0-hw,0-hh), (0-hw,hh), (hw,hh), (hw,0-hh) ]
-- A square with a given edge length.
square : Float -> Shape
square : number -> Shape
square n = rect n n
-- An oval with a given width and height.
oval : Float -> Float -> Shape
oval : number -> number -> Shape
oval w h =
let n = 50
t = 2 * pi / n
@ -200,7 +200,7 @@ oval w h =
in List.map f [0..n-1]
-- A circle with a given radius.
circle : Float -> Shape
circle : number -> Shape
circle r = oval (2*r) (2*r)
-- A regular polygon with N sides. The first argument specifies the number
@ -208,7 +208,7 @@ circle r = oval (2*r) (2*r)
-- 30 you would say:
--
-- ngon 5 30
ngon : Int -> Float -> Shape
ngon : Int -> number -> Shape
ngon n r =
let m = toFloat n
t = 2 * pi / m

4
libraries/Graphics/Input.elm
View file

@ -75,10 +75,14 @@ checkbox b =
let cbs = checkboxes b
in (lift (cbs.checkbox id) cbs.events, cbs.events)
-- Detect when the mouse is hovering over some elements. This
-- allows you to create and destroy elements dynamically and still
-- detect hover information.
hoverables : a -> { events : Signal a,
hoverable : (Bool -> a) -> Element -> Element }
hoverables = Native.Graphics.Input.hoverables
-- Detect when the mouse is hovering over a specifici `Element`.
hoverable : Element -> (Element, Signal Bool)
hoverable elem =
let pool = hoverables False

4
libraries/List.elm
View file

@ -91,11 +91,11 @@ any = Native.List.any
-- Check to see if all elements are True.
and : [Bool] -> Bool
and = Native.List.and
and = foldl (&&) True
-- Check to see if any elements are True.
or : [Bool] -> Bool
or = Native.List.or
or = foldl (||) False
-- Concatenate a list of appendable things:
--

2
libraries/Native/Char.js
View file

@ -16,7 +16,7 @@ Elm.Native.Char = function(elm) {
return elm.Native.Char = {
fromCode : function(c) { return String.fromCharCode(c); },
toCode : function(c) { return c.charCodeAt(0); },
toCode : function(c) { return c.toUpperCase().charCodeAt(0); },
toUpper : function(c) { return c.toUpperCase(); },
toLower : function(c) { return c.toLowerCase(); },
toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },

94
libraries/Native/Signal/Keyboard.js
View file

@ -4,29 +4,79 @@ Elm.Native.Keyboard = function(elm) {
elm.Native = elm.Native || {};
if (elm.Native.Keyboard) return elm.Native.Keyboard;
// Duplicated from Native.Signal
function send(node, timestep, changed) {
var kids = node.kids;
for (var i = kids.length; i--; ) {
kids[i].recv(timestep, changed, node.id);
}
}
var Signal = Elm.Signal(elm);
var NList = Elm.Native.List(elm);
var Utils = Elm.Native.Utils(elm);
var keysDown = Signal.constant(NList.Nil);
var lastKey = Signal.constant('\0');
var downEvents = Signal.constant(0);
var upEvents = Signal.constant(0);
var blurEvents = Signal.constant(0);
elm.addListener([keysDown.id], document, 'keydown', function down(e) {
if (NList.member(e.keyCode)(keysDown.value)) return;
elm.notify(keysDown.id, NList.Cons(e.keyCode, keysDown.value));
});
elm.addListener([keysDown.id], document, 'keyup', function up(e) {
function notEq(kc) { return kc !== e.keyCode; }
elm.notify(keysDown.id, NList.filter(notEq)(keysDown.value));
});
elm.addListener([keysDown.id], document, 'blur', function blur(e) {
elm.notify(keysDown.id, NList.Nil);
});
elm.addListener([lastKey.id], document, 'keypress', function press(e) {
elm.notify(lastKey.id, e.charCode || e.keyCode);
});
elm.addListener([downEvents.id], document, 'keydown', function down(e) {
elm.notify(downEvents.id, e.keyCode);
});
elm.addListener([upEvents.id], document, 'keyup', function up(e) {
elm.notify(upEvents.id, e.keyCode);
});
elm.addListener([blurEvents.id], document, 'blur', function blur(e) {
elm.notify(blurEvents.id, NList.Nil);
});
function KeyMerge(down, up, blur) {
var args = [down,up,blur];
this.id = Utils.guid();
// Ignore starting values here
this.value = NList.Nil
this.kids = [];
var n = args.length;
var count = 0;
var isChanged = false;
this.recv = function(timestep, changed, parentID) {
++count;
if (changed) {
// We know this a change must only be one of the following cases
if (parentID === down.id && !(NList.member(down.value)(this.value))) {
isChanged = true;
this.value = NList.Cons(down.value, this.value);
}
if (parentID === up.id) {
isChanged = true;
var notEq = function(kc) { return kc !== up.value };
this.value = NList.filter(notEq)(this.value);
}
if (parentID === blur.id) {
isChanged = true;
this.value = NList.Nil;
}
}
if (count == n) {
send(this, timestep, isChanged);
isChanged = false;
count = 0;
}
};
for (var i = n; i--; ) { args[i].kids.push(this); }
}
var keysDown = Signal.dropRepeats(new KeyMerge(downEvents,upEvents,blurEvents));
function keySignal(f) {
var signal = Signal.dropRepeats(A2(Signal.lift, f, keysDown));
var signal = A2(Signal.lift, f, keysDown);
// what's the significance of these two following lines? -jpm
keysDown.defaultNumberOfKids += 1;
signal.defaultNumberOfKids = 0;
return signal;
@ -51,11 +101,13 @@ Elm.Native.Keyboard = function(elm) {
function is(key) { return keySignal(NList.member(key)); }
var lastPressed = Signal.dropRepeats(downEvents);
return elm.Native.Keyboard = {
isDown:is,
directions:F4(dir),
keysDown:keysDown,
lastPressed:lastKey
isDown:is,
directions:F4(dir),
keysDown:keysDown,
lastPressed:lastPressed
};
};

3
libraries/Signal.elm
View file

@ -52,7 +52,8 @@ lift8 = Native.Signal.lift8
-- Create a past-dependent signal. Each value given on the input signal will
-- be accumulated, producing a new output value.
--
-- For instance, `(foldp (\\t acc -> acc + 1) 0 (Time.every second))` increments every second.
-- For instance, `(foldp (\\arrows number -> number + arrows.y) 0 Keyboard.arrows)`
-- increments or decrements the accumulated value (which starts at zero) when the up or down arrow keys are pressed.
foldp : (a -> b -> b) -> b -> Signal a -> Signal b
foldp = Native.Signal.foldp

1
runtime/Init.js
View file

@ -115,7 +115,6 @@ function init(display, container, module, moduleToReplace) {
// rerender scene if graphics are enabled.
if (typeof graphicsNode !== 'undefined') {
graphicsNode.value = A2( Elm.Graphics.Element(elm).spacer, 0, 0 );
graphicsNode.recv(0, true, 0);
}
}

4
runtime/Render/Element.js
View file

@ -252,9 +252,9 @@ function updateProps(node, curr, next) {
e.style.opacity = props.opacity;
}
var nextColor = (props.color.ctor === 'Just' ?
extract(props.color._0) : 'transparent');
extract(props.color._0) : '');
if (e.style.backgroundColor !== nextColor) {
e.style.backgroundColor = nextColor;
e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);
}
if (props.tag !== currP.tag) { e.id = props.tag; }
if (props.href !== currP.href) {

4
runtime/Render/Utils.js
View file

@ -14,8 +14,8 @@ function addTo(container, elem) {
}
function extract(c) {
if (c._3 === 1) { return 'rgb(' + c._0 + ',' + c._1 + ',' + c._2 + ')'; }
return 'rgba(' + c._0 + ',' + c._1 + ',' + c._2 + ',' + c._3 + ')';
if (c._3 === 1) { return 'rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')'; }
return 'rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')';
}
function addTransform(style, trans) {

47
server/Server.hs
View file

@ -7,17 +7,21 @@ import Data.List (isPrefixOf, isSuffixOf, (\\))
import Data.Version (showVersion)
import Happstack.Server
import Happstack.Server.Compression
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process
import GHC.IO.Handle
import qualified Language.Elm as Elm
import Paths_elm_server
runtime = "/elm-" ++ showVersion version ++ ".js"
runtime = "/elm-runtime.js"
serve :: Int -> String -> IO ()
serve portNumber libLoc = do
putStrLn ("Elm Server " ++ showVersion version ++
": running at <http://localhost:" ++ (show portNumber) ++ ">")
putStrLn $ "Elm Server " ++ showVersion version ++
": running at <http://localhost:" ++ show portNumber ++ ">"
putStrLn "Just refresh a page to recompile it!"
simpleHTTP httpConf $ do
_ <- compressedResponseFilter
@ -30,11 +34,24 @@ serve portNumber libLoc = do
pageTitle :: String -> String
pageTitle = dropExtension . takeBaseName
serveElm :: FilePath -> ServerPartT IO Response
serveElm fp = do
guard (takeExtension fp == ".elm")
content <- liftIO (readFile (tail fp))
length content `seq` (ok . toResponse $ Elm.toHtml runtime (pageTitle fp) content)
let file = tail fp
args = [ "--make" ,"--runtime=" ++ runtime, "--cache-dir=elm-server-cache", file ]
(_, stdout, _, handle) <- liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe }
exitCode <- liftIO $ waitForProcess handle
liftIO $ removeDirectoryRecursive "elm-server-cache"
case (exitCode, stdout) of
(ExitFailure _, Just out) ->
do str <- liftIO $ hGetContents out
badRequest $ toResponse str
(ExitFailure _, Nothing) ->
badRequest $ toResponse "See command line for error message."
(ExitSuccess, _) ->
serveFile (asContentType "text/html") ("build" </> replaceExtension file "html")
serveLib :: FilePath -> [Char] -> ServerPartT IO Response
serveLib libLoc fp = do
guard (fp == runtime)
serveFile (asContentType "application/javascript") libLoc
@ -45,16 +62,18 @@ main = getArgs >>= parse
parse :: [String] -> IO ()
parse ("--help":_) = putStrLn usage
parse ("--version":_) = putStrLn ("The Elm Server " ++ showVersion version)
parse args = if null remainingArgs
then serve portNumber =<< elmRuntime
else putStrLn usageMini
where runtimeArg = filter (isPrefixOf "--runtime-location=") args
portArg = filter (isPrefixOf "--port=") args
remainingArgs = (args \\ runtimeArg) \\ portArg
parse args =
case null remainingArgs of
True -> serve portNumber =<< elmRuntime
False -> putStrLn usageMini
where
runtimeArg = filter (isPrefixOf "--runtime-location=") args
portArg = filter (isPrefixOf "--port=") args
remainingArgs = (args \\ runtimeArg) \\ portArg
argValue arg = tail $ dropWhile (/= '=') (head arg)
portNumber = if null portArg then 8000 else read (argValue portArg) :: Int
elmRuntime = if null runtimeArg then Elm.runtime else return $ argValue runtimeArg
argValue arg = tail $ dropWhile (/= '=') (head arg)
portNumber = if null portArg then 8000 else read (argValue portArg) :: Int
elmRuntime = if null runtimeArg then Elm.runtime else return $ argValue runtimeArg
usageMini :: String
usageMini =

8
server/elm-server.cabal
View file

@ -1,5 +1,5 @@
Name: elm-server
Version: 0.8
Version: 0.9.0.2
Synopsis: The Elm language server.
Description: This package provides a standalone, Happstack-based Elm server.
@ -27,12 +27,14 @@ Executable elm-server
Main-is: Server.hs
Build-depends: base >=4.2 && <5,
containers >= 0.3,
directory,
transformers >= 0.2,
mtl >= 2,
parsec >= 3.1.1,
blaze-html >= 0.5.1,
HTTP >= 4000,
happstack-server == 7.1.1 || == 7.1.7 || == 7.0.2,
happstack-server,
deepseq,
filepath,
Elm >= 0.8
Elm >= 0.9.0.2,
process

7
tests/Everything.hs
View file

@ -1,7 +0,0 @@
module Everything where
import System.Exit
main = do
putStrLn "This test always fails"
exitFailure

22
tests/Main.hs Normal file
View file

@ -0,0 +1,22 @@
module Main where
import System.Directory
import System.Exit (exitWith)
import System.Environment (getArgs)
import Test.Framework.TestManager
import Test.Framework.BlackBoxTest
main :: IO ()
main = do
args <- getArgs
tests <- blackBoxTests "tests/good" "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

6
tests/good/AliasSubstitution.elm Normal file
View file

@ -0,0 +1,6 @@
type Vec2Ext a = { a | x:Float, y:Float }
type Vec2 = Vec2Ext {}
extractVec : Vec2Ext a -> Vec2
extractVec v = { x = v.x, y = v.y }

3
tests/good/Apply.elm
View file

@ -1,3 +0,0 @@
let apply f x = f x
id x = x
in apply id (apply id (apply id (apply id (apply id (apply id 4)))))

3
tests/good/NoExpressions.elm Normal file
View file

@ -0,0 +1,3 @@
type Width = Float
type Height = Float

8
tests/good/Soundness.elm
View file

@ -1,8 +0,0 @@
trickyID x = let y = x in y
quad f = twice (twice f)
twice f x = f (f x)
n = quad (quad trickyID) 4
c = twice trickyID 'a'

3
tests/good/Soundness/Apply.elm Normal file
View file

@ -0,0 +1,3 @@
apply f = let g x = f x
in g

4
tests/good/Soundness/ApplyAnnotated.elm Normal file
View file

@ -0,0 +1,4 @@
apply : (a -> b) -> a -> b
apply f = let g x = f x
in g

3
tests/good/Soundness1.elm → tests/good/Soundness/Id.elm
View file

@ -1,2 +1,3 @@
test =
myId =
let id x = x in id

3
tests/good/SoundnessAnnotated1.elm → tests/good/Soundness/IdAnnotated.elm
View file

@ -1,3 +1,4 @@
test = let id : a -> a
myId = let id : a -> a
id x = x
in id

2
tests/good/Soundness/TrickyId.elm Normal file
View file

@ -0,0 +1,2 @@
myId x = let y = x in y

3
tests/good/Soundness/TrickyIdAnnotated.elm Normal file
View file

@ -0,0 +1,3 @@
myId : a -> a
myId x = let y = x in y

1
tests/good/Soundness2.elm
View file

@ -1 +0,0 @@
test x = let y = x in y

2
tests/good/Soundness3.elm
View file

@ -1,2 +0,0 @@
test f = let g x = f x
in g

2
tests/good/SoundnessAnnotated2.elm
View file

@ -1,2 +0,0 @@
test : a -> a
test x = let y = x in y

3
tests/good/SoundnessAnnotated3.elm
View file

@ -1,3 +0,0 @@
test : (a -> b) -> a -> b
test f = let g x = f x
in g

6
tests/good/Unify/LockedVars.elm Normal file
View file

@ -0,0 +1,6 @@
-- unify flexible and locked types
import Dict
multiplyKey ((i,j), _) = (i*j)
x = map multiplyKey (Dict.toList (Dict.singleton (1,2) 0))

8
tests/good/Unify/NonHomogeneousRecords.elm Normal file
View file

@ -0,0 +1,8 @@
type Thing = { x:Float, y:Float }
f : Thing -> Thing
f t =
let x = t.x
y = t.y
in t

7
tests/test
View file

@ -1,7 +0,0 @@
#!/bin/sh
(
cd `dirname $0` &&
cabal configure --enable-tests &&
cabal build &&
cabal test
) || exit 1

5
tests/testRepl
View file

@ -1,5 +0,0 @@
#!/bin/sh
here=`cd \`dirname $0\` && pwd`
cd "$here/tests" &&
ghci

5
tests/tests/.ghci
View file

@ -1,5 +0,0 @@
:set -i../src -i.
:l Main Parse.Parser
:m + Test.QuickCheck Main
:set prompt "test>> "
:set -Wall

54
tests/tests/Main.hs
View file

@ -1,54 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, QuasiQuotes, ExtendedDefaultRules #-}
module Main where
import Test.Framework as TF (defaultMain, testGroup, Test)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Text.InterpolatedString.Perl6 (qq)
import Parse.Parser
import Util.Arbs
import Debug.Trace
main :: IO ()
main = defaultMain tests
parses :: String -> Bool
parses code = either (const False) (const True) (parseProgram code)
parseFails :: String -> Bool
parseFails = not . parses
tests :: [TF.Test]
tests = [
testGroup "String Assignments" [
testProperty "prop_assignString" prop_assignString
, testProperty "prop_invalidIdent" prop_invalidIdent
, testProperty "prop_emptyList" prop_emptyList
, testProperty "prop_record" prop_record
]
]
prop_assignString :: ValidIdent -> StringLiteral -> Bool
prop_assignString i s = parses [qq|
{i} = {s}
|]
prop_invalidIdent :: ValidIdent -> InvalidIdentChar -> StringLiteral -> Bool
prop_invalidIdent i z s = parseFails [qq|
{i}{z} = {s}
|]
prop_emptyList :: ValidIdent -> Bool
prop_emptyList i = parses [qq|
{i}=[]
|]
prop_record :: ValidIdent -> ValidIdent -> ValidIdent -> ValidIdent -> StringLiteral -> Bool
prop_record a b c k v = parses [qq|
{a} = \{{k} = {v} \}
{b} = .{k} {a}
{c} = {a}.{k}
|]

45
tests/tests/Util/Arbs.hs
View file

@ -1,45 +0,0 @@
module Util.Arbs where
import Control.Applicative
import Test.QuickCheck
import Util.CharGens
import Util.String
import Text.InterpolatedString.Perl6 (ShowQ(showQ))
newtype ValidIdent = ValidIdent String deriving (Eq, Show)
instance ShowQ ValidIdent where
showQ (ValidIdent v) = v
instance Arbitrary ValidIdent where
arbitrary = ValidIdent <$> ((:) <$> lowerAlpha <*> (listOf alphaNumUnderPrime))
newtype StringLiteral = StringLiteral String deriving (Eq, Show)
instance ShowQ StringLiteral where
showQ (StringLiteral v) = v
instance Arbitrary StringLiteral where
arbitrary = StringLiteral <$> (\x -> "\"" ++ x ++ "\"") <$> escape <$> arbitrary
newtype InvalidIdentChar = InvalidIdentChar Char deriving (Eq, Show)
instance ShowQ InvalidIdentChar where
showQ (InvalidIdentChar c) = [c]
instance Arbitrary InvalidIdentChar where
arbitrary = InvalidIdentChar <$> elements "!@#$%^&*()-=+\\|/?.>,<`~"
newtype BuiltinType = BuiltinType String deriving (Eq, Show)
instance ShowQ BuiltinType where
showQ (BuiltinType v) = v
instance Arbitrary BuiltinType where
-- TODO: add others
arbitrary = BuiltinType <$> elements ["Char", "String"]

19
tests/tests/Util/CharGens.hs
View file

@ -1,19 +0,0 @@
module Util.CharGens where
import Test.QuickCheck
import Test.QuickCheck.Property
lowerAlpha :: Gen Char
lowerAlpha = elements ['a'..'z']
upperAlpha :: Gen Char
upperAlpha = elements ['A'..'Z']
alpha :: Gen Char
alpha = oneof [lowerAlpha, upperAlpha]
alphaNum :: Gen Char
alphaNum = oneof [alpha, elements ['0'..'9']]
alphaNumUnderPrime :: Gen Char
alphaNumUnderPrime = oneof [alphaNum, elements ['_', '\'']]

13
tests/tests/Util/String.hs
View file

@ -1,13 +0,0 @@
module Util.String where
import qualified Data.Text as T
replace :: String -> String -> String -> String
replace a b c = T.unpack (T.replace (T.pack a) (T.pack b) (T.pack c))
escape :: String -> String
escape =
(replace "\n" "\\n") .
(replace "\t" "\\t") .
(replace "\"" "\\\"") .
(replace "\\" "\\\\")