Adopt "model" code from elm-get so that dependencies can be crawled from the compiler.
This commit is contained in:
parent
61ff49067f
commit
3c1b9f7171
8 changed files with 286 additions and 48 deletions
15
Elm.cabal
15
Elm.cabal
|
@ -30,7 +30,12 @@ source-repository head
|
||||||
location: git://github.com/evancz/Elm.git
|
location: git://github.com/evancz/Elm.git
|
||||||
|
|
||||||
Library
|
Library
|
||||||
exposed-modules: Language.Elm
|
exposed-modules: Elm.Internal.Dependencies,
|
||||||
|
Elm.Internal.Documentation,
|
||||||
|
Elm.Internal.Name,
|
||||||
|
Elm.Internal.Paths,
|
||||||
|
Elm.Internal.Utils,
|
||||||
|
Elm.Internal.Version
|
||||||
Hs-Source-Dirs: compiler
|
Hs-Source-Dirs: compiler
|
||||||
other-modules: SourceSyntax.Declaration,
|
other-modules: SourceSyntax.Declaration,
|
||||||
SourceSyntax.Expression,
|
SourceSyntax.Expression,
|
||||||
|
@ -86,7 +91,8 @@ Library
|
||||||
Build.Utils,
|
Build.Utils,
|
||||||
Paths_Elm
|
Paths_Elm
|
||||||
|
|
||||||
Build-depends: base >=4.2 && <5,
|
Build-depends: aeson,
|
||||||
|
base >=4.2 && <5,
|
||||||
binary >= 0.6.4.0,
|
binary >= 0.6.4.0,
|
||||||
blaze-html == 0.5.* || == 0.6.*,
|
blaze-html == 0.5.* || == 0.6.*,
|
||||||
blaze-markup,
|
blaze-markup,
|
||||||
|
@ -101,6 +107,7 @@ Library
|
||||||
pandoc >= 1.10,
|
pandoc >= 1.10,
|
||||||
parsec >= 3.1.1,
|
parsec >= 3.1.1,
|
||||||
pretty,
|
pretty,
|
||||||
|
text,
|
||||||
transformers >= 0.2,
|
transformers >= 0.2,
|
||||||
union-find,
|
union-find,
|
||||||
uniplate
|
uniplate
|
||||||
|
@ -163,7 +170,8 @@ Executable elm
|
||||||
Build.Utils,
|
Build.Utils,
|
||||||
Paths_Elm
|
Paths_Elm
|
||||||
|
|
||||||
Build-depends: base >=4.2 && <5,
|
Build-depends: aeson,
|
||||||
|
base >=4.2 && <5,
|
||||||
binary >= 0.6.4.0,
|
binary >= 0.6.4.0,
|
||||||
blaze-html == 0.5.* || == 0.6.*,
|
blaze-html == 0.5.* || == 0.6.*,
|
||||||
blaze-markup == 0.5.1.*,
|
blaze-markup == 0.5.1.*,
|
||||||
|
@ -178,6 +186,7 @@ Executable elm
|
||||||
pandoc >= 1.10,
|
pandoc >= 1.10,
|
||||||
parsec >= 3.1.1,
|
parsec >= 3.1.1,
|
||||||
pretty,
|
pretty,
|
||||||
|
text,
|
||||||
transformers >= 0.2,
|
transformers >= 0.2,
|
||||||
union-find,
|
union-find,
|
||||||
uniplate
|
uniplate
|
||||||
|
|
|
@ -24,6 +24,7 @@ import qualified Transform.SortDefinitions as SD
|
||||||
import qualified Type.Inference as TI
|
import qualified Type.Inference as TI
|
||||||
import qualified Type.Constrain.Declaration as TcDecl
|
import qualified Type.Constrain.Declaration as TcDecl
|
||||||
import qualified Transform.Canonicalize as Canonical
|
import qualified Transform.Canonicalize as Canonical
|
||||||
|
import qualified Elm.Internal.Version as V
|
||||||
|
|
||||||
getSortedDependencies :: [FilePath] -> Interfaces -> FilePath -> IO [String]
|
getSortedDependencies :: [FilePath] -> Interfaces -> FilePath -> IO [String]
|
||||||
getSortedDependencies srcDirs builtIns root =
|
getSortedDependencies srcDirs builtIns root =
|
||||||
|
@ -44,41 +45,15 @@ additionalSourceDirs =
|
||||||
|
|
||||||
getLatest project = do
|
getLatest project = do
|
||||||
subs <- getDirectoryContents project
|
subs <- getDirectoryContents project
|
||||||
case Maybe.mapMaybe version subs of
|
case Maybe.mapMaybe V.fromString subs of
|
||||||
[] -> return Nothing
|
[] -> return Nothing
|
||||||
versions -> return $ Just $ (project </>) $ showVersion maxVersion
|
versions -> return $ Just $ (project </>) $ show maxVersion
|
||||||
where maxVersion = List.maximumBy compareVersion versions
|
where maxVersion = List.maximum versions
|
||||||
|
|
||||||
isProject path = do
|
isProject path = do
|
||||||
exists <- doesDirectoryExist path
|
exists <- doesDirectoryExist path
|
||||||
return $ exists && path `notElem` [".","..","_internals"]
|
return $ exists && path `notElem` [".","..","_internals"]
|
||||||
|
|
||||||
showVersion (ns,tag) =
|
|
||||||
List.intercalate "." (map show ns) ++ if null tag then "" else "-" ++ tag
|
|
||||||
|
|
||||||
compareVersion a b =
|
|
||||||
case compare (fst a) (fst b) of
|
|
||||||
EQ -> compare (snd b) (snd a) -- reverse comparison to favor ""
|
|
||||||
cmp -> cmp
|
|
||||||
|
|
||||||
version :: String -> Maybe ([Int], String)
|
|
||||||
version version = (,) <$> splitNumbers possibleNumbers <*> tag
|
|
||||||
where
|
|
||||||
(possibleNumbers, possibleTag) = break (=='-') version
|
|
||||||
|
|
||||||
tag = case possibleTag of
|
|
||||||
"" -> Just ""
|
|
||||||
'-':rest -> Just rest
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
splitNumbers :: String -> Maybe [Int]
|
|
||||||
splitNumbers ns =
|
|
||||||
case span Char.isDigit ns of
|
|
||||||
("", _) -> Nothing
|
|
||||||
(number, []) -> Just [read number]
|
|
||||||
(number, '.':rest) -> (read number :) <$> splitNumbers rest
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
type Deps = (FilePath, String, [String])
|
type Deps = (FilePath, String, [String])
|
||||||
|
|
||||||
sortDeps :: [Deps] -> IO [String]
|
sortDeps :: [Deps] -> IO [String]
|
||||||
|
|
93
compiler/Elm/Internal/Dependencies.hs
Normal file
93
compiler/Elm/Internal/Dependencies.hs
Normal file
|
@ -0,0 +1,93 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
module Elm.Internal.Dependencies where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Monad.Error
|
||||||
|
import qualified Control.Exception as E
|
||||||
|
import Data.Aeson
|
||||||
|
import qualified Data.List as List
|
||||||
|
import qualified Data.ByteString.Lazy as BS
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import qualified Elm.Internal.Name as N
|
||||||
|
import qualified Elm.Internal.Version as V
|
||||||
|
|
||||||
|
data Deps = Deps
|
||||||
|
{ name :: N.Name
|
||||||
|
, version :: V.Version
|
||||||
|
, summary :: String
|
||||||
|
, description :: String
|
||||||
|
, license :: String
|
||||||
|
, repo :: String
|
||||||
|
, exposed :: [String]
|
||||||
|
, elmVersion :: V.Version
|
||||||
|
} deriving Show
|
||||||
|
|
||||||
|
instance FromJSON Deps where
|
||||||
|
parseJSON (Object obj) =
|
||||||
|
do version <- obj .: "version"
|
||||||
|
|
||||||
|
summary <- obj .: "summary"
|
||||||
|
when (length summary >= 80) $
|
||||||
|
fail "'summary' must be less than 80 characters"
|
||||||
|
|
||||||
|
desc <- obj .: "description"
|
||||||
|
license <- obj .: "license"
|
||||||
|
|
||||||
|
repo <- obj .: "repository"
|
||||||
|
name <- case repoToName repo of
|
||||||
|
Left err -> fail err
|
||||||
|
Right nm -> return nm
|
||||||
|
|
||||||
|
exposed <- obj .: "exposed-modules"
|
||||||
|
when (null exposed) $
|
||||||
|
fail "there are no 'exposed-modules'.\n\
|
||||||
|
\At least one module must be exposed for anyone to use this library!"
|
||||||
|
|
||||||
|
elmVersion <- obj .: "elm-version"
|
||||||
|
|
||||||
|
return $ Deps name version summary desc license repo exposed elmVersion
|
||||||
|
|
||||||
|
parseJSON _ = mzero
|
||||||
|
|
||||||
|
repoToName :: String -> Either String N.Name
|
||||||
|
repoToName repo
|
||||||
|
| not (end `List.isSuffixOf` repo) = Left msg
|
||||||
|
| otherwise =
|
||||||
|
do path <- getPath
|
||||||
|
let raw = take (length path - length end) path
|
||||||
|
case N.fromString raw of
|
||||||
|
Nothing -> Left msg
|
||||||
|
Just name -> Right name
|
||||||
|
where
|
||||||
|
getPath | http `List.isPrefixOf` repo = Right $ drop (length http ) repo
|
||||||
|
| https `List.isPrefixOf` repo = Right $ drop (length https) repo
|
||||||
|
| otherwise = Left msg
|
||||||
|
http = "http://github.com/"
|
||||||
|
https = "https://github.com/"
|
||||||
|
end = ".git"
|
||||||
|
msg = "the 'repository' field must point to a GitHub project for now, something\n\
|
||||||
|
\like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
|
||||||
|
\and PROJECT is the repo you want to upload."
|
||||||
|
|
||||||
|
withDeps :: (Deps -> a) -> FilePath -> ErrorT String IO a
|
||||||
|
withDeps handle path =
|
||||||
|
do json <- readPath
|
||||||
|
case eitherDecode json of
|
||||||
|
Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err
|
||||||
|
Right ds -> return (handle ds)
|
||||||
|
where
|
||||||
|
readPath :: ErrorT String IO BS.ByteString
|
||||||
|
readPath = do
|
||||||
|
result <- liftIO $ E.catch (Right <$> BS.readFile path)
|
||||||
|
(\err -> return $ Left (err :: IOError))
|
||||||
|
case result of
|
||||||
|
Right bytes -> return bytes
|
||||||
|
Left _ -> throwError $
|
||||||
|
"could not find file " ++ path ++
|
||||||
|
"\n You may need to create a dependency file for your project."
|
||||||
|
|
||||||
|
dependencies :: FilePath -> ErrorT String IO (Map.Map String String)
|
||||||
|
dependencies _ = return Map.empty -- withDeps deps
|
||||||
|
|
||||||
|
depsAt :: FilePath -> ErrorT String IO Deps
|
||||||
|
depsAt = withDeps id
|
41
compiler/Elm/Internal/Documentation.hs
Normal file
41
compiler/Elm/Internal/Documentation.hs
Normal file
|
@ -0,0 +1,41 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
module Elm.Internal.Documentation where
|
||||||
|
|
||||||
|
import Control.Applicative ((<$>),(<*>))
|
||||||
|
import Control.Monad
|
||||||
|
import Data.Aeson
|
||||||
|
|
||||||
|
data Document = Doc
|
||||||
|
{ moduleName :: String
|
||||||
|
, structure :: String
|
||||||
|
, entries :: [Entry]
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
|
data Entry = Entry
|
||||||
|
{ name :: String
|
||||||
|
, comment :: String
|
||||||
|
, raw :: String
|
||||||
|
, assocPrec :: Maybe (String,Int)
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
|
instance FromJSON Document where
|
||||||
|
parseJSON (Object v) =
|
||||||
|
Doc <$> v .: "name"
|
||||||
|
<*> v .: "document"
|
||||||
|
<*> (concat <$> sequence [ v .: "aliases", v .: "datatypes", v .: "values" ])
|
||||||
|
|
||||||
|
parseJSON _ = fail "Conversion to Document was expecting an object"
|
||||||
|
|
||||||
|
instance FromJSON Entry where
|
||||||
|
parseJSON (Object v) =
|
||||||
|
Entry <$> v .: "name"
|
||||||
|
<*> v .: "comment"
|
||||||
|
<*> v .: "raw"
|
||||||
|
<*> (liftM2 (,) <$> v .:? "associativity"
|
||||||
|
<*> v .:? "precedence")
|
||||||
|
|
||||||
|
parseJSON _ = fail "Conversion to Entry was expecting an object"
|
||||||
|
|
||||||
|
data Content = Markdown String | Value String
|
||||||
|
deriving Show
|
||||||
|
|
48
compiler/Elm/Internal/Name.hs
Normal file
48
compiler/Elm/Internal/Name.hs
Normal file
|
@ -0,0 +1,48 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
|
module Elm.Internal.Name where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Monad.Error
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Binary
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Maybe as Maybe
|
||||||
|
import Data.Typeable
|
||||||
|
|
||||||
|
data Name = Name { user :: String, project :: String }
|
||||||
|
deriving (Typeable,Eq)
|
||||||
|
|
||||||
|
instance Binary Name where
|
||||||
|
get = Name <$> get <*> get
|
||||||
|
put (Name user project) =
|
||||||
|
put user >> put project
|
||||||
|
|
||||||
|
instance Show Name where
|
||||||
|
show name = user name ++ "/" ++ project name
|
||||||
|
|
||||||
|
toFilePath :: Name -> FilePath
|
||||||
|
toFilePath name = user name ++ "-" ++ project name
|
||||||
|
|
||||||
|
fromString :: String -> Maybe Name
|
||||||
|
fromString string =
|
||||||
|
case break (=='/') string of
|
||||||
|
( user@(_:_), '/' : project@(_:_) )
|
||||||
|
| all (/='/') project -> Just (Name user project)
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
fromString' :: String -> ErrorT String IO Name
|
||||||
|
fromString' string =
|
||||||
|
Maybe.maybe (throwError $ errorMsg string) return (fromString string)
|
||||||
|
|
||||||
|
instance FromJSON Name where
|
||||||
|
parseJSON (String text) =
|
||||||
|
let string = T.unpack text in
|
||||||
|
Maybe.maybe (fail $ errorMsg string) return (fromString string)
|
||||||
|
|
||||||
|
parseJSON _ = fail "Project name must be a string."
|
||||||
|
|
||||||
|
errorMsg string =
|
||||||
|
unlines
|
||||||
|
[ "Dependency file has an invalid name: " ++ string
|
||||||
|
, "Must have format user/project and match a public github project."
|
||||||
|
]
|
23
compiler/Elm/Internal/Paths.hs
Normal file
23
compiler/Elm/Internal/Paths.hs
Normal file
|
@ -0,0 +1,23 @@
|
||||||
|
module Elm.Internal.Paths where
|
||||||
|
|
||||||
|
import System.IO.Unsafe
|
||||||
|
import qualified Paths_Elm as This
|
||||||
|
|
||||||
|
-- |Name of directory for all of a project's dependencies.
|
||||||
|
dependencyDirectory :: FilePath
|
||||||
|
dependencyDirectory = "elm_dependencies"
|
||||||
|
|
||||||
|
-- |Name of the dependency file, specifying dependencies and
|
||||||
|
-- other metadata for building and sharing projects.
|
||||||
|
dependencyFile :: FilePath
|
||||||
|
dependencyFile = "elm_dependencies.json"
|
||||||
|
|
||||||
|
{-# NOINLINE runtime #-}
|
||||||
|
-- |The absolute path to Elm's runtime system.
|
||||||
|
runtime :: FilePath
|
||||||
|
runtime = unsafePerformIO $ This.getDataFileName "elm-runtime.js"
|
||||||
|
|
||||||
|
{-# NOINLINE docs #-}
|
||||||
|
-- |The absolute path to Elm's core library documentation.
|
||||||
|
docs :: FilePath
|
||||||
|
docs = unsafePerformIO $ This.getDataFileName "docs.json"
|
|
@ -1,11 +1,6 @@
|
||||||
{- | This module exports functions for compiling Elm to JS
|
{- | This module exports functions for compiling Elm to JS.
|
||||||
and some utilities for making it easier to find some Elm-related files.
|
|
||||||
|
|
||||||
Learning resources for Elm are available at
|
|
||||||
<http://elm-lang.org.elm/Learn.elm> and many interactive examples are
|
|
||||||
available at <http://elm-lang.org/Examples.elm>
|
|
||||||
-}
|
-}
|
||||||
module Language.Elm (compile, moduleName, runtime, docs) where
|
module Elm.Internal.Utils (compile, moduleName) where
|
||||||
|
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
import qualified Generate.JavaScript as JS
|
import qualified Generate.JavaScript as JS
|
||||||
|
@ -14,7 +9,6 @@ import qualified Parse.Module as Parser
|
||||||
import qualified SourceSyntax.Module as M
|
import qualified SourceSyntax.Module as M
|
||||||
import qualified Text.PrettyPrint as P
|
import qualified Text.PrettyPrint as P
|
||||||
import qualified Metadata.Prelude as Prelude
|
import qualified Metadata.Prelude as Prelude
|
||||||
import qualified Paths_Elm as This
|
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
|
|
||||||
-- |This function compiles Elm code to JavaScript. It will return either
|
-- |This function compiles Elm code to JavaScript. It will return either
|
||||||
|
@ -32,11 +26,3 @@ interfaces = unsafePerformIO $ Prelude.interfaces
|
||||||
-- |This function extracts the module name of a given source program.
|
-- |This function extracts the module name of a given source program.
|
||||||
moduleName :: String -> Maybe String
|
moduleName :: String -> Maybe String
|
||||||
moduleName = Parser.getModuleName
|
moduleName = Parser.getModuleName
|
||||||
|
|
||||||
-- |The absolute path to Elm's runtime system.
|
|
||||||
runtime :: IO FilePath
|
|
||||||
runtime = This.getDataFileName "elm-runtime.js"
|
|
||||||
|
|
||||||
-- |The absolute path to Elm's core library documentation.
|
|
||||||
docs :: IO FilePath
|
|
||||||
docs = This.getDataFileName "docs.json"
|
|
63
compiler/Elm/Internal/Version.hs
Normal file
63
compiler/Elm/Internal/Version.hs
Normal file
|
@ -0,0 +1,63 @@
|
||||||
|
{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
|
||||||
|
module Elm.Internal.Version where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Binary
|
||||||
|
import Data.Char (isDigit)
|
||||||
|
import qualified Data.List as List
|
||||||
|
import Data.Typeable
|
||||||
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
-- Data representation
|
||||||
|
|
||||||
|
data Version = V [Int] String
|
||||||
|
deriving (Typeable,Eq)
|
||||||
|
|
||||||
|
instance Ord Version where
|
||||||
|
compare (V ns tag) (V ns' tag') =
|
||||||
|
case compare ns ns' of
|
||||||
|
EQ -> compare tag' tag -- reverse comparison to favor ""
|
||||||
|
cmp -> cmp
|
||||||
|
|
||||||
|
instance Show Version where
|
||||||
|
show (V ns tag) =
|
||||||
|
List.intercalate "." (map show ns) ++ if null tag then "" else "-" ++ tag
|
||||||
|
|
||||||
|
instance Binary Version where
|
||||||
|
get = V <$> get <*> get
|
||||||
|
put (V ns tag) = do put ns
|
||||||
|
put tag
|
||||||
|
|
||||||
|
tagless :: Version -> Bool
|
||||||
|
tagless (V _ tag) = null tag
|
||||||
|
|
||||||
|
fromString :: String -> Maybe Version
|
||||||
|
fromString version = V <$> splitNumbers possibleNumbers <*> tag
|
||||||
|
where
|
||||||
|
(possibleNumbers, possibleTag) = break (=='-') version
|
||||||
|
|
||||||
|
tag = case possibleTag of
|
||||||
|
"" -> Just ""
|
||||||
|
'-':rest -> Just rest
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
splitNumbers :: String -> Maybe [Int]
|
||||||
|
splitNumbers ns =
|
||||||
|
case span isDigit ns of
|
||||||
|
("", _) -> Nothing
|
||||||
|
(number, []) -> Just [read number]
|
||||||
|
(number, '.':rest) -> (read number :) <$> splitNumbers rest
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
instance FromJSON Version where
|
||||||
|
parseJSON (String text) =
|
||||||
|
let string = T.unpack text in
|
||||||
|
case fromString string of
|
||||||
|
Just v -> return v
|
||||||
|
Nothing -> fail $ unlines
|
||||||
|
[ "Dependency file has an invalid version number: " ++ string
|
||||||
|
, "Must have format 0.1.2 or 0.1.2-tag"
|
||||||
|
]
|
||||||
|
|
||||||
|
parseJSON _ = fail "Version number must be stored as a string."
|
Loading…
Reference in a new issue