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