Merge branch 'master' into dev
This commit is contained in:
commit
476e87ffc6
68 changed files with 547 additions and 582 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
@ -7,5 +7,6 @@ cabal-dev
|
|||
*.aes
|
||||
*.elmi
|
||||
*.elmo
|
||||
data
|
||||
*/ElmFiles/*
|
||||
.DS_Store
|
||||
|
|
|
@ -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
|
|
@ -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
29
Setup.hs
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ++ ")"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -19,13 +19,25 @@ num = fmap toLit (preNum <?> "number")
|
|||
string "."
|
||||
('.':) <$> many1 digit
|
||||
|
||||
str :: IParser Literal
|
||||
str = choice [ let quote = try (string "\"\"\"")
|
||||
in quote >> Str <$> manyTill (backslashed <|> anyChar) quote
|
||||
, liftM Str . expecting "string" . betwixt '"' '"' . many $
|
||||
backslashed <|> satisfy (/='"')
|
||||
]
|
||||
|
||||
chr :: IParser Literal
|
||||
chr = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
|
||||
<?> "character"
|
||||
|
||||
str :: IParser Literal
|
||||
str = choice [ quote >> str <$> manyTill (backslashed <|> anyChar) quote
|
||||
, liftM Str . expecting "string" . betwixt '"' '"' . many $
|
||||
backslashed <|> satisfy (/='"')
|
||||
]
|
||||
where
|
||||
quote = try (string "\"\"\"")
|
||||
str = Str . dewindows
|
||||
|
||||
-- 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
|
||||
_ -> []
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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 []
|
||||
--}
|
|
@ -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
|
||||
|
|
|
@ -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| ... |]"
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
|
@ -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,
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -2,6 +2,7 @@
|
|||
module Type.PrettyPrint where
|
||||
|
||||
import Text.PrettyPrint
|
||||
import qualified SourceSyntax.PrettyPrint as Src
|
||||
|
||||
data ParensWhen = Fn | App | Never
|
||||
|
||||
|
@ -11,3 +12,5 @@ class PrettyType a where
|
|||
commaSep docs = sep (punctuate comma docs)
|
||||
|
||||
parensIf bool doc = if bool then parens doc else doc
|
||||
|
||||
reprime = Src.reprime
|
|
@ -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' })
|
||||
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)
|
||||
|
||||
return ()
|
||||
mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)
|
||||
|
||||
|
||||
-- adjust the ranks of variables such that ranks never increase as you
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
@ -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 “complementary color”.
|
||||
-- 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
|
||||
|
|
|
@ -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° 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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:
|
||||
--
|
||||
|
|
|
@ -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(); },
|
||||
|
|
|
@ -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
|
||||
};
|
||||
|
||||
};
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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);
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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) {
|
||||
|
|
|
@ -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) {
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,7 +0,0 @@
|
|||
module Everything where
|
||||
|
||||
import System.Exit
|
||||
|
||||
main = do
|
||||
putStrLn "This test always fails"
|
||||
exitFailure
|
22
tests/Main.hs
Normal file
22
tests/Main.hs
Normal 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
6
tests/good/AliasSubstitution.elm
Normal 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 }
|
|
@ -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
3
tests/good/NoExpressions.elm
Normal file
|
@ -0,0 +1,3 @@
|
|||
|
||||
type Width = Float
|
||||
type Height = Float
|
|
@ -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
3
tests/good/Soundness/Apply.elm
Normal file
|
@ -0,0 +1,3 @@
|
|||
|
||||
apply f = let g x = f x
|
||||
in g
|
4
tests/good/Soundness/ApplyAnnotated.elm
Normal file
4
tests/good/Soundness/ApplyAnnotated.elm
Normal file
|
@ -0,0 +1,4 @@
|
|||
|
||||
apply : (a -> b) -> a -> b
|
||||
apply f = let g x = f x
|
||||
in g
|
|
@ -1,2 +1,3 @@
|
|||
test =
|
||||
|
||||
myId =
|
||||
let id x = x in id
|
|
@ -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
2
tests/good/Soundness/TrickyId.elm
Normal file
|
@ -0,0 +1,2 @@
|
|||
|
||||
myId x = let y = x in y
|
3
tests/good/Soundness/TrickyIdAnnotated.elm
Normal file
3
tests/good/Soundness/TrickyIdAnnotated.elm
Normal file
|
@ -0,0 +1,3 @@
|
|||
|
||||
myId : a -> a
|
||||
myId x = let y = x in y
|
|
@ -1 +0,0 @@
|
|||
test x = let y = x in y
|
|
@ -1,2 +0,0 @@
|
|||
test f = let g x = f x
|
||||
in g
|
|
@ -1,2 +0,0 @@
|
|||
test : a -> a
|
||||
test x = let y = x in y
|
|
@ -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
6
tests/good/Unify/LockedVars.elm
Normal 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
8
tests/good/Unify/NonHomogeneousRecords.elm
Normal 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
|
|
@ -1,7 +0,0 @@
|
|||
#!/bin/sh
|
||||
(
|
||||
cd `dirname $0` &&
|
||||
cabal configure --enable-tests &&
|
||||
cabal build &&
|
||||
cabal test
|
||||
) || exit 1
|
|
@ -1,5 +0,0 @@
|
|||
#!/bin/sh
|
||||
|
||||
here=`cd \`dirname $0\` && pwd`
|
||||
cd "$here/tests" &&
|
||||
ghci
|
|
@ -1,5 +0,0 @@
|
|||
:set -i../src -i.
|
||||
:l Main Parse.Parser
|
||||
:m + Test.QuickCheck Main
|
||||
:set prompt "test>> "
|
||||
:set -Wall
|
|
@ -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}
|
||||
|]
|
|
@ -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"]
|
|
@ -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 ['_', '\'']]
|
|
@ -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 "\\" "\\\\")
|
Loading…
Reference in a new issue