Merge branch 'dev'
This commit is contained in:
commit
b65bf8ccc9
94 changed files with 2475 additions and 1934 deletions
27
Elm.cabal
27
Elm.cabal
|
@ -1,5 +1,5 @@
|
||||||
Name: Elm
|
Name: Elm
|
||||||
Version: 0.11
|
Version: 0.12
|
||||||
Synopsis: The Elm language module.
|
Synopsis: The Elm language module.
|
||||||
Description: Elm aims to make client-side web-development more pleasant.
|
Description: Elm aims to make client-side web-development more pleasant.
|
||||||
It is a statically/strongly typed, functional reactive
|
It is a statically/strongly typed, functional reactive
|
||||||
|
@ -14,7 +14,7 @@ License-file: LICENSE
|
||||||
|
|
||||||
Author: Evan Czaplicki
|
Author: Evan Czaplicki
|
||||||
Maintainer: info@elm-lang.org
|
Maintainer: info@elm-lang.org
|
||||||
Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
|
Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
|
||||||
|
|
||||||
Category: Compiler, Language
|
Category: Compiler, Language
|
||||||
|
|
||||||
|
@ -37,19 +37,19 @@ Library
|
||||||
Elm.Internal.Utils,
|
Elm.Internal.Utils,
|
||||||
Elm.Internal.Version
|
Elm.Internal.Version
|
||||||
Hs-Source-Dirs: compiler
|
Hs-Source-Dirs: compiler
|
||||||
other-modules: SourceSyntax.Declaration,
|
other-modules: SourceSyntax.Annotation,
|
||||||
|
SourceSyntax.Declaration,
|
||||||
SourceSyntax.Expression,
|
SourceSyntax.Expression,
|
||||||
SourceSyntax.Helpers,
|
SourceSyntax.Helpers,
|
||||||
SourceSyntax.Literal,
|
SourceSyntax.Literal,
|
||||||
SourceSyntax.Location,
|
|
||||||
SourceSyntax.Module,
|
SourceSyntax.Module,
|
||||||
SourceSyntax.Pattern,
|
SourceSyntax.Pattern,
|
||||||
SourceSyntax.PrettyPrint,
|
SourceSyntax.PrettyPrint,
|
||||||
SourceSyntax.Type,
|
SourceSyntax.Type,
|
||||||
|
SourceSyntax.Variable,
|
||||||
Generate.JavaScript,
|
Generate.JavaScript,
|
||||||
Generate.JavaScript.Helpers,
|
Generate.JavaScript.Helpers,
|
||||||
Generate.JavaScript.Ports,
|
Generate.JavaScript.Ports,
|
||||||
Generate.Noscript,
|
|
||||||
Generate.Markdown,
|
Generate.Markdown,
|
||||||
Generate.Html,
|
Generate.Html,
|
||||||
Generate.Cases,
|
Generate.Cases,
|
||||||
|
@ -97,7 +97,7 @@ Library
|
||||||
Build-depends: aeson,
|
Build-depends: aeson,
|
||||||
base >=4.2 && <5,
|
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.8,
|
||||||
blaze-markup,
|
blaze-markup,
|
||||||
bytestring,
|
bytestring,
|
||||||
cmdargs,
|
cmdargs,
|
||||||
|
@ -119,19 +119,19 @@ Executable elm
|
||||||
Main-is: Compiler.hs
|
Main-is: Compiler.hs
|
||||||
ghc-options: -threaded -O2
|
ghc-options: -threaded -O2
|
||||||
Hs-Source-Dirs: compiler
|
Hs-Source-Dirs: compiler
|
||||||
other-modules: SourceSyntax.Declaration,
|
other-modules: SourceSyntax.Annotation,
|
||||||
|
SourceSyntax.Declaration,
|
||||||
SourceSyntax.Expression,
|
SourceSyntax.Expression,
|
||||||
SourceSyntax.Helpers,
|
SourceSyntax.Helpers,
|
||||||
SourceSyntax.Literal,
|
SourceSyntax.Literal,
|
||||||
SourceSyntax.Location,
|
|
||||||
SourceSyntax.Module,
|
SourceSyntax.Module,
|
||||||
SourceSyntax.Pattern,
|
SourceSyntax.Pattern,
|
||||||
SourceSyntax.PrettyPrint,
|
SourceSyntax.PrettyPrint,
|
||||||
SourceSyntax.Type,
|
SourceSyntax.Type,
|
||||||
|
SourceSyntax.Variable,
|
||||||
Generate.JavaScript,
|
Generate.JavaScript,
|
||||||
Generate.JavaScript.Helpers,
|
Generate.JavaScript.Helpers,
|
||||||
Generate.JavaScript.Ports,
|
Generate.JavaScript.Ports,
|
||||||
Generate.Noscript,
|
|
||||||
Generate.Markdown,
|
Generate.Markdown,
|
||||||
Generate.Html,
|
Generate.Html,
|
||||||
Generate.Cases,
|
Generate.Cases,
|
||||||
|
@ -179,8 +179,8 @@ Executable elm
|
||||||
Build-depends: aeson,
|
Build-depends: aeson,
|
||||||
base >=4.2 && <5,
|
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.8,
|
||||||
blaze-markup == 0.5.1.*,
|
blaze-markup,
|
||||||
bytestring,
|
bytestring,
|
||||||
cmdargs,
|
cmdargs,
|
||||||
containers >= 0.3,
|
containers >= 0.3,
|
||||||
|
@ -200,15 +200,16 @@ Executable elm
|
||||||
Executable elm-doc
|
Executable elm-doc
|
||||||
Main-is: Docs.hs
|
Main-is: Docs.hs
|
||||||
Hs-Source-Dirs: compiler
|
Hs-Source-Dirs: compiler
|
||||||
other-modules: SourceSyntax.Declaration,
|
other-modules: SourceSyntax.Annotation,
|
||||||
|
SourceSyntax.Declaration,
|
||||||
SourceSyntax.Expression,
|
SourceSyntax.Expression,
|
||||||
SourceSyntax.Helpers,
|
SourceSyntax.Helpers,
|
||||||
SourceSyntax.Literal,
|
SourceSyntax.Literal,
|
||||||
SourceSyntax.Location,
|
|
||||||
SourceSyntax.Module,
|
SourceSyntax.Module,
|
||||||
SourceSyntax.Pattern,
|
SourceSyntax.Pattern,
|
||||||
SourceSyntax.PrettyPrint,
|
SourceSyntax.PrettyPrint,
|
||||||
SourceSyntax.Type,
|
SourceSyntax.Type,
|
||||||
|
SourceSyntax.Variable,
|
||||||
Parse.Binop,
|
Parse.Binop,
|
||||||
Parse.Declaration,
|
Parse.Declaration,
|
||||||
Parse.Expression,
|
Parse.Expression,
|
||||||
|
|
3
Setup.hs
3
Setup.hs
|
@ -148,7 +148,8 @@ buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()
|
||||||
buildRuntime lbi elmos = do
|
buildRuntime lbi elmos = do
|
||||||
createDirectoryIfMissing True (rtsDir lbi)
|
createDirectoryIfMissing True (rtsDir lbi)
|
||||||
let rts' = rts lbi
|
let rts' = rts lbi
|
||||||
writeFile rts' "var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
|
writeFile rts' "'use strict';\n\
|
||||||
|
\var Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
|
||||||
\var ElmRuntime = {}; ElmRuntime.Render = {};\n"
|
\var ElmRuntime = {}; ElmRuntime.Render = {};\n"
|
||||||
mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
|
mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
|
||||||
mapM_ (appendTo rts') elmos
|
mapM_ (appendTo rts') elmos
|
||||||
|
|
|
@ -1,10 +1,38 @@
|
||||||
|
|
||||||
|
## 0.12
|
||||||
|
|
||||||
|
#### Breaking Changes:
|
||||||
|
|
||||||
|
* Overhaul Graphics.Input library (inspired by Spiros Eliopoulos and Jeff Smitts)
|
||||||
|
* Overhaul Text library to accomodate new Graphics.Input.Field
|
||||||
|
library and make the API more consistent overall
|
||||||
|
* Overhaul Regex library (inspired by Attila Gazso)
|
||||||
|
* Change syntax for "import open List" to "import List (..)"
|
||||||
|
* Improved JSON format for types generated by elm-doc
|
||||||
|
* Remove problematic Mouse.isClicked signal
|
||||||
|
* Revise the semantics of keepWhen and dropWhen to only update when
|
||||||
|
the filtered signal changes (thanks Max New and Janis Voigtländer)
|
||||||
|
|
||||||
|
#### Improvements:
|
||||||
|
|
||||||
|
* Add Graphics.Input.Field for customizable text fields
|
||||||
|
* Add Trampoline library (thanks to @maxsnew and @timthelion)
|
||||||
|
* Add Debug library (inspired by @timthelion)
|
||||||
|
* Drastically improved performance on markdown parsing (thanks to @Dandandan)
|
||||||
|
* Add Date.fromTime function
|
||||||
|
* Use pointer-events to detect hovers on layered elements (thanks to @Xashili)
|
||||||
|
* Fix bugs in Bitwise library
|
||||||
|
* Fix bug when exporting Maybe values through ports
|
||||||
|
|
||||||
## 0.11
|
## 0.11
|
||||||
|
|
||||||
* Lazy and Lazy.Stream (thanks to Max New)
|
* Ports, a new FFI that is more general and much nicer to use
|
||||||
* sortBy, sortWith (thanks to Max Goldstein)
|
* Basic compiler tests (thanks to Max New)
|
||||||
|
|
||||||
|
## 0.10.1
|
||||||
|
|
||||||
|
* sort, sortBy, sortWith (thanks to Max Goldstein)
|
||||||
* elm-repl
|
* elm-repl
|
||||||
* Markdown interpolation
|
|
||||||
* Bitwise library
|
* Bitwise library
|
||||||
* Regex library
|
* Regex library
|
||||||
* Improve Transform2D library (thanks to Michael Søndergaard)
|
* Improve Transform2D library (thanks to Michael Søndergaard)
|
|
@ -29,10 +29,7 @@ getSortedDependencies srcDirs builtIns root =
|
||||||
result <- runErrorT $ readAllDeps allSrcDirs builtIns root
|
result <- runErrorT $ readAllDeps allSrcDirs builtIns root
|
||||||
case result of
|
case result of
|
||||||
Right deps -> sortDeps deps
|
Right deps -> sortDeps deps
|
||||||
Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
|
Left err -> failure err
|
||||||
where msg = "\nYou may need to create a " ++
|
|
||||||
Path.dependencyFile ++
|
|
||||||
" file if you\nare trying to use a 3rd party library."
|
|
||||||
|
|
||||||
extraDependencies :: IO (Maybe [FilePath])
|
extraDependencies :: IO (Maybe [FilePath])
|
||||||
extraDependencies =
|
extraDependencies =
|
||||||
|
@ -75,20 +72,22 @@ sortDeps depends =
|
||||||
msg = "A cyclical module dependency or was detected in:\n"
|
msg = "A cyclical module dependency or was detected in:\n"
|
||||||
|
|
||||||
readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
|
readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
|
||||||
readAllDeps srcDirs builtIns root =
|
readAllDeps srcDirs rawBuiltIns filePath =
|
||||||
do let ifaces = (Set.fromList . Map.keys) builtIns
|
State.evalStateT (go Nothing filePath) Set.empty
|
||||||
State.evalStateT (go ifaces root) Set.empty
|
|
||||||
where
|
where
|
||||||
go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
|
builtIns :: Set.Set String
|
||||||
go builtIns root = do
|
builtIns = Set.fromList $ Map.keys rawBuiltIns
|
||||||
root' <- lift $ findSrcFile srcDirs root
|
|
||||||
(name, deps) <- lift $ readDeps root'
|
go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
|
||||||
|
go parentModuleName filePath = do
|
||||||
|
filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
|
||||||
|
(moduleName, deps) <- lift $ readDeps filePath'
|
||||||
seen <- State.get
|
seen <- State.get
|
||||||
let realDeps = Set.difference (Set.fromList deps) builtIns
|
let realDeps = Set.difference (Set.fromList deps) builtIns
|
||||||
newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
|
newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
|
||||||
State.put (Set.insert name (Set.union newDeps seen))
|
State.put (Set.insert moduleName (Set.union newDeps seen))
|
||||||
rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
|
rest <- mapM (go (Just moduleName) . toFilePath) (Set.toList newDeps)
|
||||||
return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
|
return ((makeRelative "." filePath', moduleName, Set.toList realDeps) : concat rest)
|
||||||
|
|
||||||
readDeps :: FilePath -> ErrorT String IO (String, [String])
|
readDeps :: FilePath -> ErrorT String IO (String, [String])
|
||||||
readDeps path = do
|
readDeps path = do
|
||||||
|
@ -98,15 +97,10 @@ readDeps path = do
|
||||||
where msg = "Error resolving dependencies in " ++ path ++ ":\n"
|
where msg = "Error resolving dependencies in " ++ path ++ ":\n"
|
||||||
Right o -> return o
|
Right o -> return o
|
||||||
|
|
||||||
findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
|
findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
|
||||||
findSrcFile dirs path = foldr tryDir notFound dirs
|
findSrcFile parentModuleName dirs path =
|
||||||
|
foldr tryDir notFound dirs
|
||||||
where
|
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
|
tryDir dir next = do
|
||||||
let path' = dir </> path
|
let path' = dir </> path
|
||||||
exists <- liftIO $ doesFileExist path'
|
exists <- liftIO $ doesFileExist path'
|
||||||
|
@ -114,6 +108,20 @@ findSrcFile dirs path = foldr tryDir notFound dirs
|
||||||
then return path'
|
then return path'
|
||||||
else next
|
else next
|
||||||
|
|
||||||
|
parentModuleName' =
|
||||||
|
case parentModuleName of
|
||||||
|
Just name -> "module '" ++ name ++ "'"
|
||||||
|
Nothing -> "the main module"
|
||||||
|
|
||||||
|
notFound = throwError $ unlines
|
||||||
|
[ "When finding the imports declared in " ++ parentModuleName' ++ ", could not find file: " ++ path
|
||||||
|
, " If you created this module, but it is in a subdirectory that does not"
|
||||||
|
, " exactly match the module name, you may need to use the --src-dir flag."
|
||||||
|
, ""
|
||||||
|
, " If it is part of a 3rd party library, it needs to be declared"
|
||||||
|
, " as a dependency in your project's " ++ Path.dependencyFile ++ " file."
|
||||||
|
]
|
||||||
|
|
||||||
isNative :: String -> Bool
|
isNative :: String -> Bool
|
||||||
isNative name = List.isPrefixOf "Native." name
|
isNative name = List.isPrefixOf "Native." name
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,6 @@
|
||||||
module Build.Source (build) where
|
module Build.Source (build) where
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
|
||||||
import System.FilePath as FP
|
import System.FilePath as FP
|
||||||
import Text.PrettyPrint (Doc)
|
import Text.PrettyPrint (Doc)
|
||||||
|
|
||||||
|
@ -33,7 +32,7 @@ build noPrelude interfaces source =
|
||||||
|
|
||||||
let exports'
|
let exports'
|
||||||
| null exs =
|
| null exs =
|
||||||
let get = Set.toList . Pattern.boundVars in
|
let get = Pattern.boundVarList in
|
||||||
concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
|
concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
|
||||||
concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
|
concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
|
||||||
[ name | TypeAlias name _ (Type.Record _ _) <- decls ]
|
[ name | TypeAlias name _ (Type.Record _ _) <- decls ]
|
||||||
|
|
|
@ -1,8 +1,11 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Build.Utils where
|
module Build.Utils where
|
||||||
|
|
||||||
|
import System.Directory (doesFileExist)
|
||||||
|
import System.Environment (getEnv)
|
||||||
import System.FilePath ((</>), replaceExtension)
|
import System.FilePath ((</>), replaceExtension)
|
||||||
import qualified Build.Flags as Flag
|
import qualified Build.Flags as Flag
|
||||||
|
import qualified Paths_Elm as This
|
||||||
|
|
||||||
buildPath :: Flag.Flags -> FilePath -> String -> FilePath
|
buildPath :: Flag.Flags -> FilePath -> String -> FilePath
|
||||||
buildPath flags filePath ext =
|
buildPath flags filePath ext =
|
||||||
|
@ -19,3 +22,14 @@ elmo flags filePath =
|
||||||
elmi :: Flag.Flags -> FilePath -> FilePath
|
elmi :: Flag.Flags -> FilePath -> FilePath
|
||||||
elmi flags filePath =
|
elmi flags filePath =
|
||||||
cachePath flags filePath "elmi"
|
cachePath flags filePath "elmi"
|
||||||
|
|
||||||
|
-- |The absolute path to a data file
|
||||||
|
getDataFile :: FilePath -> IO FilePath
|
||||||
|
getDataFile name = do
|
||||||
|
path <- This.getDataFileName name
|
||||||
|
exists <- doesFileExist path
|
||||||
|
if exists
|
||||||
|
then return path
|
||||||
|
else do
|
||||||
|
env <- getEnv "ELM_HOME"
|
||||||
|
return (env </> name)
|
||||||
|
|
|
@ -8,6 +8,7 @@ import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
|
import Control.Arrow (second)
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Aeson.Encode.Pretty
|
import Data.Aeson.Encode.Pretty
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
|
@ -15,8 +16,8 @@ import qualified Data.Map as Map
|
||||||
import qualified Data.ByteString.Lazy as BS
|
import qualified Data.ByteString.Lazy as BS
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
import SourceSyntax.Helpers (isSymbol)
|
import qualified SourceSyntax.Helpers as Help
|
||||||
import SourceSyntax.Type (Type(..))
|
import qualified SourceSyntax.Type as T
|
||||||
import qualified SourceSyntax.Expression as E
|
import qualified SourceSyntax.Expression as E
|
||||||
import qualified SourceSyntax.Declaration as D
|
import qualified SourceSyntax.Declaration as D
|
||||||
|
|
||||||
|
@ -30,20 +31,24 @@ data Flags = Flags
|
||||||
{ files :: [FilePath] }
|
{ files :: [FilePath] }
|
||||||
deriving (Data,Typeable,Show,Eq)
|
deriving (Data,Typeable,Show,Eq)
|
||||||
|
|
||||||
|
defaultFlags :: Flags
|
||||||
defaultFlags = Flags
|
defaultFlags = Flags
|
||||||
{ files = def &= args &= typ "FILES"
|
{ files = def &= args &= typ "FILES"
|
||||||
} &= help "Generate documentation for Elm"
|
} &= help "Generate documentation for Elm"
|
||||||
&= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
|
&= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
flags <- cmdArgs defaultFlags
|
flags <- cmdArgs defaultFlags
|
||||||
mapM parseFile (files flags)
|
mapM_ parseFile (files flags)
|
||||||
|
|
||||||
|
config :: Config
|
||||||
config = Config { confIndent = 2, confCompare = keyOrder keys }
|
config = Config { confIndent = 2, confCompare = keyOrder keys }
|
||||||
where
|
where
|
||||||
keys = ["name","document","comment","raw","aliases","datatypes"
|
keys = ["tag","name","document","comment","raw","aliases","datatypes"
|
||||||
,"values","typeVariables","type","constructors"]
|
,"values","typeVariables","type","constructors"]
|
||||||
|
|
||||||
|
parseFile :: FilePath -> IO ()
|
||||||
parseFile path = do
|
parseFile path = do
|
||||||
source <- readFile path
|
source <- readFile path
|
||||||
case iParse docs source of
|
case iParse docs source of
|
||||||
|
@ -69,6 +74,7 @@ docComment = do
|
||||||
let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
|
let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
|
||||||
return $ dropWhile (==' ') (reverse reversed)
|
return $ dropWhile (==' ') (reverse reversed)
|
||||||
|
|
||||||
|
moduleDocs :: IParser (String, [String], String)
|
||||||
moduleDocs = do
|
moduleDocs = do
|
||||||
optional freshLine
|
optional freshLine
|
||||||
(names,exports) <- moduleDef
|
(names,exports) <- moduleDef
|
||||||
|
@ -121,7 +127,7 @@ collect infixes types aliases adts things =
|
||||||
where
|
where
|
||||||
nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
|
nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
|
||||||
addDefaultInfix name pairs
|
addDefaultInfix name pairs
|
||||||
| all isSymbol name = addInfix (D.L, 9 :: Int) pairs
|
| all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
|
||||||
| otherwise = pairs
|
| otherwise = pairs
|
||||||
|
|
||||||
customOps = Map.intersectionWith addInfix infixes types
|
customOps = Map.intersectionWith addInfix infixes types
|
||||||
|
@ -138,7 +144,7 @@ collect infixes types aliases adts things =
|
||||||
let fields = ["typeVariables" .= vars, "type" .= tipe ]
|
let fields = ["typeVariables" .= vars, "type" .= tipe ]
|
||||||
in collect infixes types (insert name fields aliases) adts rest
|
in collect infixes types (insert name fields aliases) adts rest
|
||||||
D.Datatype name vars ctors ->
|
D.Datatype name vars ctors ->
|
||||||
let tipe = Data name (map Var vars)
|
let tipe = T.Data name (map T.Var vars)
|
||||||
fields = ["typeVariables" .= vars
|
fields = ["typeVariables" .= vars
|
||||||
, "constructors" .= map (ctorToJson tipe) ctors ]
|
, "constructors" .= map (ctorToJson tipe) ctors ]
|
||||||
in collect infixes types aliases (insert name fields adts) rest
|
in collect infixes types aliases (insert name fields adts) rest
|
||||||
|
@ -147,17 +153,35 @@ collect infixes types aliases adts things =
|
||||||
obj name fields =
|
obj name fields =
|
||||||
[ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
|
[ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
|
||||||
|
|
||||||
instance ToJSON Type where
|
instance ToJSON T.Type where
|
||||||
toJSON tipe =
|
toJSON tipe =
|
||||||
|
object $
|
||||||
case tipe of
|
case tipe of
|
||||||
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
|
T.Lambda _ _ ->
|
||||||
Var x -> toJSON x
|
let tipes = T.collectLambdas tipe in
|
||||||
Data name ts -> toJSON (toJSON name : map toJSON ts)
|
[ "tag" .= ("function" :: Text.Text)
|
||||||
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
|
, "args" .= toJSON (init tipes)
|
||||||
where fields' = case ext of
|
, "result" .= toJSON (last tipes)
|
||||||
Nothing -> fields
|
]
|
||||||
Just x -> ("_", Var x) : fields
|
|
||||||
|
|
||||||
|
T.Var x ->
|
||||||
|
[ "tag" .= ("var" :: Text.Text)
|
||||||
|
, "name" .= toJSON x
|
||||||
|
]
|
||||||
|
|
||||||
|
T.Data name ts ->
|
||||||
|
[ "tag" .= ("adt" :: Text.Text)
|
||||||
|
, "name" .= toJSON name
|
||||||
|
, "args" .= map toJSON ts
|
||||||
|
]
|
||||||
|
|
||||||
|
T.Record fields ext ->
|
||||||
|
[ "tag" .= ("record" :: Text.Text)
|
||||||
|
, "fields" .= toJSON (map (toJSON . second toJSON) fields)
|
||||||
|
, "extension" .= toJSON ext
|
||||||
|
]
|
||||||
|
|
||||||
|
ctorToJson :: T.Type -> (String, [T.Type]) -> Value
|
||||||
ctorToJson tipe (ctor, tipes) =
|
ctorToJson tipe (ctor, tipes) =
|
||||||
object [ "name" .= ctor
|
object [ "name" .= ctor
|
||||||
, "type" .= foldr Lambda tipe tipes ]
|
, "type" .= foldr T.Lambda tipe tipes ]
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
|
{-# OPTIONS_GHC -Wall #-}
|
||||||
module Elm.Internal.Paths where
|
module Elm.Internal.Paths where
|
||||||
|
|
||||||
import System.IO.Unsafe
|
import Build.Utils (getDataFile)
|
||||||
import qualified Paths_Elm as This
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
|
|
||||||
-- |Name of directory for all of a project's dependencies.
|
-- |Name of directory for all of a project's dependencies.
|
||||||
dependencyDirectory :: FilePath
|
dependencyDirectory :: FilePath
|
||||||
|
@ -15,9 +16,9 @@ dependencyFile = "elm_dependencies.json"
|
||||||
{-# NOINLINE runtime #-}
|
{-# NOINLINE runtime #-}
|
||||||
-- |The absolute path to Elm's runtime system.
|
-- |The absolute path to Elm's runtime system.
|
||||||
runtime :: FilePath
|
runtime :: FilePath
|
||||||
runtime = unsafePerformIO $ This.getDataFileName "elm-runtime.js"
|
runtime = unsafePerformIO $ getDataFile "elm-runtime.js"
|
||||||
|
|
||||||
{-# NOINLINE docs #-}
|
{-# NOINLINE docs #-}
|
||||||
-- |The absolute path to Elm's core library documentation.
|
-- |The absolute path to Elm's core library documentation.
|
||||||
docs :: FilePath
|
docs :: FilePath
|
||||||
docs = unsafePerformIO $ This.getDataFileName "docs.json"
|
docs = unsafePerformIO $ getDataFile "docs.json"
|
||||||
|
|
|
@ -6,14 +6,15 @@ import Control.Monad.State
|
||||||
import Data.List (groupBy,sortBy)
|
import Data.List (groupBy,sortBy)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
|
||||||
import SourceSyntax.Location
|
import SourceSyntax.Annotation
|
||||||
import SourceSyntax.Literal
|
|
||||||
import SourceSyntax.Pattern
|
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
|
import SourceSyntax.Literal
|
||||||
|
import qualified SourceSyntax.Pattern as P
|
||||||
|
import qualified SourceSyntax.Variable as V
|
||||||
import Transform.Substitute
|
import Transform.Substitute
|
||||||
|
|
||||||
|
|
||||||
toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
|
toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
|
||||||
toMatch patterns = do
|
toMatch patterns = do
|
||||||
v <- newVar
|
v <- newVar
|
||||||
(,) v <$> match [v] (map (first (:[])) patterns) Fail
|
(,) v <$> match [v] (map (first (:[])) patterns) Fail
|
||||||
|
@ -27,7 +28,7 @@ data Match
|
||||||
= Match String [Clause] Match
|
= Match String [Clause] Match
|
||||||
| Break
|
| Break
|
||||||
| Fail
|
| Fail
|
||||||
| Other LExpr
|
| Other Expr
|
||||||
| Seq [Match]
|
| Seq [Match]
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
|
||||||
matchSubst _ Break = Break
|
matchSubst _ Break = Break
|
||||||
matchSubst _ Fail = Fail
|
matchSubst _ Fail = Fail
|
||||||
matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
|
matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
|
||||||
matchSubst pairs (Other (L s e)) =
|
matchSubst pairs (Other (A a e)) =
|
||||||
Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
|
Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
|
||||||
matchSubst pairs (Match n cs m) =
|
matchSubst pairs (Match n cs m) =
|
||||||
Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
|
Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
|
||||||
where varSubst v = fromMaybe v (lookup v pairs)
|
where varSubst v = fromMaybe v (lookup v pairs)
|
||||||
|
@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
|
||||||
|
|
||||||
isCon (p:_, _) =
|
isCon (p:_, _) =
|
||||||
case p of
|
case p of
|
||||||
PData _ _ -> True
|
P.Data _ _ -> True
|
||||||
PLiteral _ -> True
|
P.Literal _ -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
isVar p = not (isCon p)
|
isVar p = not (isCon p)
|
||||||
|
|
||||||
match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
|
match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
|
||||||
match [] [] def = return def
|
match [] [] def = return def
|
||||||
match [] [([],e)] Fail = return $ Other e
|
match [] [([],e)] Fail = return $ Other e
|
||||||
match [] [([],e)] Break = return $ Other e
|
match [] [([],e)] Break = return $ Other e
|
||||||
|
@ -67,46 +68,46 @@ match vs@(v:_) cs def
|
||||||
where
|
where
|
||||||
cs' = map (dealias v) cs
|
cs' = map (dealias v) cs
|
||||||
|
|
||||||
dealias v c@(p:ps, L s e) =
|
dealias v c@(p:ps, A a e) =
|
||||||
case p of
|
case p of
|
||||||
PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
|
P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)
|
||||||
_ -> c
|
_ -> c
|
||||||
|
|
||||||
matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
|
matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
|
||||||
matchVar (v:vs) cs def = match vs (map subVar cs) def
|
matchVar (v:vs) cs def = match vs (map subVar cs) def
|
||||||
where
|
where
|
||||||
subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)
|
subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
|
||||||
where
|
where
|
||||||
subOnePattern pattern e =
|
subOnePattern pattern e =
|
||||||
case pattern of
|
case pattern of
|
||||||
PVar x -> subst x (Var v) e
|
P.Var x -> subst x (rawVar v) e
|
||||||
PAnything -> e
|
P.Anything -> e
|
||||||
PRecord fs ->
|
P.Record fs ->
|
||||||
foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
|
foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
|
||||||
|
|
||||||
matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
|
matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
|
||||||
matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
|
matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
|
||||||
where
|
where
|
||||||
css = groupBy eq (sortBy cmp cs)
|
css = groupBy eq (sortBy cmp cs)
|
||||||
|
|
||||||
cmp (p1:_,_) (p2:_,_) =
|
cmp (p1:_,_) (p2:_,_) =
|
||||||
case (p1,p2) of
|
case (p1,p2) of
|
||||||
(PData n1 _, PData n2 _) -> compare n1 n2
|
(P.Data n1 _, P.Data n2 _) -> compare n1 n2
|
||||||
_ -> compare p1 p2
|
_ -> compare p1 p2
|
||||||
|
|
||||||
eq (p1:_,_) (p2:_,_) =
|
eq (p1:_,_) (p2:_,_) =
|
||||||
case (p1,p2) of
|
case (p1,p2) of
|
||||||
(PData n1 _, PData n2 _) -> n1 == n2
|
(P.Data n1 _, P.Data n2 _) -> n1 == n2
|
||||||
_ -> p1 == p2
|
_ -> p1 == p2
|
||||||
|
|
||||||
toClause cs =
|
toClause cs =
|
||||||
case head cs of
|
case head cs of
|
||||||
(PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
|
(P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
|
||||||
(PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
|
(P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
|
||||||
|
|
||||||
matchClause :: Either String Literal
|
matchClause :: Either String Literal
|
||||||
-> [String]
|
-> [String]
|
||||||
-> [([Pattern],LExpr)]
|
-> [([P.Pattern],Expr)]
|
||||||
-> Match
|
-> Match
|
||||||
-> State Int Clause
|
-> State Int Clause
|
||||||
matchClause c (_:vs) cs def =
|
matchClause c (_:vs) cs def =
|
||||||
|
@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
|
||||||
|
|
||||||
flatten (p:ps, e) =
|
flatten (p:ps, e) =
|
||||||
case p of
|
case p of
|
||||||
PData _ ps' -> (ps' ++ ps, e)
|
P.Data _ ps' -> (ps' ++ ps, e)
|
||||||
PLiteral _ -> (ps, e)
|
P.Literal _ -> (ps, e)
|
||||||
|
|
||||||
getVars =
|
getVars =
|
||||||
case head cs of
|
case head cs of
|
||||||
(PData _ ps : _, _) -> forM ps (const newVar)
|
(P.Data _ ps : _, _) -> forM ps (const newVar)
|
||||||
(PLiteral _ : _, _) -> return []
|
(P.Literal _ : _, _) -> return []
|
||||||
|
|
||||||
matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
|
matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
|
||||||
matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
|
matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
|
||||||
where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
|
where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
|
|
@ -1,25 +1,27 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Generate.JavaScript (generate) where
|
module Generate.JavaScript (generate) where
|
||||||
|
|
||||||
import Control.Arrow (first,(***))
|
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
|
import Control.Arrow (first,(***))
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
import Language.ECMAScript3.PrettyPrint
|
||||||
|
import Language.ECMAScript3.Syntax
|
||||||
|
|
||||||
import Generate.JavaScript.Helpers
|
import Generate.JavaScript.Helpers
|
||||||
import qualified Generate.Cases as Case
|
import qualified Generate.Cases as Case
|
||||||
import qualified Generate.JavaScript.Ports as Port
|
import qualified Generate.JavaScript.Ports as Port
|
||||||
import qualified Generate.Markdown as MD
|
import qualified Generate.Markdown as MD
|
||||||
|
import SourceSyntax.Annotation
|
||||||
|
import SourceSyntax.Expression
|
||||||
import qualified SourceSyntax.Helpers as Help
|
import qualified SourceSyntax.Helpers as Help
|
||||||
import SourceSyntax.Literal
|
import SourceSyntax.Literal
|
||||||
import SourceSyntax.Pattern as Pattern
|
|
||||||
import SourceSyntax.Location
|
|
||||||
import SourceSyntax.Expression
|
|
||||||
import SourceSyntax.Module
|
import SourceSyntax.Module
|
||||||
import Language.ECMAScript3.Syntax
|
import qualified SourceSyntax.Pattern as P
|
||||||
import Language.ECMAScript3.PrettyPrint
|
import SourceSyntax.PrettyPrint (renderPretty)
|
||||||
|
import qualified SourceSyntax.Variable as V
|
||||||
import qualified Transform.SafeNames as MakeSafe
|
import qualified Transform.SafeNames as MakeSafe
|
||||||
|
|
||||||
varDecl :: String -> Expression () -> VarDecl ()
|
varDecl :: String -> Expression () -> VarDecl ()
|
||||||
|
@ -50,10 +52,10 @@ literal lit =
|
||||||
FloatNum n -> NumLit () n
|
FloatNum n -> NumLit () n
|
||||||
Boolean b -> BoolLit () b
|
Boolean b -> BoolLit () b
|
||||||
|
|
||||||
expression :: LExpr -> State Int (Expression ())
|
expression :: Expr -> State Int (Expression ())
|
||||||
expression (L span expr) =
|
expression (A region expr) =
|
||||||
case expr of
|
case expr of
|
||||||
Var x -> return $ ref x
|
Var (V.Raw x) -> return $ obj x
|
||||||
Literal lit -> return $ literal lit
|
Literal lit -> return $ literal lit
|
||||||
|
|
||||||
Range lo hi ->
|
Range lo hi ->
|
||||||
|
@ -85,17 +87,16 @@ expression (L span expr) =
|
||||||
do fields' <- forM fields $ \(f,e) -> do
|
do fields' <- forM fields $ \(f,e) -> do
|
||||||
(,) f <$> expression e
|
(,) f <$> expression e
|
||||||
let fieldMap = List.foldl' combine Map.empty fields'
|
let fieldMap = List.foldl' combine Map.empty fields'
|
||||||
return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
|
return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
|
||||||
where
|
where
|
||||||
combine r (k,v) = Map.insertWith (++) k [v] r
|
combine r (k,v) = Map.insertWith (++) k [v] r
|
||||||
prop = PropId () . var
|
|
||||||
hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
|
hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
|
||||||
Map.toList . Map.filter (not . null) $ Map.map tail fs
|
Map.toList . Map.filter (not . null) $ Map.map tail fs
|
||||||
visible fs = map (first prop) . Map.toList $ Map.map head fs
|
visible fs = map (first prop) . Map.toList $ Map.map head fs
|
||||||
|
|
||||||
Binop op e1 e2 -> binop span op e1 e2
|
Binop op e1 e2 -> binop region op e1 e2
|
||||||
|
|
||||||
Lambda p e@(L s _) ->
|
Lambda p e@(A ann _) ->
|
||||||
do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
|
do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
|
||||||
body' <- expression body
|
body' <- expression body
|
||||||
return $ case length args < 2 || length args > 9 of
|
return $ case length args < 2 || length args > 9 of
|
||||||
|
@ -104,13 +105,14 @@ expression (L span expr) =
|
||||||
where
|
where
|
||||||
depattern (args, body) pattern =
|
depattern (args, body) pattern =
|
||||||
case pattern of
|
case pattern of
|
||||||
PVar x -> return (args ++ [x], body)
|
P.Var x -> return (args ++ [x], body)
|
||||||
_ -> do arg <- Case.newVar
|
_ -> do arg <- Case.newVar
|
||||||
return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
|
return ( args ++ [arg]
|
||||||
|
, A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
|
||||||
|
|
||||||
(patterns, innerBody) = collect [p] e
|
(patterns, innerBody) = collect [p] e
|
||||||
|
|
||||||
collect patterns lexpr@(L _ expr) =
|
collect patterns lexpr@(A _ expr) =
|
||||||
case expr of
|
case expr of
|
||||||
Lambda p e -> collect (p:patterns) e
|
Lambda p e -> collect (p:patterns) e
|
||||||
_ -> (patterns, lexpr)
|
_ -> (patterns, lexpr)
|
||||||
|
@ -127,7 +129,7 @@ expression (L span expr) =
|
||||||
(func, args) = getArgs e1 [e2]
|
(func, args) = getArgs e1 [e2]
|
||||||
getArgs func args =
|
getArgs func args =
|
||||||
case func of
|
case func of
|
||||||
(L _ (App f arg)) -> getArgs f (arg : args)
|
(A _ (App f arg)) -> getArgs f (arg : args)
|
||||||
_ -> (func, args)
|
_ -> (func, args)
|
||||||
|
|
||||||
Let defs e ->
|
Let defs e ->
|
||||||
|
@ -139,9 +141,9 @@ expression (L span expr) =
|
||||||
MultiIf branches ->
|
MultiIf branches ->
|
||||||
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
|
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
|
||||||
return $ case last branches of
|
return $ case last branches of
|
||||||
(L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
|
(A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
|
||||||
(L _ (Literal (Boolean True)), _) -> safeIfs branches'
|
(A _ (Literal (Boolean True)), _) -> safeIfs branches'
|
||||||
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
|
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
|
||||||
where
|
where
|
||||||
safeIfs branches = ifs (init branches) (snd (last branches))
|
safeIfs branches = ifs (init branches) (snd (last branches))
|
||||||
ifs branches finally = foldr iff finally branches
|
ifs branches finally = foldr iff finally branches
|
||||||
|
@ -151,10 +153,12 @@ expression (L span expr) =
|
||||||
do (tempVar,initialMatch) <- Case.toMatch cases
|
do (tempVar,initialMatch) <- Case.toMatch cases
|
||||||
(revisedMatch, stmt) <-
|
(revisedMatch, stmt) <-
|
||||||
case e of
|
case e of
|
||||||
L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
|
A _ (Var (V.Raw x)) ->
|
||||||
_ -> do e' <- expression e
|
return (Case.matchSubst [(tempVar,x)] initialMatch, [])
|
||||||
|
_ ->
|
||||||
|
do e' <- expression e
|
||||||
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
|
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
|
||||||
match' <- match span revisedMatch
|
match' <- match region revisedMatch
|
||||||
return (function [] (stmt ++ match') `call` [])
|
return (function [] (stmt ++ match') `call` [])
|
||||||
|
|
||||||
ExplicitList es ->
|
ExplicitList es ->
|
||||||
|
@ -184,28 +188,28 @@ expression (L span expr) =
|
||||||
[ string name, Port.outgoing tipe, value' ]
|
[ string name, Port.outgoing tipe, value' ]
|
||||||
|
|
||||||
definition :: Def -> State Int [Statement ()]
|
definition :: Def -> State Int [Statement ()]
|
||||||
definition (Definition pattern expr@(L span _) _) = do
|
definition (Definition pattern expr@(A region _) _) = do
|
||||||
expr' <- expression expr
|
expr' <- expression expr
|
||||||
let assign x = varDecl x expr'
|
let assign x = varDecl x expr'
|
||||||
case pattern of
|
case pattern of
|
||||||
PVar x
|
P.Var x
|
||||||
| Help.isOp x ->
|
| Help.isOp x ->
|
||||||
let op = LBracket () (ref "_op") (string x) in
|
let op = LBracket () (ref "_op") (string x) in
|
||||||
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
|
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
return [ VarDeclStmt () [ assign x ] ]
|
return [ VarDeclStmt () [ assign x ] ]
|
||||||
|
|
||||||
PRecord fields ->
|
P.Record fields ->
|
||||||
let setField f = varDecl f (dotSep ["$",f]) in
|
let setField f = varDecl f (dotSep ["$",f]) in
|
||||||
return [ VarDeclStmt () (assign "$" : map setField fields) ]
|
return [ VarDeclStmt () (assign "$" : map setField fields) ]
|
||||||
|
|
||||||
PData name patterns | vars /= Nothing ->
|
P.Data name patterns | vars /= Nothing ->
|
||||||
return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
|
return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
|
||||||
where
|
where
|
||||||
vars = getVars patterns
|
vars = getVars patterns
|
||||||
getVars patterns =
|
getVars patterns =
|
||||||
case patterns of
|
case patterns of
|
||||||
PVar x : rest -> (x:) `fmap` getVars rest
|
P.Var x : rest -> (x:) `fmap` getVars rest
|
||||||
[] -> Just []
|
[] -> Just []
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
@ -216,41 +220,45 @@ definition (Definition pattern expr@(L span _) _) = do
|
||||||
|
|
||||||
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
|
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
|
||||||
if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
|
if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
|
||||||
exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
|
exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
|
||||||
|
|
||||||
_ ->
|
_ ->
|
||||||
do defs' <- concat <$> mapM toDef vars
|
do defs' <- concat <$> mapM toDef vars
|
||||||
return (VarDeclStmt () [assign "$"] : defs')
|
return (VarDeclStmt () [assign "$"] : defs')
|
||||||
where
|
where
|
||||||
vars = Set.toList $ Pattern.boundVars pattern
|
vars = P.boundVarList pattern
|
||||||
mkVar = L span . Var
|
mkVar = A region . rawVar
|
||||||
toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
|
toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
|
||||||
in definition $ Definition (PVar y) expr Nothing
|
in definition $ Definition (P.Var y) expr Nothing
|
||||||
|
|
||||||
match :: SrcSpan -> Case.Match -> State Int [Statement ()]
|
match :: Region -> Case.Match -> State Int [Statement ()]
|
||||||
match span mtch =
|
match region mtch =
|
||||||
case mtch of
|
case mtch of
|
||||||
Case.Match name clauses mtch' ->
|
Case.Match name clauses mtch' ->
|
||||||
do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
|
do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
|
||||||
mtch'' <- match span mtch'
|
mtch'' <- match region mtch'
|
||||||
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
|
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
|
||||||
where
|
where
|
||||||
isLiteral p = case p of
|
isLiteral p = case p of
|
||||||
Case.Clause (Right _) _ _ -> True
|
Case.Clause (Right _) _ _ -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
|
|
||||||
|
access name
|
||||||
|
| any isLiteral clauses = obj name
|
||||||
|
| otherwise = dotSep (split name ++ ["ctor"])
|
||||||
|
|
||||||
format isChars e
|
format isChars e
|
||||||
| or isChars = InfixExpr () OpAdd e (string "")
|
| or isChars = InfixExpr () OpAdd e (string "")
|
||||||
| otherwise = e
|
| otherwise = e
|
||||||
|
|
||||||
Case.Fail ->
|
Case.Fail ->
|
||||||
return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
|
return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
|
||||||
|
|
||||||
Case.Break -> return [BreakStmt () Nothing]
|
Case.Break -> return [BreakStmt () Nothing]
|
||||||
Case.Other e ->
|
Case.Other e ->
|
||||||
do e' <- expression e
|
do e' <- expression e
|
||||||
return [ ret e' ]
|
return [ ret e' ]
|
||||||
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
|
Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
|
||||||
where
|
where
|
||||||
dropEnd acc [] = acc
|
dropEnd acc [] = acc
|
||||||
dropEnd acc (m:ms) =
|
dropEnd acc (m:ms) =
|
||||||
|
@ -258,9 +266,9 @@ match span mtch =
|
||||||
Case.Other _ -> acc ++ [m]
|
Case.Other _ -> acc ++ [m]
|
||||||
_ -> dropEnd (acc ++ [m]) ms
|
_ -> dropEnd (acc ++ [m]) ms
|
||||||
|
|
||||||
clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
|
clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
|
||||||
clause span variable (Case.Clause value vars mtch) =
|
clause region variable (Case.Clause value vars mtch) =
|
||||||
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
|
(,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
|
||||||
where
|
where
|
||||||
vars' = map (\n -> variable ++ "._" ++ show n) [0..]
|
vars' = map (\n -> variable ++ "._" ++ show n) [0..]
|
||||||
(isChar, pattern) =
|
(isChar, pattern) =
|
||||||
|
@ -273,8 +281,8 @@ clause span variable (Case.Clause value vars mtch) =
|
||||||
[] -> name
|
[] -> name
|
||||||
is -> drop (last is + 1) name
|
is -> drop (last is + 1) name
|
||||||
|
|
||||||
flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
|
flattenLets :: [Def] -> Expr -> ([Def], Expr)
|
||||||
flattenLets defs lexpr@(L _ expr) =
|
flattenLets defs lexpr@(A _ expr) =
|
||||||
case expr of
|
case expr of
|
||||||
Let ds body -> flattenLets (defs ++ ds) body
|
Let ds body -> flattenLets (defs ++ ds) body
|
||||||
_ -> (defs, lexpr)
|
_ -> (defs, lexpr)
|
||||||
|
@ -288,7 +296,8 @@ generate unsafeModule =
|
||||||
thisModule = dotSep ("_elm" : names modul ++ ["values"])
|
thisModule = dotSep ("_elm" : names modul ++ ["values"])
|
||||||
programStmts =
|
programStmts =
|
||||||
concat
|
concat
|
||||||
[ setup (Just "_elm") (names modul ++ ["values"])
|
[ [ ExprStmt () $ string "use strict" ]
|
||||||
|
, setup (Just "_elm") (names modul ++ ["values"])
|
||||||
, [ IfSingleStmt () thisModule (ret thisModule) ]
|
, [ IfSingleStmt () thisModule (ret thisModule) ]
|
||||||
, [ internalImports (List.intercalate "." (names modul)) ]
|
, [ internalImports (List.intercalate "." (names modul)) ]
|
||||||
, concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
|
, concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
|
||||||
|
@ -301,7 +310,7 @@ generate unsafeModule =
|
||||||
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
|
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
|
||||||
where
|
where
|
||||||
exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
|
exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
|
||||||
entry x = (PropId () (var x), ref x)
|
entry x = (prop x, ref x)
|
||||||
|
|
||||||
assign path expr =
|
assign path expr =
|
||||||
case path of
|
case path of
|
||||||
|
@ -311,7 +320,7 @@ generate unsafeModule =
|
||||||
|
|
||||||
jsImport modul = setup Nothing path ++ [ include ]
|
jsImport modul = setup Nothing path ++ [ include ]
|
||||||
where
|
where
|
||||||
path = split modul
|
path = Help.splitDots modul
|
||||||
include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
|
include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
|
||||||
|
|
||||||
setup namespace path = map create paths
|
setup namespace path = map create paths
|
||||||
|
@ -321,8 +330,8 @@ generate unsafeModule =
|
||||||
Nothing -> tail . init $ List.inits path
|
Nothing -> tail . init $ List.inits path
|
||||||
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
|
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
|
||||||
|
|
||||||
binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
|
binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
|
||||||
binop span op e1 e2 =
|
binop region op e1 e2 =
|
||||||
case op of
|
case op of
|
||||||
"Basics.." ->
|
"Basics.." ->
|
||||||
do es <- mapM expression (e1 : collect [] e2)
|
do es <- mapM expression (e1 : collect [] e2)
|
||||||
|
@ -335,7 +344,7 @@ binop span op e1 e2 =
|
||||||
do e1' <- expression e1
|
do e1' <- expression e1
|
||||||
e2' <- expression e2
|
e2' <- expression e2
|
||||||
return $ obj "_L.append" `call` [e1', e2']
|
return $ obj "_L.append" `call` [e1', e2']
|
||||||
"::" -> expression (L span (Data "::" [e1,e2]))
|
"::" -> expression (A region (Data "::" [e1,e2]))
|
||||||
_ ->
|
_ ->
|
||||||
do e1' <- expression e1
|
do e1' <- expression e1
|
||||||
e2' <- expression e2
|
e2' <- expression e2
|
||||||
|
@ -345,13 +354,13 @@ binop span op e1 e2 =
|
||||||
where
|
where
|
||||||
collect es e =
|
collect es e =
|
||||||
case e of
|
case e of
|
||||||
L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
|
A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
|
||||||
_ -> es ++ [e]
|
_ -> es ++ [e]
|
||||||
|
|
||||||
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
|
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
|
||||||
| otherwise = dotSep parts
|
| otherwise = dotSep parts
|
||||||
where
|
where
|
||||||
parts = split op
|
parts = Help.splitDots op
|
||||||
operator = last parts
|
operator = last parts
|
||||||
|
|
||||||
opDict = Map.fromList (infixOps ++ specialOps)
|
opDict = Map.fromList (infixOps ++ specialOps)
|
||||||
|
|
|
@ -58,22 +58,26 @@ inc tipe x =
|
||||||
where
|
where
|
||||||
array = DotRef () x (var "map") <| incoming t
|
array = DotRef () x (var "map") <| incoming t
|
||||||
|
|
||||||
Data ctor ts | Help.isTuple ctor -> check x JSArray tuple
|
Data ctor ts
|
||||||
|
| Help.isTuple ctor -> check x JSArray tuple
|
||||||
where
|
where
|
||||||
tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
|
tuple = ObjectLit () $ (prop "ctor", string ctor) : values
|
||||||
values = zipWith convert [0..] ts
|
values = zipWith convert [0..] ts
|
||||||
convert n t = ( PropId () $ var ('_':show n)
|
convert n t = ( prop ('_':show n)
|
||||||
, inc t (BracketRef () x (IntLit () n)))
|
, inc t (BracketRef () x (IntLit () n)))
|
||||||
|
|
||||||
Data _ _ -> error "bad ADT got to port generation code"
|
Data _ _ ->
|
||||||
|
error "bad ADT got to port generation code"
|
||||||
|
|
||||||
Record _ (Just _) -> error "bad record 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
|
Record fields Nothing ->
|
||||||
|
check x (JSObject (map fst fields)) object
|
||||||
where
|
where
|
||||||
object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
|
object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
|
||||||
keys = map convert fields
|
keys = map convert fields
|
||||||
convert (f,t) = (PropId () (var f), inc t (DotRef () x (var f)))
|
convert (f,t) = (prop f, inc t (DotRef () x (var f)))
|
||||||
|
|
||||||
outgoing tipe =
|
outgoing tipe =
|
||||||
case tipe of
|
case tipe of
|
||||||
|
@ -109,19 +113,21 @@ out tipe x =
|
||||||
| ctor == "Maybe.Maybe" ->
|
| ctor == "Maybe.Maybe" ->
|
||||||
CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
|
CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
|
||||||
(NullLit ())
|
(NullLit ())
|
||||||
(DotRef () x (var "_0"))
|
(out t (DotRef () x (var "_0")))
|
||||||
|
|
||||||
| ctor == "_List" ->
|
| ctor == "_List" ->
|
||||||
DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
|
DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
|
||||||
|
|
||||||
Data ctor ts | Help.isTuple ctor ->
|
Data ctor ts
|
||||||
ArrayLit () $ zipWith convert [0..] ts
|
| Help.isTuple ctor ->
|
||||||
where
|
let convert n t = out t $ DotRef () x $ var ('_':show n)
|
||||||
convert n t = out t $ DotRef () x $ var ('_':show n)
|
in ArrayLit () $ zipWith convert [0..] ts
|
||||||
|
|
||||||
Data _ _ -> error "bad ADT got to port generation code"
|
Data _ _ ->
|
||||||
|
error "bad ADT got to port generation code"
|
||||||
|
|
||||||
Record _ (Just _) -> error "bad record got to port generation code"
|
Record _ (Just _) ->
|
||||||
|
error "bad record got to port generation code"
|
||||||
|
|
||||||
Record fields Nothing ->
|
Record fields Nothing ->
|
||||||
ObjectLit () keys
|
ObjectLit () keys
|
||||||
|
|
|
@ -1,68 +0,0 @@
|
||||||
module Generate.Noscript (noscript) where
|
|
||||||
|
|
||||||
import Data.List (isInfixOf)
|
|
||||||
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 :: Extract def => Module def -> String
|
|
||||||
noscript modul = concat (extract modul)
|
|
||||||
|
|
||||||
class Extract a where
|
|
||||||
extract :: a -> [String]
|
|
||||||
|
|
||||||
instance Extract def => Extract (Module def) where
|
|
||||||
extract (Module _ _ _ stmts) =
|
|
||||||
map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
|
|
||||||
|
|
||||||
instance Extract def => Extract (D.Declaration' port def) where
|
|
||||||
extract (D.Definition d) = extract d
|
|
||||||
extract _ = []
|
|
||||||
|
|
||||||
instance Extract Def where
|
|
||||||
extract (Definition _ e _) = extract e
|
|
||||||
|
|
||||||
instance Extract e => Extract (Located e) where
|
|
||||||
extract (L _ e) = extract e
|
|
||||||
|
|
||||||
instance Extract def => Extract (Expr' def) where
|
|
||||||
extract expr =
|
|
||||||
let f = extract in
|
|
||||||
case expr of
|
|
||||||
Literal (Str s) -> [s]
|
|
||||||
Binop op e1 e2 -> case (op, f e1, f e2) of
|
|
||||||
("++", [s1], [s2]) -> [s1 ++ s2]
|
|
||||||
(_ , ss1 , ss2 ) -> ss1 ++ ss2
|
|
||||||
Lambda v e -> f e
|
|
||||||
App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src
|
|
||||||
| "image" `isInfixOf` func -> extractImage src
|
|
||||||
App (L _ (App (L _ (Var func)) src)) txt
|
|
||||||
| "link" `isInfixOf` func -> extractLink src txt
|
|
||||||
App (L _ (Var func)) e
|
|
||||||
| "header" `isInfixOf` func -> tag "h1" e
|
|
||||||
| "bold" `isInfixOf` func -> tag "b" e
|
|
||||||
| "italic" `isInfixOf` func -> tag "i" e
|
|
||||||
| "monospace" `isInfixOf` func -> tag "code" e
|
|
||||||
App e1 e2 -> f e1 ++ f e2
|
|
||||||
Let defs e -> concatMap extract defs ++ f e
|
|
||||||
Var _ -> []
|
|
||||||
Case e cases -> concatMap (f . snd) cases
|
|
||||||
Data _ es -> concatMap f es
|
|
||||||
MultiIf es -> concatMap (f . snd) es
|
|
||||||
Markdown _ md _ -> [ MD.toHtml md ]
|
|
||||||
_ -> []
|
|
||||||
|
|
||||||
extractLink src txt =
|
|
||||||
case (extract src, extract txt) of
|
|
||||||
([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
|
|
||||||
( ss1, ss2) -> ss1 ++ ss2
|
|
||||||
|
|
||||||
extractImage src =
|
|
||||||
case extract src of
|
|
||||||
[s] -> ["<img src=\"" ++ s ++ "\">"]
|
|
||||||
ss -> ss
|
|
||||||
|
|
||||||
tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)
|
|
|
@ -3,11 +3,11 @@ module Metadata.Prelude (interfaces, add) where
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
import qualified Paths_Elm as Path
|
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
import SourceSyntax.Module
|
import SourceSyntax.Module
|
||||||
import qualified Build.Interface as Interface
|
import qualified Build.Interface as Interface
|
||||||
|
import Build.Utils (getDataFile)
|
||||||
|
|
||||||
add :: Bool -> Module def -> Module def
|
add :: Bool -> Module def -> Module def
|
||||||
add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
|
add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls
|
||||||
|
@ -20,18 +20,18 @@ add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) d
|
||||||
Just _ -> []
|
Just _ -> []
|
||||||
|
|
||||||
prelude :: [(String, ImportMethod)]
|
prelude :: [(String, ImportMethod)]
|
||||||
prelude = string : text ++ map (\n -> (n, Hiding [])) modules
|
prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules
|
||||||
where
|
where
|
||||||
text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
|
text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
|
||||||
string = ("String", As "String")
|
string = map ((,) "String") [ As "String", Importing ["show"] ]
|
||||||
modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
|
modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"
|
||||||
, "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]
|
, "Graphics.Element", "Graphics.Collage", "Native.Ports" ]
|
||||||
|
|
||||||
interfaces :: Bool -> IO Interfaces
|
interfaces :: Bool -> IO Interfaces
|
||||||
interfaces noPrelude =
|
interfaces noPrelude =
|
||||||
if noPrelude
|
if noPrelude
|
||||||
then return $ Map.empty
|
then return Map.empty
|
||||||
else safeReadDocs =<< Path.getDataFileName "interfaces.data"
|
else safeReadDocs =<< getDataFile "interfaces.data"
|
||||||
|
|
||||||
safeReadDocs :: FilePath -> IO Interfaces
|
safeReadDocs :: FilePath -> IO Interfaces
|
||||||
safeReadDocs name =
|
safeReadDocs name =
|
||||||
|
|
|
@ -1,10 +1,11 @@
|
||||||
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Parse.Binop (binops, OpTable) where
|
module Parse.Binop (binops, OpTable) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Data.List (intercalate)
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
import SourceSyntax.Location (merge)
|
import SourceSyntax.Annotation (merge)
|
||||||
import qualified SourceSyntax.Expression as E
|
import qualified SourceSyntax.Expression as E
|
||||||
import SourceSyntax.Declaration (Assoc(..))
|
import SourceSyntax.Declaration (Assoc(..))
|
||||||
import Text.Parsec
|
import Text.Parsec
|
||||||
|
@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
|
||||||
opAssoc :: OpTable -> String -> Assoc
|
opAssoc :: OpTable -> String -> Assoc
|
||||||
opAssoc table op = snd $ Map.findWithDefault (9,L) op table
|
opAssoc table op = snd $ Map.findWithDefault (9,L) op table
|
||||||
|
|
||||||
hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
|
hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool
|
||||||
hasLevel table n (op,_) = opLevel table op == n
|
hasLevel table n (op,_) = opLevel table op == n
|
||||||
|
|
||||||
binops :: IParser E.LParseExpr
|
binops :: IParser E.ParseExpr
|
||||||
-> IParser E.LParseExpr
|
-> IParser E.ParseExpr
|
||||||
-> IParser String
|
-> IParser String
|
||||||
-> IParser E.LParseExpr
|
-> IParser E.ParseExpr
|
||||||
binops term last anyOp =
|
binops term last anyOp =
|
||||||
do e <- term
|
do e <- term
|
||||||
table <- getState
|
table <- getState
|
||||||
|
@ -38,9 +39,9 @@ binops term last anyOp =
|
||||||
|
|
||||||
split :: OpTable
|
split :: OpTable
|
||||||
-> Int
|
-> Int
|
||||||
-> E.LParseExpr
|
-> E.ParseExpr
|
||||||
-> [(String, E.LParseExpr)]
|
-> [(String, E.ParseExpr)]
|
||||||
-> IParser E.LParseExpr
|
-> IParser E.ParseExpr
|
||||||
split _ _ e [] = return e
|
split _ _ e [] = return e
|
||||||
split table n e eops = do
|
split table n e eops = do
|
||||||
assoc <- getAssoc table n eops
|
assoc <- getAssoc table n eops
|
||||||
|
@ -49,26 +50,26 @@ split table n e eops = do
|
||||||
case assoc of R -> joinR es ops
|
case assoc of R -> joinR es ops
|
||||||
_ -> joinL es ops
|
_ -> joinL es ops
|
||||||
|
|
||||||
splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
|
splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
|
||||||
-> [IParser E.LParseExpr]
|
-> [IParser E.ParseExpr]
|
||||||
splitLevel table n e eops =
|
splitLevel table n e eops =
|
||||||
case break (hasLevel table n) eops of
|
case break (hasLevel table n) eops of
|
||||||
(lops, (op,e'):rops) ->
|
(lops, (_op,e'):rops) ->
|
||||||
split table (n+1) e lops : splitLevel table n e' rops
|
split table (n+1) e lops : splitLevel table n e' rops
|
||||||
(lops, []) -> [ split table (n+1) e lops ]
|
(lops, []) -> [ split table (n+1) e lops ]
|
||||||
|
|
||||||
joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
|
joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
|
||||||
joinL [e] [] = return e
|
joinL [e] [] = return e
|
||||||
joinL (a:b:es) (op:ops) = joinL (merge a b (E.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."
|
joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
|
||||||
|
|
||||||
joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
|
joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
|
||||||
joinR [e] [] = return e
|
joinR [e] [] = return e
|
||||||
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
|
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
|
||||||
return (merge a e (E.Binop op a e))
|
return (merge a e (E.Binop op a e))
|
||||||
joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
|
joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
|
||||||
|
|
||||||
getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc
|
getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc
|
||||||
getAssoc table n eops
|
getAssoc table n eops
|
||||||
| all (==L) assocs = return L
|
| all (==L) assocs = return L
|
||||||
| all (==R) assocs = return R
|
| all (==R) assocs = return R
|
||||||
|
@ -79,5 +80,5 @@ getAssoc table n eops
|
||||||
assocs = map (opAssoc table . fst) levelOps
|
assocs = map (opAssoc table . fst) levelOps
|
||||||
msg problem =
|
msg problem =
|
||||||
concat [ "Conflicting " ++ problem ++ " for binary operators ("
|
concat [ "Conflicting " ++ problem ++ " for binary operators ("
|
||||||
, intercalate ", " (map fst eops), "). "
|
, List.intercalate ", " (map fst eops), "). "
|
||||||
, "Consider adding parentheses to disambiguate." ]
|
, "Consider adding parentheses to disambiguate." ]
|
||||||
|
|
|
@ -5,45 +5,45 @@ import Data.List (foldl')
|
||||||
import Text.Parsec hiding (newline,spaces)
|
import Text.Parsec hiding (newline,spaces)
|
||||||
import Text.Parsec.Indent
|
import Text.Parsec.Indent
|
||||||
|
|
||||||
|
import Parse.Binop
|
||||||
import Parse.Helpers
|
import Parse.Helpers
|
||||||
|
import Parse.Literal
|
||||||
import qualified Parse.Pattern as Pattern
|
import qualified Parse.Pattern as Pattern
|
||||||
import qualified Parse.Type as Type
|
import qualified Parse.Type as Type
|
||||||
import Parse.Binop
|
|
||||||
import Parse.Literal
|
|
||||||
|
|
||||||
import SourceSyntax.Location as Location
|
import SourceSyntax.Annotation as Annotation
|
||||||
import SourceSyntax.Pattern hiding (tuple,list)
|
import qualified SourceSyntax.Pattern as P
|
||||||
import qualified SourceSyntax.Literal as Literal
|
import qualified SourceSyntax.Literal as L
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
|
|
||||||
|
|
||||||
-------- Basic Terms --------
|
-------- Basic Terms --------
|
||||||
|
|
||||||
varTerm :: IParser ParseExpr
|
varTerm :: IParser ParseExpr'
|
||||||
varTerm = toVar <$> var <?> "variable"
|
varTerm = toVar <$> var <?> "variable"
|
||||||
|
|
||||||
toVar :: String -> ParseExpr
|
toVar :: String -> ParseExpr'
|
||||||
toVar v = case v of "True" -> Literal (Literal.Boolean True)
|
toVar v = case v of "True" -> Literal (L.Boolean True)
|
||||||
"False" -> Literal (Literal.Boolean False)
|
"False" -> Literal (L.Boolean False)
|
||||||
_ -> Var v
|
_ -> rawVar v
|
||||||
|
|
||||||
accessor :: IParser ParseExpr
|
accessor :: IParser ParseExpr'
|
||||||
accessor = do
|
accessor = do
|
||||||
(start, lbl, end) <- located (try (string "." >> rLabel))
|
(start, lbl, end) <- located (try (string "." >> rLabel))
|
||||||
let loc e = Location.at start end e
|
let loc e = Annotation.at start end e
|
||||||
return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
|
return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
|
||||||
|
|
||||||
negative :: IParser ParseExpr
|
negative :: IParser ParseExpr'
|
||||||
negative = do
|
negative = do
|
||||||
(start, nTerm, end) <-
|
(start, nTerm, end) <-
|
||||||
located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
|
located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
|
||||||
let loc e = Location.at start end e
|
let loc e = Annotation.at start end e
|
||||||
return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
|
return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
|
||||||
|
|
||||||
|
|
||||||
-------- Complex Terms --------
|
-------- Complex Terms --------
|
||||||
|
|
||||||
listTerm :: IParser ParseExpr
|
listTerm :: IParser ParseExpr'
|
||||||
listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
|
listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
|
||||||
where
|
where
|
||||||
range = do
|
range = do
|
||||||
|
@ -60,38 +60,39 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
|
||||||
span uid index =
|
span uid index =
|
||||||
"<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
|
"<span id=\"md-" ++ uid ++ "-" ++ show index ++ "\">{{ markdown interpolation is in the pipeline, but still needs more testing }}</span>"
|
||||||
|
|
||||||
interpolation uid md exprs = do
|
interpolation uid exprs = do
|
||||||
try (string "{{")
|
try (string "{{")
|
||||||
e <- padded expr
|
e <- padded expr
|
||||||
string "}}"
|
string "}}"
|
||||||
return (md ++ span uid (length exprs), exprs ++ [e])
|
return (span uid (length exprs), exprs ++ [e])
|
||||||
|
|
||||||
parensTerm :: IParser LParseExpr
|
parensTerm :: IParser ParseExpr
|
||||||
parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
|
parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
|
||||||
where
|
where
|
||||||
opFn = do
|
opFn = do
|
||||||
(start, op, end) <- located anyOp
|
(start, op, end) <- located anyOp
|
||||||
let loc = Location.at start end
|
let loc = Annotation.at start end
|
||||||
return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
|
return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
|
||||||
Binop op (loc $ Var "x") (loc $ Var "y")
|
Binop op (loc $ rawVar "x") (loc $ rawVar "y")
|
||||||
|
|
||||||
tupleFn = do
|
tupleFn = do
|
||||||
let comma = char ',' <?> "comma ','"
|
let comma = char ',' <?> "comma ','"
|
||||||
(start, commas, end) <- located (comma >> many (whitespace >> comma))
|
(start, commas, end) <- located (comma >> many (whitespace >> comma))
|
||||||
let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
|
let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
|
||||||
loc = Location.at start end
|
loc = Annotation.at start end
|
||||||
return $ foldr (\x e -> loc $ Lambda x e)
|
return $ foldr (\x e -> loc $ Lambda x e)
|
||||||
(loc . tuple $ map (loc . Var) vars) (map PVar vars)
|
(loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
|
||||||
|
|
||||||
parened = do
|
parened = do
|
||||||
(start, es, end) <- located (commaSep expr)
|
(start, es, end) <- located (commaSep expr)
|
||||||
return $ case es of
|
return $ case es of
|
||||||
[e] -> e
|
[e] -> e
|
||||||
_ -> Location.at start end (tuple es)
|
_ -> Annotation.at start end (tuple es)
|
||||||
|
|
||||||
recordTerm :: IParser LParseExpr
|
recordTerm :: IParser ParseExpr
|
||||||
recordTerm = brackets $ choice [ misc, addLocation record ]
|
recordTerm = brackets $ choice [ misc, addLocation record ]
|
||||||
where field = do
|
where
|
||||||
|
field = do
|
||||||
label <- rLabel
|
label <- rLabel
|
||||||
patterns <- spacePrefix Pattern.term
|
patterns <- spacePrefix Pattern.term
|
||||||
padded equals
|
padded equals
|
||||||
|
@ -111,41 +112,41 @@ recordTerm = brackets $ choice [ misc, addLocation record ]
|
||||||
string "|" >> whitespace
|
string "|" >> whitespace
|
||||||
Insert r <$> rLabel <*> (padded equals >> expr)
|
Insert r <$> rLabel <*> (padded equals >> expr)
|
||||||
|
|
||||||
modify r = addLocation
|
modify r =
|
||||||
(string "|" >> whitespace >> Modify r <$> commaSep1 change)
|
addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
|
||||||
|
|
||||||
misc = try $ do
|
misc = try $ do
|
||||||
record <- addLocation (Var <$> rLabel)
|
record <- addLocation (rawVar <$> rLabel)
|
||||||
opt <- padded (optionMaybe (remove record))
|
opt <- padded (optionMaybe (remove record))
|
||||||
case opt of
|
case opt of
|
||||||
Just e -> try (insert e) <|> return e
|
Just e -> try (insert e) <|> return e
|
||||||
Nothing -> try (insert record) <|> try (modify record)
|
Nothing -> try (insert record) <|> try (modify record)
|
||||||
|
|
||||||
|
|
||||||
term :: IParser LParseExpr
|
term :: IParser ParseExpr
|
||||||
term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
|
term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
|
||||||
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
|
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
|
||||||
<?> "basic term (4, x, 'c', etc.)"
|
<?> "basic term (4, x, 'c', etc.)"
|
||||||
|
|
||||||
-------- Applications --------
|
-------- Applications --------
|
||||||
|
|
||||||
appExpr :: IParser LParseExpr
|
appExpr :: IParser ParseExpr
|
||||||
appExpr = do
|
appExpr = do
|
||||||
t <- term
|
t <- term
|
||||||
ts <- constrainedSpacePrefix term $ \str ->
|
ts <- constrainedSpacePrefix term $ \str ->
|
||||||
if null str then notFollowedBy (char '-') else return ()
|
if null str then notFollowedBy (char '-') else return ()
|
||||||
return $ case ts of
|
return $ case ts of
|
||||||
[] -> t
|
[] -> t
|
||||||
_ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
|
_ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
|
||||||
|
|
||||||
-------- Normal Expressions --------
|
-------- Normal Expressions --------
|
||||||
|
|
||||||
binaryExpr :: IParser LParseExpr
|
binaryExpr :: IParser ParseExpr
|
||||||
binaryExpr = binops appExpr lastExpr anyOp
|
binaryExpr = binops appExpr lastExpr anyOp
|
||||||
where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
|
where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
|
||||||
<|> lambdaExpr
|
<|> lambdaExpr
|
||||||
|
|
||||||
ifExpr :: IParser ParseExpr
|
ifExpr :: IParser ParseExpr'
|
||||||
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
||||||
where
|
where
|
||||||
normal = do
|
normal = do
|
||||||
|
@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
||||||
whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
|
whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
|
||||||
elseBranch <- expr
|
elseBranch <- expr
|
||||||
return $ MultiIf [(bool, thenBranch),
|
return $ MultiIf [(bool, thenBranch),
|
||||||
(Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
|
(Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
|
||||||
multiIf = MultiIf <$> spaceSep1 iff
|
multiIf = MultiIf <$> spaceSep1 iff
|
||||||
where iff = do string "|" ; whitespace
|
where iff = do string "|" ; whitespace
|
||||||
b <- expr ; padded arrow
|
b <- expr ; padded arrow
|
||||||
(,) b <$> expr
|
(,) b <$> expr
|
||||||
|
|
||||||
lambdaExpr :: IParser LParseExpr
|
lambdaExpr :: IParser ParseExpr
|
||||||
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
||||||
whitespace
|
whitespace
|
||||||
args <- spaceSep1 Pattern.term
|
args <- spaceSep1 Pattern.term
|
||||||
|
@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
||||||
defSet :: IParser [ParseDef]
|
defSet :: IParser [ParseDef]
|
||||||
defSet = block (do d <- def ; whitespace ; return d)
|
defSet = block (do d <- def ; whitespace ; return d)
|
||||||
|
|
||||||
letExpr :: IParser ParseExpr
|
letExpr :: IParser ParseExpr'
|
||||||
letExpr = do
|
letExpr = do
|
||||||
reserved "let" ; whitespace
|
reserved "let" ; whitespace
|
||||||
defs <- defSet
|
defs <- defSet
|
||||||
padded (reserved "in")
|
padded (reserved "in")
|
||||||
Let defs <$> expr
|
Let defs <$> expr
|
||||||
|
|
||||||
caseExpr :: IParser ParseExpr
|
caseExpr :: IParser ParseExpr'
|
||||||
caseExpr = do
|
caseExpr = do
|
||||||
reserved "case"; e <- padded expr; reserved "of"; whitespace
|
reserved "case"; e <- padded expr; reserved "of"; whitespace
|
||||||
Case e <$> (with <|> without)
|
Case e <$> (with <|> without)
|
||||||
|
@ -189,35 +190,35 @@ caseExpr = do
|
||||||
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
|
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
|
||||||
without = block (do c <- case_ ; whitespace ; return c)
|
without = block (do c <- case_ ; whitespace ; return c)
|
||||||
|
|
||||||
expr :: IParser LParseExpr
|
expr :: IParser ParseExpr
|
||||||
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
|
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
|
||||||
<|> lambdaExpr
|
<|> lambdaExpr
|
||||||
<|> binaryExpr
|
<|> binaryExpr
|
||||||
<?> "an expression"
|
<?> "an expression"
|
||||||
|
|
||||||
defStart :: IParser [Pattern]
|
defStart :: IParser [P.Pattern]
|
||||||
defStart =
|
defStart =
|
||||||
choice [ do p1 <- try Pattern.term
|
choice [ do p1 <- try Pattern.term
|
||||||
infics p1 <|> func p1
|
infics p1 <|> func p1
|
||||||
, func =<< (PVar <$> parens symOp)
|
, func =<< (P.Var <$> parens symOp)
|
||||||
, (:[]) <$> Pattern.expr
|
, (:[]) <$> Pattern.expr
|
||||||
] <?> "the definition of a variable (x = ...)"
|
] <?> "the definition of a variable (x = ...)"
|
||||||
where
|
where
|
||||||
func pattern =
|
func pattern =
|
||||||
case pattern of
|
case pattern of
|
||||||
PVar _ -> (pattern:) <$> spacePrefix Pattern.term
|
P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
|
||||||
_ -> do try (lookAhead (whitespace >> string "="))
|
_ -> do try (lookAhead (whitespace >> string "="))
|
||||||
return [pattern]
|
return [pattern]
|
||||||
|
|
||||||
infics p1 = do
|
infics p1 = do
|
||||||
o:p <- try (whitespace >> anyOp)
|
o:p <- try (whitespace >> anyOp)
|
||||||
p2 <- (whitespace >> Pattern.term)
|
p2 <- (whitespace >> Pattern.term)
|
||||||
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
|
return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
|
||||||
else [ PVar (o:p), p1, p2 ]
|
else [ P.Var (o:p), p1, p2 ]
|
||||||
|
|
||||||
makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
|
makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
|
||||||
makeFunction args body@(L s _) =
|
makeFunction args body@(A ann _) =
|
||||||
foldr (\arg body' -> L s $ Lambda arg body') body args
|
foldr (\arg body' -> A ann $ Lambda arg body') body args
|
||||||
|
|
||||||
definition :: IParser ParseDef
|
definition :: IParser ParseDef
|
||||||
definition = withPos $ do
|
definition = withPos $ do
|
||||||
|
|
|
@ -12,11 +12,12 @@ import Text.Parsec hiding (newline,spaces,State)
|
||||||
import Text.Parsec.Indent
|
import Text.Parsec.Indent
|
||||||
import qualified Text.Parsec.Token as T
|
import qualified Text.Parsec.Token as T
|
||||||
|
|
||||||
import SourceSyntax.Helpers as Help
|
import SourceSyntax.Annotation as Annotation
|
||||||
import SourceSyntax.Location as Location
|
|
||||||
import SourceSyntax.Expression
|
|
||||||
import SourceSyntax.PrettyPrint
|
|
||||||
import SourceSyntax.Declaration (Assoc)
|
import SourceSyntax.Declaration (Assoc)
|
||||||
|
import SourceSyntax.Expression
|
||||||
|
import SourceSyntax.Helpers as Help
|
||||||
|
import SourceSyntax.PrettyPrint
|
||||||
|
import SourceSyntax.Variable as Variable
|
||||||
|
|
||||||
reserveds = [ "if", "then", "else"
|
reserveds = [ "if", "then", "else"
|
||||||
, "case", "of"
|
, "case", "of"
|
||||||
|
@ -168,7 +169,8 @@ betwixt a b c = do char a ; out <- c
|
||||||
char b <?> "closing '" ++ [b] ++ "'" ; return out
|
char b <?> "closing '" ++ [b] ++ "'" ; return out
|
||||||
|
|
||||||
surround a z name p = do
|
surround a z name p = do
|
||||||
char a ; v <- padded p
|
char a
|
||||||
|
v <- padded p
|
||||||
char z <?> unwords ["closing", name, show z]
|
char z <?> unwords ["closing", name, show z]
|
||||||
return v
|
return v
|
||||||
|
|
||||||
|
@ -181,10 +183,10 @@ parens = surround '(' ')' "paren"
|
||||||
brackets :: IParser a -> IParser a
|
brackets :: IParser a -> IParser a
|
||||||
brackets = surround '{' '}' "bracket"
|
brackets = surround '{' '}' "bracket"
|
||||||
|
|
||||||
addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
|
addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
|
||||||
addLocation expr = do
|
addLocation expr = do
|
||||||
(start, e, end) <- located expr
|
(start, e, end) <- located expr
|
||||||
return (Location.at start end e)
|
return (Annotation.at start end e)
|
||||||
|
|
||||||
located :: IParser a -> IParser (SourcePos, a, SourcePos)
|
located :: IParser a -> IParser (SourcePos, a, SourcePos)
|
||||||
located p = do
|
located p = do
|
||||||
|
@ -193,10 +195,10 @@ located p = do
|
||||||
end <- getPosition
|
end <- getPosition
|
||||||
return (start, e, end)
|
return (start, e, end)
|
||||||
|
|
||||||
accessible :: IParser LParseExpr -> IParser LParseExpr
|
accessible :: IParser ParseExpr -> IParser ParseExpr
|
||||||
accessible expr = do
|
accessible expr = do
|
||||||
start <- getPosition
|
start <- getPosition
|
||||||
ce@(L _ e) <- expr
|
ce@(A _ e) <- expr
|
||||||
let rest f = do
|
let rest f = do
|
||||||
let dot = char '.' >> notFollowedBy (char '.')
|
let dot = char '.' >> notFollowedBy (char '.')
|
||||||
access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
|
access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
|
||||||
|
@ -205,8 +207,10 @@ accessible expr = do
|
||||||
Just _ -> accessible $ do
|
Just _ -> accessible $ do
|
||||||
v <- var <?> "field access (e.g. List.map)"
|
v <- var <?> "field access (e.g. List.map)"
|
||||||
end <- getPosition
|
end <- getPosition
|
||||||
return (Location.at start end (f v))
|
return (Annotation.at start end (f v))
|
||||||
case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
|
case e of
|
||||||
|
Var (Variable.Raw (c:cs))
|
||||||
|
| isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
|
||||||
| otherwise -> rest (Access ce)
|
| otherwise -> rest (Access ce)
|
||||||
_ -> rest (Access ce)
|
_ -> rest (Access ce)
|
||||||
|
|
||||||
|
@ -268,7 +272,7 @@ ignoreUntil end = go
|
||||||
ignore p = const () <$> p
|
ignore p = const () <$> p
|
||||||
filler = choice [ try (ignore chr) <|> ignore str
|
filler = choice [ try (ignore chr) <|> ignore str
|
||||||
, ignore multiComment
|
, ignore multiComment
|
||||||
, ignore (markdown (\_ _ -> mzero))
|
, ignore (markdown (\_ -> mzero))
|
||||||
, ignore anyChar
|
, ignore anyChar
|
||||||
]
|
]
|
||||||
go = choice [ Just <$> end
|
go = choice [ Just <$> end
|
||||||
|
@ -301,15 +305,15 @@ anyUntilPos pos = go
|
||||||
True -> return []
|
True -> return []
|
||||||
False -> (:) <$> anyChar <*> go
|
False -> (:) <$> anyChar <*> go
|
||||||
|
|
||||||
markdown :: (String -> [a] -> IParser (String, [a])) -> IParser (String, [a])
|
markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])
|
||||||
markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
|
markdown interpolation = try (string "[markdown|") >> closeMarkdown (++ "") []
|
||||||
where
|
where
|
||||||
closeMarkdown md stuff =
|
closeMarkdown md stuff =
|
||||||
choice [ do try (string "|]")
|
choice [ do try (string "|]")
|
||||||
return (md, stuff)
|
return (md "", stuff)
|
||||||
, uncurry closeMarkdown =<< interpolation md stuff
|
, (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff
|
||||||
, do c <- anyChar
|
, do c <- anyChar
|
||||||
closeMarkdown (md ++ [c]) stuff
|
closeMarkdown (md . ([c]++)) stuff
|
||||||
]
|
]
|
||||||
|
|
||||||
--str :: IParser String
|
--str :: IParser String
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Parse.Literal (literal) where
|
module Parse.Literal (literal) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
|
@ -7,16 +7,34 @@ import Parse.Helpers
|
||||||
import SourceSyntax.Literal
|
import SourceSyntax.Literal
|
||||||
|
|
||||||
literal :: IParser Literal
|
literal :: IParser Literal
|
||||||
literal = num <|> (Str <$> str) <|> (Chr <$> chr)
|
literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"
|
||||||
|
|
||||||
num :: IParser Literal
|
num :: IParser Literal
|
||||||
num = fmap toLit (preNum <?> "number")
|
num = toLit <$> (number <?> "number")
|
||||||
where toLit n | '.' `elem` n = FloatNum (read n)
|
where
|
||||||
|
toLit n
|
||||||
|
| any (`elem` ".eE") n = FloatNum (read n)
|
||||||
| otherwise = IntNum (read n)
|
| otherwise = IntNum (read n)
|
||||||
preNum = concat <$> sequence [ option "" minus, many1 digit, option "" postNum ]
|
|
||||||
postNum = do try $ lookAhead (string "." >> digit)
|
number = concat <$> sequence
|
||||||
string "."
|
[ option "" minus
|
||||||
('.':) <$> many1 digit
|
, many1 digit
|
||||||
minus = try $ do string "-"
|
, option "" decimals
|
||||||
|
, option "" exponent ]
|
||||||
|
|
||||||
|
minus = try $ do
|
||||||
|
string "-"
|
||||||
lookAhead digit
|
lookAhead digit
|
||||||
return "-"
|
return "-"
|
||||||
|
|
||||||
|
decimals = do
|
||||||
|
try $ lookAhead (string "." >> digit)
|
||||||
|
string "."
|
||||||
|
n <- many1 digit
|
||||||
|
return ('.' : n)
|
||||||
|
|
||||||
|
exponent = do
|
||||||
|
string "e" <|> string "E"
|
||||||
|
op <- option "" (string "+" <|> string "-")
|
||||||
|
n <- many1 digit
|
||||||
|
return ('e' : op ++ n)
|
||||||
|
|
|
@ -8,7 +8,7 @@ import Parse.Helpers
|
||||||
import SourceSyntax.Module (ImportMethod(..), Imports)
|
import SourceSyntax.Module (ImportMethod(..), Imports)
|
||||||
|
|
||||||
varList :: IParser [String]
|
varList :: IParser [String]
|
||||||
varList = parens $ commaSep1 (var <|> parens symOp)
|
varList = commaSep1 (var <|> parens symOp)
|
||||||
|
|
||||||
getModuleName :: String -> Maybe String
|
getModuleName :: String -> Maybe String
|
||||||
getModuleName source =
|
getModuleName source =
|
||||||
|
@ -27,7 +27,7 @@ moduleDef = do
|
||||||
whitespace
|
whitespace
|
||||||
names <- dotSep1 capVar <?> "name of module"
|
names <- dotSep1 capVar <?> "name of module"
|
||||||
whitespace
|
whitespace
|
||||||
exports <- option [] varList
|
exports <- option [] (parens varList)
|
||||||
whitespace <?> "reserved word 'where'"
|
whitespace <?> "reserved word 'where'"
|
||||||
reserved "where"
|
reserved "where"
|
||||||
return (names, exports)
|
return (names, exports)
|
||||||
|
@ -38,17 +38,22 @@ imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
|
||||||
import' :: IParser (String, ImportMethod)
|
import' :: IParser (String, ImportMethod)
|
||||||
import' =
|
import' =
|
||||||
do reserved "import"
|
do reserved "import"
|
||||||
whitespace
|
|
||||||
open <- optionMaybe (reserved "open")
|
|
||||||
whitespace
|
whitespace
|
||||||
name <- intercalate "." <$> dotSep1 capVar
|
name <- intercalate "." <$> dotSep1 capVar
|
||||||
case open of
|
(,) name <$> option (As name) method
|
||||||
Just _ -> return (name, Hiding [])
|
|
||||||
Nothing -> let how = try (whitespace >> (as' <|> importing'))
|
|
||||||
in (,) name <$> option (As name) how
|
|
||||||
where
|
where
|
||||||
|
method :: IParser ImportMethod
|
||||||
|
method = try $ do whitespace
|
||||||
|
as' <|> importing'
|
||||||
|
|
||||||
as' :: IParser ImportMethod
|
as' :: IParser ImportMethod
|
||||||
as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
|
as' = do
|
||||||
|
reserved "as"
|
||||||
|
whitespace
|
||||||
|
As <$> capVar <?> "alias for module"
|
||||||
|
|
||||||
importing' :: IParser ImportMethod
|
importing' :: IParser ImportMethod
|
||||||
importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
|
importing' =
|
||||||
|
parens (choice [ const (Hiding []) <$> string ".."
|
||||||
|
, Importing <$> varList
|
||||||
|
] <?> "listing of imported values (x,y,z)")
|
||||||
|
|
|
@ -3,57 +3,59 @@ module Parse.Pattern (term, expr) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Data.Char (isUpper)
|
import Data.Char (isUpper)
|
||||||
import Data.List (intercalate)
|
import qualified Data.List as List
|
||||||
import Text.Parsec hiding (newline,spaces,State)
|
import Text.Parsec hiding (newline,spaces,State)
|
||||||
|
|
||||||
import Parse.Helpers
|
import Parse.Helpers
|
||||||
import Parse.Literal
|
import Parse.Literal
|
||||||
import SourceSyntax.Literal
|
import SourceSyntax.Literal
|
||||||
import SourceSyntax.Pattern hiding (tuple, list)
|
import qualified SourceSyntax.Pattern as P
|
||||||
import qualified SourceSyntax.Pattern as Pattern
|
|
||||||
|
|
||||||
basic :: IParser Pattern
|
basic :: IParser P.Pattern
|
||||||
basic = choice
|
basic = choice
|
||||||
[ char '_' >> return PAnything
|
[ char '_' >> return P.Anything
|
||||||
, do v <- var
|
, do v <- var
|
||||||
return $ case v of
|
return $ case v of
|
||||||
"True" -> PLiteral (Boolean True)
|
"True" -> P.Literal (Boolean True)
|
||||||
"False" -> PLiteral (Boolean False)
|
"False" -> P.Literal (Boolean False)
|
||||||
c:_ | isUpper c -> PData v []
|
c:_ | isUpper c -> P.Data v []
|
||||||
_ -> PVar v
|
_ -> P.Var v
|
||||||
, PLiteral <$> literal
|
, P.Literal <$> literal
|
||||||
]
|
]
|
||||||
|
|
||||||
asPattern :: Pattern -> IParser Pattern
|
asPattern :: P.Pattern -> IParser P.Pattern
|
||||||
asPattern pattern = do
|
asPattern pattern = do
|
||||||
var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
|
var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
|
||||||
return $ case var of
|
return $ case var of
|
||||||
Just v -> PAlias v pattern
|
Just v -> P.Alias v pattern
|
||||||
Nothing -> pattern
|
Nothing -> pattern
|
||||||
|
|
||||||
record :: IParser Pattern
|
record :: IParser P.Pattern
|
||||||
record = PRecord <$> brackets (commaSep1 lowVar)
|
record = P.Record <$> brackets (commaSep1 lowVar)
|
||||||
|
|
||||||
tuple :: IParser Pattern
|
tuple :: IParser P.Pattern
|
||||||
tuple = do ps <- parens (commaSep expr)
|
tuple = do
|
||||||
return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
|
ps <- parens (commaSep expr)
|
||||||
|
return $ case ps of
|
||||||
|
[p] -> p
|
||||||
|
_ -> P.tuple ps
|
||||||
|
|
||||||
list :: IParser Pattern
|
list :: IParser P.Pattern
|
||||||
list = Pattern.list <$> braces (commaSep expr)
|
list = P.list <$> braces (commaSep expr)
|
||||||
|
|
||||||
term :: IParser Pattern
|
term :: IParser P.Pattern
|
||||||
term =
|
term =
|
||||||
(choice [ record, tuple, list, basic ]) <?> "pattern"
|
(choice [ record, tuple, list, basic ]) <?> "pattern"
|
||||||
|
|
||||||
patternConstructor :: IParser Pattern
|
patternConstructor :: IParser P.Pattern
|
||||||
patternConstructor = do
|
patternConstructor = do
|
||||||
v <- intercalate "." <$> dotSep1 capVar
|
v <- List.intercalate "." <$> dotSep1 capVar
|
||||||
case v of
|
case v of
|
||||||
"True" -> return $ PLiteral (Boolean True)
|
"True" -> return $ P.Literal (Boolean True)
|
||||||
"False" -> return $ PLiteral (Boolean False)
|
"False" -> return $ P.Literal (Boolean False)
|
||||||
_ -> PData v <$> spacePrefix term
|
_ -> P.Data v <$> spacePrefix term
|
||||||
|
|
||||||
expr :: IParser Pattern
|
expr :: IParser P.Pattern
|
||||||
expr = do
|
expr = do
|
||||||
patterns <- consSep1 (patternConstructor <|> term)
|
patterns <- consSep1 (patternConstructor <|> term)
|
||||||
asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
|
asPattern (foldr1 P.cons patterns) <?> "pattern"
|
||||||
|
|
74
compiler/SourceSyntax/Annotation.hs
Normal file
74
compiler/SourceSyntax/Annotation.hs
Normal file
|
@ -0,0 +1,74 @@
|
||||||
|
{-# OPTIONS_GHC -W #-}
|
||||||
|
module SourceSyntax.Annotation where
|
||||||
|
|
||||||
|
import qualified Text.Parsec.Pos as Parsec
|
||||||
|
import qualified Text.PrettyPrint as P
|
||||||
|
import SourceSyntax.PrettyPrint
|
||||||
|
|
||||||
|
data Annotated annotation expr = A annotation expr
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data Region
|
||||||
|
= Span Position Position P.Doc
|
||||||
|
| None P.Doc
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
data Position = Position
|
||||||
|
{ line :: Int
|
||||||
|
, column :: Int
|
||||||
|
} deriving (Show)
|
||||||
|
|
||||||
|
type Located expr = Annotated Region expr
|
||||||
|
|
||||||
|
none e = A (None (pretty e)) e
|
||||||
|
noneNoDocs e = A (None P.empty) e
|
||||||
|
|
||||||
|
at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr
|
||||||
|
-> Annotated Region expr
|
||||||
|
at start end e =
|
||||||
|
A (Span (position start) (position end) (pretty e)) e
|
||||||
|
where
|
||||||
|
position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
|
||||||
|
|
||||||
|
merge (A s1 _) (A s2 _) e =
|
||||||
|
A (span (pretty e)) e
|
||||||
|
where
|
||||||
|
span = case (s1,s2) of
|
||||||
|
(Span start _ _, Span _ end _) -> Span start end
|
||||||
|
(Span start end _, _) -> Span start end
|
||||||
|
(_, Span start end _) -> Span start end
|
||||||
|
(_, _) -> None
|
||||||
|
|
||||||
|
mergeOldDocs (A s1 _) (A s2 _) e =
|
||||||
|
A span e
|
||||||
|
where
|
||||||
|
span = case (s1,s2) of
|
||||||
|
(Span start _ d1, Span _ end d2) ->
|
||||||
|
Span start end (P.vcat [d1, P.text "\n", d2])
|
||||||
|
|
||||||
|
(Span _ _ _, _) -> s1
|
||||||
|
(_, Span _ _ _) -> s2
|
||||||
|
(_, _) -> None P.empty
|
||||||
|
|
||||||
|
sameAs :: Annotated a expr -> expr' -> Annotated a expr'
|
||||||
|
sameAs (A annotation _) expr = A annotation expr
|
||||||
|
|
||||||
|
getRegionDocs region =
|
||||||
|
case region of
|
||||||
|
Span _ _ doc -> doc
|
||||||
|
None doc -> doc
|
||||||
|
|
||||||
|
instance Pretty Region where
|
||||||
|
pretty span =
|
||||||
|
case span of
|
||||||
|
None _ -> P.empty
|
||||||
|
Span start end _ ->
|
||||||
|
P.text $
|
||||||
|
case line start == line end of
|
||||||
|
False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
|
||||||
|
True -> "on line " ++ show (line end) ++ ", column " ++
|
||||||
|
show (column start) ++ " to " ++ show (column end)
|
||||||
|
|
||||||
|
instance Pretty e => Pretty (Annotated a e) where
|
||||||
|
pretty (A _ e) = pretty e
|
||||||
|
|
|
@ -20,11 +20,11 @@ data Assoc = L | N | R
|
||||||
|
|
||||||
data ParsePort
|
data ParsePort
|
||||||
= PPAnnotation String T.Type
|
= PPAnnotation String T.Type
|
||||||
| PPDef String Expr.LParseExpr
|
| PPDef String Expr.ParseExpr
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data Port
|
data Port
|
||||||
= Out String Expr.LExpr T.Type
|
= Out String Expr.Expr T.Type
|
||||||
| In String T.Type
|
| In String T.Type
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
|
|
@ -11,49 +11,54 @@ module SourceSyntax.Expression where
|
||||||
import SourceSyntax.PrettyPrint
|
import SourceSyntax.PrettyPrint
|
||||||
import Text.PrettyPrint as P
|
import Text.PrettyPrint as P
|
||||||
import qualified SourceSyntax.Helpers as Help
|
import qualified SourceSyntax.Helpers as Help
|
||||||
import qualified SourceSyntax.Location as Location
|
import qualified SourceSyntax.Annotation as Annotation
|
||||||
import qualified SourceSyntax.Pattern as Pattern
|
import qualified SourceSyntax.Pattern as Pattern
|
||||||
import qualified SourceSyntax.Type as SrcType
|
import qualified SourceSyntax.Type as SrcType
|
||||||
import qualified SourceSyntax.Literal as Literal
|
import qualified SourceSyntax.Literal as Literal
|
||||||
|
import qualified SourceSyntax.Variable as Variable
|
||||||
|
|
||||||
---- GENERAL AST ----
|
---- 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
|
{-| 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
|
"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
|
move through the compilation process. The type holes are used to represent:
|
||||||
structural changes in the types. The only type hole right now is:
|
|
||||||
|
|
||||||
def: Parsing allows two kinds of definitions (type annotations or definitions),
|
ann: Annotations for arbitrary expressions. Allows you to add information
|
||||||
but later checks will see that they are well formed and combine them.
|
to the AST like position in source code or inferred types.
|
||||||
|
|
||||||
|
def: Definition style. The source syntax separates type annotations and
|
||||||
|
definitions, but after parsing we check that they are well formed and
|
||||||
|
collapse them.
|
||||||
|
|
||||||
|
var: Representation of variables. Starts as strings, but is later enriched
|
||||||
|
with information about what module a variable came from.
|
||||||
|
|
||||||
-}
|
-}
|
||||||
data Expr' def
|
type GeneralExpr annotation definition variable =
|
||||||
|
Annotation.Annotated annotation (GeneralExpr' annotation definition variable)
|
||||||
|
|
||||||
|
data GeneralExpr' ann def var
|
||||||
= Literal Literal.Literal
|
= Literal Literal.Literal
|
||||||
| Var String
|
| Var var
|
||||||
| Range (LExpr' def) (LExpr' def)
|
| Range (GeneralExpr ann def var) (GeneralExpr ann def var)
|
||||||
| ExplicitList [LExpr' def]
|
| ExplicitList [GeneralExpr ann def var]
|
||||||
| Binop String (LExpr' def) (LExpr' def)
|
| Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
|
||||||
| Lambda Pattern.Pattern (LExpr' def)
|
| Lambda Pattern.Pattern (GeneralExpr ann def var)
|
||||||
| App (LExpr' def) (LExpr' def)
|
| App (GeneralExpr ann def var) (GeneralExpr ann def var)
|
||||||
| MultiIf [(LExpr' def,LExpr' def)]
|
| MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
|
||||||
| Let [def] (LExpr' def)
|
| Let [def] (GeneralExpr ann def var)
|
||||||
| Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
|
| Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
|
||||||
| Data String [LExpr' def]
|
| Data String [GeneralExpr ann def var]
|
||||||
| Access (LExpr' def) String
|
| Access (GeneralExpr ann def var) String
|
||||||
| Remove (LExpr' def) String
|
| Remove (GeneralExpr ann def var) String
|
||||||
| Insert (LExpr' def) String (LExpr' def)
|
| Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
|
||||||
| Modify (LExpr' def) [(String, LExpr' def)]
|
| Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
|
||||||
| Record [(String, LExpr' def)]
|
| Record [(String, GeneralExpr ann def var)]
|
||||||
| Markdown String String [LExpr' def]
|
| Markdown String String [GeneralExpr ann def var]
|
||||||
-- for type checking and code gen only
|
-- for type checking and code gen only
|
||||||
| PortIn String SrcType.Type
|
| PortIn String SrcType.Type
|
||||||
| PortOut String SrcType.Type (LExpr' def)
|
| PortOut String SrcType.Type (GeneralExpr ann def var)
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
|
||||||
---- SPECIALIZED ASTs ----
|
---- SPECIALIZED ASTs ----
|
||||||
|
@ -62,11 +67,11 @@ data Expr' def
|
||||||
annotations and definitions, which is how they appear in source code and how
|
annotations and definitions, which is how they appear in source code and how
|
||||||
they are parsed.
|
they are parsed.
|
||||||
-}
|
-}
|
||||||
type ParseExpr = Expr' ParseDef
|
type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
|
||||||
type LParseExpr = LExpr' ParseDef
|
type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
|
||||||
|
|
||||||
data ParseDef
|
data ParseDef
|
||||||
= Def Pattern.Pattern LParseExpr
|
= Def Pattern.Pattern ParseExpr
|
||||||
| TypeAnnotation String SrcType.Type
|
| TypeAnnotation String SrcType.Type
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
@ -74,69 +79,88 @@ data ParseDef
|
||||||
ports are all paired with definitions in the appropriate order, it collapses
|
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.
|
them into a Def that is easier to work with in later phases of compilation.
|
||||||
-}
|
-}
|
||||||
type LExpr = LExpr' Def
|
type Expr = GeneralExpr Annotation.Region Def Variable.Raw
|
||||||
type Expr = Expr' Def
|
type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw
|
||||||
|
|
||||||
data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
|
data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
---- UTILITIES ----
|
---- UTILITIES ----
|
||||||
|
|
||||||
tuple :: [LExpr' def] -> Expr' def
|
rawVar :: String -> GeneralExpr' ann def Variable.Raw
|
||||||
|
rawVar x = Var (Variable.Raw x)
|
||||||
|
|
||||||
|
tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var
|
||||||
tuple es = Data ("_Tuple" ++ show (length es)) es
|
tuple es = Data ("_Tuple" ++ show (length es)) es
|
||||||
|
|
||||||
delist :: LExpr' def -> [LExpr' def]
|
delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
|
||||||
delist (Location.L _ (Data "::" [h,t])) = h : delist t
|
delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
|
||||||
delist _ = []
|
delist _ = []
|
||||||
|
|
||||||
saveEnvName :: String
|
saveEnvName :: String
|
||||||
saveEnvName = "_save_the_environment!!!"
|
saveEnvName = "_save_the_environment!!!"
|
||||||
|
|
||||||
dummyLet :: Pretty def => [def] -> LExpr' def
|
dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
|
||||||
dummyLet defs =
|
dummyLet defs =
|
||||||
Location.none $ Let defs (Location.none $ Var saveEnvName)
|
Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)
|
||||||
|
|
||||||
instance Pretty def => Show (Expr' def) where
|
instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
|
||||||
show = render . pretty
|
|
||||||
|
|
||||||
instance Pretty def => Pretty (Expr' def) where
|
|
||||||
pretty expr =
|
pretty expr =
|
||||||
case expr of
|
case expr of
|
||||||
Literal lit -> pretty lit
|
Literal lit -> pretty lit
|
||||||
Var x -> variable x
|
|
||||||
|
Var x -> pretty x
|
||||||
|
|
||||||
Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
|
Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
|
||||||
|
|
||||||
ExplicitList es -> P.brackets (commaCat (map pretty es))
|
ExplicitList es -> P.brackets (commaCat (map pretty es))
|
||||||
Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
|
|
||||||
|
Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->
|
||||||
P.text "-" <> prettyParens e
|
P.text "-" <> prettyParens e
|
||||||
|
|
||||||
Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
|
Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
|
||||||
where op' = if Help.isOp op then op else "`" ++ op ++ "`"
|
where
|
||||||
|
op' = if Help.isOp op then op else "`" ++ op ++ "`"
|
||||||
|
|
||||||
Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
|
Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
|
||||||
where
|
where
|
||||||
(ps,body) = collectLambdas (Location.none $ Lambda p e)
|
(ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
|
||||||
args = P.sep (map Pattern.prettyParens ps)
|
args = P.sep (map Pattern.prettyParens ps)
|
||||||
|
|
||||||
App _ _ -> P.hang func 2 (P.sep args)
|
App _ _ -> P.hang func 2 (P.sep args)
|
||||||
where func:args = map prettyParens (collectApps (Location.none expr))
|
where
|
||||||
|
func:args = map prettyParens (collectApps (Annotation.A undefined expr))
|
||||||
|
|
||||||
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
|
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
|
||||||
where
|
where
|
||||||
iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
|
iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
|
||||||
|
|
||||||
Let defs e ->
|
Let defs e ->
|
||||||
P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
|
P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
|
||||||
, P.text "in" <+> pretty e ]
|
, P.text "in" <+> pretty e ]
|
||||||
|
|
||||||
Case e pats ->
|
Case e pats ->
|
||||||
P.hang pexpr 2 (P.vcat (map pretty' pats))
|
P.hang pexpr 2 (P.vcat (map pretty' pats))
|
||||||
where
|
where
|
||||||
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
|
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
|
||||||
pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
|
pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
|
||||||
|
|
||||||
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
|
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
|
||||||
Data "[]" [] -> P.text "[]"
|
Data "[]" [] -> P.text "[]"
|
||||||
Data name es
|
Data name es
|
||||||
| Help.isTuple name -> P.parens (commaCat (map pretty es))
|
| Help.isTuple name -> P.parens (commaCat (map pretty es))
|
||||||
| otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
|
| otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
|
||||||
|
|
||||||
Access e x -> prettyParens e <> P.text "." <> variable x
|
Access e x -> prettyParens e <> P.text "." <> variable x
|
||||||
|
|
||||||
Remove e x -> P.braces (pretty 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.equals <+> pretty v)
|
Insert (Annotation.A _ (Remove e y)) x v ->
|
||||||
|
P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
|
||||||
|
, variable x, P.equals, pretty v ]
|
||||||
|
|
||||||
Insert e x v ->
|
Insert e x v ->
|
||||||
P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
|
P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
|
||||||
|
|
||||||
|
@ -175,21 +199,23 @@ instance Pretty Def where
|
||||||
Nothing -> P.empty
|
Nothing -> P.empty
|
||||||
Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
|
Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
|
||||||
|
|
||||||
collectApps :: LExpr' def -> [LExpr' def]
|
collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
|
||||||
collectApps lexpr@(Location.L _ expr) =
|
collectApps annExpr@(Annotation.A _ expr) =
|
||||||
case expr of
|
case expr of
|
||||||
App a b -> collectApps a ++ [b]
|
App a b -> collectApps a ++ [b]
|
||||||
_ -> [lexpr]
|
_ -> [annExpr]
|
||||||
|
|
||||||
collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
|
collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
|
||||||
collectLambdas lexpr@(Location.L _ expr) =
|
collectLambdas lexpr@(Annotation.A _ expr) =
|
||||||
case expr of
|
case expr of
|
||||||
Lambda pattern body -> (pattern : ps, body')
|
Lambda pattern body ->
|
||||||
where (ps, body') = collectLambdas body
|
let (ps, body') = collectLambdas body
|
||||||
|
in (pattern : ps, body')
|
||||||
|
|
||||||
_ -> ([], lexpr)
|
_ -> ([], lexpr)
|
||||||
|
|
||||||
prettyParens :: (Pretty def) => LExpr' def -> Doc
|
prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
|
||||||
prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
|
prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
|
||||||
where
|
where
|
||||||
needed =
|
needed =
|
||||||
case expr of
|
case expr of
|
||||||
|
|
|
@ -3,6 +3,15 @@ module SourceSyntax.Helpers where
|
||||||
|
|
||||||
import qualified Data.Char as Char
|
import qualified Data.Char as Char
|
||||||
|
|
||||||
|
splitDots :: String -> [String]
|
||||||
|
splitDots = go []
|
||||||
|
where
|
||||||
|
go vars str =
|
||||||
|
case break (=='.') str of
|
||||||
|
(x,_:rest) | isOp x -> vars ++ [x ++ '.' : rest]
|
||||||
|
| otherwise -> go (vars ++ [x]) rest
|
||||||
|
(x,[]) -> vars ++ [x]
|
||||||
|
|
||||||
brkt :: String -> String
|
brkt :: String -> String
|
||||||
brkt s = "{ " ++ s ++ " }"
|
brkt s = "{ " ++ s ++ " }"
|
||||||
|
|
||||||
|
|
|
@ -1,58 +0,0 @@
|
||||||
module SourceSyntax.Location where
|
|
||||||
|
|
||||||
import Text.PrettyPrint
|
|
||||||
import SourceSyntax.PrettyPrint
|
|
||||||
import qualified Text.Parsec.Pos as Parsec
|
|
||||||
|
|
||||||
data SrcPos = Pos { line :: Int, column :: Int }
|
|
||||||
deriving (Eq, Ord)
|
|
||||||
|
|
||||||
data SrcSpan = Span SrcPos SrcPos String | NoSpan String
|
|
||||||
deriving (Eq, Ord)
|
|
||||||
|
|
||||||
data Located e = L SrcSpan e
|
|
||||||
deriving (Eq, Ord)
|
|
||||||
|
|
||||||
none e = L (NoSpan (render $ pretty e)) e
|
|
||||||
noneNoDocs = L (NoSpan "")
|
|
||||||
|
|
||||||
at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))
|
|
||||||
(Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))
|
|
||||||
(render $ pretty e)) e
|
|
||||||
|
|
||||||
merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e
|
|
||||||
where span = case (s1,s2) of
|
|
||||||
(Span start _ _, Span _ end _) -> Span start end
|
|
||||||
(Span start end _, _) -> Span start end
|
|
||||||
(_, Span start end _) -> Span start end
|
|
||||||
(_, _) -> NoSpan
|
|
||||||
|
|
||||||
mergeOldDocs (L s1 _) (L s2 _) e = L span e
|
|
||||||
where span = case (s1,s2) of
|
|
||||||
(Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)
|
|
||||||
(Span _ _ _, _) -> s1
|
|
||||||
(_, Span _ _ _) -> s2
|
|
||||||
(_, _) -> NoSpan ""
|
|
||||||
|
|
||||||
sameAs (L s _) = L s
|
|
||||||
|
|
||||||
|
|
||||||
instance Show SrcPos where
|
|
||||||
show (Pos r c) = show r ++ "," ++ show c
|
|
||||||
|
|
||||||
instance Show SrcSpan where
|
|
||||||
show span =
|
|
||||||
case span of
|
|
||||||
NoSpan _ -> ""
|
|
||||||
Span start end _ ->
|
|
||||||
case line start == line end of
|
|
||||||
False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
|
|
||||||
True -> "on line " ++ show (line end) ++ ", column " ++
|
|
||||||
show (column start) ++ " to " ++ show (column end)
|
|
||||||
|
|
||||||
instance Show e => Show (Located e) where
|
|
||||||
show (L _ e) = show e
|
|
||||||
|
|
||||||
instance Pretty a => Pretty (Located a) where
|
|
||||||
pretty (L _ e) = pretty e
|
|
||||||
|
|
|
@ -1,12 +1,15 @@
|
||||||
{-# OPTIONS_GHC -Wall #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module SourceSyntax.Module where
|
module SourceSyntax.Module where
|
||||||
|
|
||||||
import Data.Binary
|
import Data.Binary
|
||||||
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Control.Applicative ((<$>), (<*>))
|
import Control.Applicative ((<$>), (<*>))
|
||||||
|
import Text.PrettyPrint as P
|
||||||
|
|
||||||
import SourceSyntax.Expression (LExpr)
|
import SourceSyntax.Expression (Expr)
|
||||||
import SourceSyntax.Declaration
|
import SourceSyntax.Declaration
|
||||||
|
import SourceSyntax.PrettyPrint
|
||||||
import SourceSyntax.Type
|
import SourceSyntax.Type
|
||||||
|
|
||||||
import qualified Elm.Internal.Version as Version
|
import qualified Elm.Internal.Version as Version
|
||||||
|
@ -21,6 +24,33 @@ type Imports = [(String, ImportMethod)]
|
||||||
data ImportMethod = As String | Importing [String] | Hiding [String]
|
data ImportMethod = As String | Importing [String] | Hiding [String]
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
instance (Pretty def) => Pretty (Module def) where
|
||||||
|
pretty (Module modNames exports imports decls) =
|
||||||
|
P.vcat [modul, P.text "", prettyImports, P.text "", prettyDecls]
|
||||||
|
where
|
||||||
|
prettyDecls = P.sep $ map pretty decls
|
||||||
|
|
||||||
|
modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"
|
||||||
|
moduleName = P.text $ List.intercalate "." modNames
|
||||||
|
prettyExports =
|
||||||
|
case exports of
|
||||||
|
[] -> P.empty
|
||||||
|
_ -> P.parens . commaCat $ map P.text exports
|
||||||
|
|
||||||
|
prettyImports = P.vcat $ map prettyImport imports
|
||||||
|
|
||||||
|
prettyImport (name, method) =
|
||||||
|
P.text "import" <+>
|
||||||
|
case method of
|
||||||
|
As alias ->
|
||||||
|
P.text $ name ++ (if name == alias then "" else " as " ++ alias)
|
||||||
|
|
||||||
|
Importing values ->
|
||||||
|
P.text name <+> P.parens (commaCat (map P.text values))
|
||||||
|
|
||||||
|
Hiding [] -> P.text ("open " ++ name)
|
||||||
|
Hiding _ -> error "invalid import declaration"
|
||||||
|
|
||||||
instance Binary ImportMethod where
|
instance Binary ImportMethod where
|
||||||
put method =
|
put method =
|
||||||
let put' n info = putWord8 n >> put info in
|
let put' n info = putWord8 n >> put info in
|
||||||
|
@ -42,7 +72,7 @@ data MetadataModule =
|
||||||
, path :: FilePath
|
, path :: FilePath
|
||||||
, exports :: [String]
|
, exports :: [String]
|
||||||
, imports :: [(String, ImportMethod)]
|
, imports :: [(String, ImportMethod)]
|
||||||
, program :: LExpr
|
, program :: Expr
|
||||||
, types :: Map.Map String Type
|
, types :: Map.Map String Type
|
||||||
, fixities :: [(Assoc, Int, String)]
|
, fixities :: [(Assoc, Int, String)]
|
||||||
, aliases :: [Alias]
|
, aliases :: [Alias]
|
||||||
|
|
|
@ -7,50 +7,54 @@ import Text.PrettyPrint as PP
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import SourceSyntax.Literal as Literal
|
import SourceSyntax.Literal as Literal
|
||||||
|
|
||||||
data Pattern = PData String [Pattern]
|
data Pattern
|
||||||
| PRecord [String]
|
= Data String [Pattern]
|
||||||
| PAlias String Pattern
|
| Record [String]
|
||||||
| PVar String
|
| Alias String Pattern
|
||||||
| PAnything
|
| Var String
|
||||||
| PLiteral Literal.Literal
|
| Anything
|
||||||
|
| Literal Literal.Literal
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
cons :: Pattern -> Pattern -> Pattern
|
cons :: Pattern -> Pattern -> Pattern
|
||||||
cons h t = PData "::" [h,t]
|
cons h t = Data "::" [h,t]
|
||||||
|
|
||||||
nil :: Pattern
|
nil :: Pattern
|
||||||
nil = PData "[]" []
|
nil = Data "[]" []
|
||||||
|
|
||||||
list :: [Pattern] -> Pattern
|
list :: [Pattern] -> Pattern
|
||||||
list = foldr cons nil
|
list = foldr cons nil
|
||||||
|
|
||||||
tuple :: [Pattern] -> Pattern
|
tuple :: [Pattern] -> Pattern
|
||||||
tuple es = PData ("_Tuple" ++ show (length es)) es
|
tuple es = Data ("_Tuple" ++ show (length es)) es
|
||||||
|
|
||||||
|
boundVarList :: Pattern -> [String]
|
||||||
|
boundVarList = Set.toList . boundVars
|
||||||
|
|
||||||
boundVars :: Pattern -> Set.Set String
|
boundVars :: Pattern -> Set.Set String
|
||||||
boundVars pattern =
|
boundVars pattern =
|
||||||
case pattern of
|
case pattern of
|
||||||
PVar x -> Set.singleton x
|
Var x -> Set.singleton x
|
||||||
PAlias x p -> Set.insert x (boundVars p)
|
Alias x p -> Set.insert x (boundVars p)
|
||||||
PData _ ps -> Set.unions (map boundVars ps)
|
Data _ ps -> Set.unions (map boundVars ps)
|
||||||
PRecord fields -> Set.fromList fields
|
Record fields -> Set.fromList fields
|
||||||
PAnything -> Set.empty
|
Anything -> Set.empty
|
||||||
PLiteral _ -> Set.empty
|
Literal _ -> Set.empty
|
||||||
|
|
||||||
|
|
||||||
instance Pretty Pattern where
|
instance Pretty Pattern where
|
||||||
pretty pattern =
|
pretty pattern =
|
||||||
case pattern of
|
case pattern of
|
||||||
PVar x -> variable x
|
Var x -> variable x
|
||||||
PLiteral lit -> pretty lit
|
Literal lit -> pretty lit
|
||||||
PRecord fs -> PP.braces (commaCat $ map variable fs)
|
Record fs -> PP.braces (commaCat $ map variable fs)
|
||||||
PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
|
Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
|
||||||
PAnything -> PP.text "_"
|
Anything -> PP.text "_"
|
||||||
PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
|
Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
|
||||||
where isCons = case hd of
|
where isCons = case hd of
|
||||||
PData "::" _ -> True
|
Data "::" _ -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
PData name ps ->
|
Data name ps ->
|
||||||
if Help.isTuple name then
|
if Help.isTuple name then
|
||||||
PP.parens . commaCat $ map pretty ps
|
PP.parens . commaCat $ map pretty ps
|
||||||
else hsep (PP.text name : map prettyParens ps)
|
else hsep (PP.text name : map prettyParens ps)
|
||||||
|
@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
|
||||||
where
|
where
|
||||||
needsThem =
|
needsThem =
|
||||||
case pattern of
|
case pattern of
|
||||||
PData name (_:_) | not (Help.isTuple name) -> True
|
Data name (_:_) | not (Help.isTuple name) -> True
|
||||||
PAlias _ _ -> True
|
Alias _ _ -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
|
@ -10,11 +10,16 @@ class Pretty a where
|
||||||
instance Pretty () where
|
instance Pretty () where
|
||||||
pretty () = empty
|
pretty () = empty
|
||||||
|
|
||||||
|
renderPretty :: (Pretty a) => a -> String
|
||||||
|
renderPretty e = render (pretty e)
|
||||||
|
|
||||||
commaCat docs = cat (punctuate comma docs)
|
commaCat docs = cat (punctuate comma docs)
|
||||||
commaSep docs = sep (punctuate comma docs)
|
commaSep docs = sep (punctuate comma docs)
|
||||||
|
|
||||||
|
parensIf :: Bool -> Doc -> Doc
|
||||||
parensIf bool doc = if bool then parens doc else doc
|
parensIf bool doc = if bool then parens doc else doc
|
||||||
|
|
||||||
|
variable :: String -> Doc
|
||||||
variable x =
|
variable x =
|
||||||
if Help.isOp x then parens (text x)
|
if Help.isOp x then parens (text x)
|
||||||
else text (reprime x)
|
else text (reprime x)
|
||||||
|
|
|
@ -1,18 +1,18 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module SourceSyntax.Type where
|
module SourceSyntax.Type where
|
||||||
|
|
||||||
|
import Control.Applicative ((<$>), (<*>))
|
||||||
import Data.Binary
|
import Data.Binary
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified SourceSyntax.Helpers as Help
|
|
||||||
import Control.Applicative ((<$>), (<*>))
|
|
||||||
import SourceSyntax.PrettyPrint
|
import SourceSyntax.PrettyPrint
|
||||||
|
import qualified SourceSyntax.Helpers as Help
|
||||||
import Text.PrettyPrint as P
|
import Text.PrettyPrint as P
|
||||||
|
|
||||||
data Type = Lambda Type Type
|
data Type = Lambda Type Type
|
||||||
| Var String
|
| Var String
|
||||||
| Data String [Type]
|
| Data String [Type]
|
||||||
| Record [(String,Type)] (Maybe String)
|
| Record [(String,Type)] (Maybe String)
|
||||||
deriving (Eq)
|
deriving (Eq,Show)
|
||||||
|
|
||||||
fieldMap :: [(String,a)] -> Map.Map String [a]
|
fieldMap :: [(String,a)] -> Map.Map String [a]
|
||||||
fieldMap fields =
|
fieldMap fields =
|
||||||
|
@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
|
||||||
tupleOf :: [Type] -> Type
|
tupleOf :: [Type] -> Type
|
||||||
tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
|
tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
|
||||||
|
|
||||||
instance Show Type where
|
|
||||||
show = render . pretty
|
|
||||||
|
|
||||||
instance Pretty Type where
|
instance Pretty Type where
|
||||||
pretty tipe =
|
pretty tipe =
|
||||||
case tipe of
|
case tipe of
|
||||||
|
|
11
compiler/SourceSyntax/Variable.hs
Normal file
11
compiler/SourceSyntax/Variable.hs
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
|
||||||
|
module SourceSyntax.Variable where
|
||||||
|
|
||||||
|
import qualified Text.PrettyPrint as P
|
||||||
|
import SourceSyntax.PrettyPrint
|
||||||
|
|
||||||
|
newtype Raw = Raw String
|
||||||
|
deriving (Eq,Ord,Show)
|
||||||
|
|
||||||
|
instance Pretty Raw where
|
||||||
|
pretty (Raw var) = variable var
|
|
@ -1,19 +1,21 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -Wall #-}
|
||||||
module Transform.Canonicalize (interface, metadataModule) where
|
module Transform.Canonicalize (interface, metadataModule) where
|
||||||
|
|
||||||
import Control.Arrow ((***))
|
import Control.Arrow ((***))
|
||||||
import Control.Applicative (Applicative,(<$>),(<*>))
|
import Control.Applicative (Applicative,(<$>),(<*>))
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
import qualified Data.Traversable as T
|
import qualified Data.Either as Either
|
||||||
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Data.List as List
|
import qualified Data.Traversable as T
|
||||||
import qualified Data.Either as Either
|
import SourceSyntax.Annotation as A
|
||||||
import SourceSyntax.Module
|
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
import SourceSyntax.Location as Loc
|
import SourceSyntax.Module
|
||||||
|
import SourceSyntax.PrettyPrint (pretty)
|
||||||
import qualified SourceSyntax.Pattern as P
|
import qualified SourceSyntax.Pattern as P
|
||||||
import qualified SourceSyntax.Type as Type
|
import qualified SourceSyntax.Type as Type
|
||||||
|
import qualified SourceSyntax.Variable as Var
|
||||||
import Text.PrettyPrint as P
|
import Text.PrettyPrint as P
|
||||||
|
|
||||||
interface :: String -> ModuleInterface -> ModuleInterface
|
interface :: String -> ModuleInterface -> ModuleInterface
|
||||||
|
@ -55,7 +57,9 @@ metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
|
||||||
metadataModule ifaces modul =
|
metadataModule ifaces modul =
|
||||||
do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
|
do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
|
||||||
[] -> Right ()
|
[] -> Right ()
|
||||||
missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
|
missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++
|
||||||
|
"\n You may need to compile with the --make flag to detect modules you have written."
|
||||||
|
]
|
||||||
program' <- rename initialEnv (program modul)
|
program' <- rename initialEnv (program modul)
|
||||||
aliases' <- mapM (three3 renameType') (aliases modul)
|
aliases' <- mapM (three3 renameType') (aliases modul)
|
||||||
datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
|
datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
|
||||||
|
@ -94,8 +98,7 @@ type Env = Map.Map String String
|
||||||
|
|
||||||
extend :: Env -> P.Pattern -> Env
|
extend :: Env -> P.Pattern -> Env
|
||||||
extend env pattern = Map.union (Map.fromList (zip xs xs)) env
|
extend env pattern = Map.union (Map.fromList (zip xs xs)) env
|
||||||
where xs = Set.toList (P.boundVars pattern)
|
where xs = P.boundVarList pattern
|
||||||
|
|
||||||
|
|
||||||
replace :: String -> Env -> String -> Either String String
|
replace :: String -> Env -> String -> Either String String
|
||||||
replace variable env v =
|
replace variable env v =
|
||||||
|
@ -108,14 +111,18 @@ replace variable env v =
|
||||||
msg = if null matches then "" else
|
msg = if null matches then "" else
|
||||||
"\nClose matches include: " ++ List.intercalate ", " matches
|
"\nClose matches include: " ++ List.intercalate ", " matches
|
||||||
|
|
||||||
rename :: Env -> LExpr -> Either [Doc] LExpr
|
-- TODO: Var.Raw -> Var.Canonical
|
||||||
rename env (L s expr) =
|
rename :: Env -> Expr -> Either [Doc] Expr
|
||||||
|
rename env (A ann expr) =
|
||||||
let rnm = rename env
|
let rnm = rename env
|
||||||
throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
|
throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon
|
||||||
|
, P.text err
|
||||||
|
]
|
||||||
|
]
|
||||||
format = Either.either throw return
|
format = Either.either throw return
|
||||||
renameType' env = renameType (format . replace "variable" env)
|
renameType' environ = renameType (format . replace "variable" environ)
|
||||||
in
|
in
|
||||||
L s <$>
|
A ann <$>
|
||||||
case expr of
|
case expr of
|
||||||
Literal _ -> return expr
|
Literal _ -> return expr
|
||||||
|
|
||||||
|
@ -153,7 +160,8 @@ rename env (L s expr) =
|
||||||
<*> rename env' body
|
<*> rename env' body
|
||||||
<*> T.traverse (renameType' env') mtipe
|
<*> T.traverse (renameType' env') mtipe
|
||||||
|
|
||||||
Var x -> Var <$> format (replace "variable" env x)
|
-- TODO: Raw -> Canonical
|
||||||
|
Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
|
||||||
|
|
||||||
Data name es -> Data name <$> mapM rnm es
|
Data name es -> Data name <$> mapM rnm es
|
||||||
|
|
||||||
|
@ -174,10 +182,10 @@ rename env (L s expr) =
|
||||||
renamePattern :: Env -> P.Pattern -> Either String P.Pattern
|
renamePattern :: Env -> P.Pattern -> Either String P.Pattern
|
||||||
renamePattern env pattern =
|
renamePattern env pattern =
|
||||||
case pattern of
|
case pattern of
|
||||||
P.PVar _ -> return pattern
|
P.Var _ -> return pattern
|
||||||
P.PLiteral _ -> return pattern
|
P.Literal _ -> return pattern
|
||||||
P.PRecord _ -> return pattern
|
P.Record _ -> return pattern
|
||||||
P.PAnything -> return pattern
|
P.Anything -> return pattern
|
||||||
P.PAlias x p -> P.PAlias x <$> renamePattern env p
|
P.Alias x p -> P.Alias x <$> renamePattern env p
|
||||||
P.PData name ps -> P.PData <$> replace "pattern" env name
|
P.Data name ps -> P.Data <$> replace "pattern" env name
|
||||||
<*> mapM (renamePattern env) ps
|
<*> mapM (renamePattern env) ps
|
||||||
|
|
|
@ -32,7 +32,7 @@ dupErr err x =
|
||||||
|
|
||||||
duplicates :: [D.Declaration] -> [String]
|
duplicates :: [D.Declaration] -> [String]
|
||||||
duplicates decls =
|
duplicates decls =
|
||||||
map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
|
map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
|
||||||
case mapM exprDups (portExprs ++ defExprs) of
|
case mapM exprDups (portExprs ++ defExprs) of
|
||||||
Left name -> [msg name]
|
Left name -> [msg name]
|
||||||
Right _ -> []
|
Right _ -> []
|
||||||
|
@ -50,14 +50,13 @@ duplicates decls =
|
||||||
D.Out name expr _ -> (name, [expr])
|
D.Out name expr _ -> (name, [expr])
|
||||||
D.In name _ -> (name, [])
|
D.In name _ -> (name, [])
|
||||||
|
|
||||||
getNames = Set.toList . Pattern.boundVars
|
exprDups :: E.Expr -> Either String E.Expr
|
||||||
|
|
||||||
exprDups :: E.LExpr -> Either String E.LExpr
|
|
||||||
exprDups expr = Expr.crawlLet defsDups expr
|
exprDups expr = Expr.crawlLet defsDups expr
|
||||||
|
|
||||||
defsDups :: [E.Def] -> Either String [E.Def]
|
defsDups :: [E.Def] -> Either String [E.Def]
|
||||||
defsDups defs =
|
defsDups defs =
|
||||||
case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
|
let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in
|
||||||
|
case dups $ concatMap varsIn defs of
|
||||||
[] -> Right defs
|
[] -> Right defs
|
||||||
name:_ -> Left name
|
name:_ -> Left name
|
||||||
|
|
||||||
|
|
|
@ -42,7 +42,7 @@ combineAnnotations = go
|
||||||
|
|
||||||
TypeAnnotation name tipe ->
|
TypeAnnotation name tipe ->
|
||||||
case defRest of
|
case defRest of
|
||||||
D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
|
D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->
|
||||||
do expr' <- exprCombineAnnotations expr
|
do expr' <- exprCombineAnnotations expr
|
||||||
let def' = E.Definition pat expr' (Just tipe)
|
let def' = E.Definition pat expr' (Just tipe)
|
||||||
(:) (D.Definition def') <$> go rest
|
(:) (D.Definition def') <$> go rest
|
||||||
|
|
|
@ -16,7 +16,7 @@ combineAnnotations = go
|
||||||
|
|
||||||
go defs =
|
go defs =
|
||||||
case defs of
|
case defs of
|
||||||
TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
|
TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->
|
||||||
do expr' <- exprCombineAnnotations expr
|
do expr' <- exprCombineAnnotations expr
|
||||||
let def = Definition pat expr' (Just tipe)
|
let def = Definition pat expr' (Just tipe)
|
||||||
(:) def <$> go rest
|
(:) def <$> go rest
|
||||||
|
|
|
@ -2,17 +2,19 @@
|
||||||
module Transform.Expression (crawlLet, checkPorts) where
|
module Transform.Expression (crawlLet, checkPorts) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
|
import SourceSyntax.Annotation ( Annotated(A) )
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
import SourceSyntax.Location
|
import SourceSyntax.Type (Type)
|
||||||
import qualified SourceSyntax.Type as ST
|
|
||||||
|
|
||||||
crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
|
crawlLet :: ([def] -> Either a [def'])
|
||||||
|
-> GeneralExpr ann def var
|
||||||
|
-> Either a (GeneralExpr ann def' var)
|
||||||
crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
|
crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
|
||||||
|
|
||||||
checkPorts :: (String -> ST.Type -> Either a ())
|
checkPorts :: (String -> Type -> Either a ())
|
||||||
-> (String -> ST.Type -> Either a ())
|
-> (String -> Type -> Either a ())
|
||||||
-> LExpr
|
-> Expr
|
||||||
-> Either a LExpr
|
-> Either a Expr
|
||||||
checkPorts inCheck outCheck expr =
|
checkPorts inCheck outCheck expr =
|
||||||
crawl inCheck outCheck (mapM checkDef) expr
|
crawl inCheck outCheck (mapM checkDef) expr
|
||||||
where
|
where
|
||||||
|
@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =
|
||||||
do _ <- checkPorts inCheck outCheck body
|
do _ <- checkPorts inCheck outCheck body
|
||||||
return def
|
return def
|
||||||
|
|
||||||
crawl :: (String -> ST.Type -> Either a ())
|
crawl :: (String -> Type -> Either a ())
|
||||||
-> (String -> ST.Type -> Either a ())
|
-> (String -> Type -> Either a ())
|
||||||
-> ([def] -> Either a [def'])
|
-> ([def] -> Either a [def'])
|
||||||
-> LExpr' def
|
-> GeneralExpr ann def var
|
||||||
-> Either a (LExpr' def')
|
-> Either a (GeneralExpr ann def' var)
|
||||||
crawl portInCheck portOutCheck defsTransform = go
|
crawl portInCheck portOutCheck defsTransform = go
|
||||||
where
|
where
|
||||||
go (L srcSpan expr) =
|
go (A srcSpan expr) =
|
||||||
L srcSpan <$>
|
A srcSpan <$>
|
||||||
case expr of
|
case expr of
|
||||||
Var x -> return (Var x)
|
Var x -> return (Var x)
|
||||||
Lambda p e -> Lambda p <$> go e
|
Lambda p e -> Lambda p <$> go e
|
||||||
|
|
|
@ -2,38 +2,43 @@
|
||||||
module Transform.SafeNames (metadataModule) where
|
module Transform.SafeNames (metadataModule) where
|
||||||
|
|
||||||
import Control.Arrow (first, (***))
|
import Control.Arrow (first, (***))
|
||||||
import SourceSyntax.Expression
|
import qualified Data.List as List
|
||||||
import SourceSyntax.Location
|
|
||||||
import SourceSyntax.Module
|
|
||||||
import SourceSyntax.Pattern
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import qualified Parse.Helpers as PHelp
|
import qualified Parse.Helpers as PHelp
|
||||||
|
import SourceSyntax.Annotation
|
||||||
|
import SourceSyntax.Expression
|
||||||
|
import qualified SourceSyntax.Helpers as SHelp
|
||||||
|
import SourceSyntax.Module
|
||||||
|
import qualified SourceSyntax.Pattern as P
|
||||||
|
import qualified SourceSyntax.Variable as Variable
|
||||||
|
|
||||||
var :: String -> String
|
var :: String -> String
|
||||||
var = dereserve . deprime
|
var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
|
||||||
where
|
where
|
||||||
deprime = map (\c -> if c == '\'' then '$' else c)
|
deprime = map (\c -> if c == '\'' then '$' else c)
|
||||||
dereserve x = case Set.member x PHelp.jsReserveds of
|
dereserve x = case Set.member x PHelp.jsReserveds of
|
||||||
False -> x
|
False -> x
|
||||||
True -> "$" ++ x
|
True -> "$" ++ x
|
||||||
|
|
||||||
pattern :: Pattern -> Pattern
|
pattern :: P.Pattern -> P.Pattern
|
||||||
pattern pat =
|
pattern pat =
|
||||||
case pat of
|
case pat of
|
||||||
PVar x -> PVar (var x)
|
P.Var x -> P.Var (var x)
|
||||||
PLiteral _ -> pat
|
P.Literal _ -> pat
|
||||||
PRecord fs -> PRecord (map var fs)
|
P.Record fs -> P.Record (map var fs)
|
||||||
PAnything -> pat
|
P.Anything -> pat
|
||||||
PAlias x p -> PAlias (var x) (pattern p)
|
P.Alias x p -> P.Alias (var x) (pattern p)
|
||||||
PData name ps -> PData name (map pattern ps)
|
P.Data name ps -> P.Data name (map pattern ps)
|
||||||
|
|
||||||
expression :: LExpr -> LExpr
|
-- TODO: should be "normal expression" -> "expression for JS generation"
|
||||||
expression (L loc expr) =
|
expression :: Expr -> Expr
|
||||||
|
expression (A ann expr) =
|
||||||
let f = expression in
|
let f = expression in
|
||||||
L loc $
|
A ann $
|
||||||
case expr of
|
case expr of
|
||||||
Literal _ -> expr
|
Literal _ -> expr
|
||||||
Var x -> Var (var x)
|
Var (Variable.Raw x) -> rawVar (var x)
|
||||||
Range e1 e2 -> Range (f e1) (f e2)
|
Range e1 e2 -> Range (f e1) (f e2)
|
||||||
ExplicitList es -> ExplicitList (map f es)
|
ExplicitList es -> ExplicitList (map f es)
|
||||||
Binop op e1 e2 -> Binop op (f e1) (f e2)
|
Binop op e1 e2 -> Binop op (f e1) (f e2)
|
||||||
|
|
|
@ -3,23 +3,24 @@ module Transform.SortDefinitions (sortDefs) where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
import qualified Data.Map as Map
|
|
||||||
import SourceSyntax.Expression
|
|
||||||
import SourceSyntax.Location
|
|
||||||
import qualified SourceSyntax.Pattern as P
|
|
||||||
import qualified Data.Graph as Graph
|
import qualified Data.Graph as Graph
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Maybe as Maybe
|
import qualified Data.Maybe as Maybe
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import SourceSyntax.Annotation
|
||||||
|
import SourceSyntax.Expression
|
||||||
|
import qualified SourceSyntax.Pattern as P
|
||||||
|
import qualified SourceSyntax.Variable as V
|
||||||
|
|
||||||
ctors :: P.Pattern -> [String]
|
ctors :: P.Pattern -> [String]
|
||||||
ctors pattern =
|
ctors pattern =
|
||||||
case pattern of
|
case pattern of
|
||||||
P.PVar _ -> []
|
P.Var _ -> []
|
||||||
P.PAlias _ p -> ctors p
|
P.Alias _ p -> ctors p
|
||||||
P.PData ctor ps -> ctor : concatMap ctors ps
|
P.Data ctor ps -> ctor : concatMap ctors ps
|
||||||
P.PRecord _ -> []
|
P.Record _ -> []
|
||||||
P.PAnything -> []
|
P.Anything -> []
|
||||||
P.PLiteral _ -> []
|
P.Literal _ -> []
|
||||||
|
|
||||||
free :: String -> State (Set.Set String) ()
|
free :: String -> State (Set.Set String) ()
|
||||||
free x = modify (Set.insert x)
|
free x = modify (Set.insert x)
|
||||||
|
@ -27,15 +28,15 @@ free x = modify (Set.insert x)
|
||||||
bound :: Set.Set String -> State (Set.Set String) ()
|
bound :: Set.Set String -> State (Set.Set String) ()
|
||||||
bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
|
bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
|
||||||
|
|
||||||
sortDefs :: LExpr -> LExpr
|
sortDefs :: Expr -> Expr
|
||||||
sortDefs expr = evalState (reorder expr) Set.empty
|
sortDefs expr = evalState (reorder expr) Set.empty
|
||||||
|
|
||||||
reorder :: LExpr -> State (Set.Set String) LExpr
|
reorder :: Expr -> State (Set.Set String) Expr
|
||||||
reorder (L s expr) =
|
reorder (A ann expr) =
|
||||||
L s <$>
|
A ann <$>
|
||||||
case expr of
|
case expr of
|
||||||
-- Be careful adding and restricting freeVars
|
-- Be careful adding and restricting freeVars
|
||||||
Var x -> free x >> return expr
|
Var (V.Raw x) -> free x >> return expr
|
||||||
|
|
||||||
Lambda p e ->
|
Lambda p e ->
|
||||||
uncurry Lambda <$> bindingReorder (p,e)
|
uncurry Lambda <$> bindingReorder (p,e)
|
||||||
|
@ -103,11 +104,11 @@ reorder (L s expr) =
|
||||||
bound (P.boundVars pattern)
|
bound (P.boundVars pattern)
|
||||||
mapM free (ctors pattern)
|
mapM free (ctors pattern)
|
||||||
|
|
||||||
let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
|
let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss
|
||||||
|
|
||||||
return let'
|
return let'
|
||||||
|
|
||||||
bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
|
bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
|
||||||
bindingReorder (pattern,expr) =
|
bindingReorder (pattern,expr) =
|
||||||
do expr' <- reorder expr
|
do expr' <- reorder expr
|
||||||
bound (P.boundVars pattern)
|
bound (P.boundVars pattern)
|
||||||
|
|
|
@ -2,14 +2,16 @@
|
||||||
module Transform.Substitute (subst) where
|
module Transform.Substitute (subst) where
|
||||||
|
|
||||||
import Control.Arrow (second, (***))
|
import Control.Arrow (second, (***))
|
||||||
import SourceSyntax.Expression
|
|
||||||
import SourceSyntax.Location
|
|
||||||
import qualified SourceSyntax.Pattern as Pattern
|
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
subst :: String -> Expr -> Expr -> Expr
|
import SourceSyntax.Annotation
|
||||||
|
import SourceSyntax.Expression
|
||||||
|
import qualified SourceSyntax.Pattern as Pattern
|
||||||
|
import qualified SourceSyntax.Variable as V
|
||||||
|
|
||||||
|
subst :: String -> Expr' -> Expr' -> Expr'
|
||||||
subst old new expr =
|
subst old new expr =
|
||||||
let f (L s e) = L s (subst old new e) in
|
let f (A a e) = A a (subst old new e) in
|
||||||
case expr of
|
case expr of
|
||||||
Range e1 e2 -> Range (f e1) (f e2)
|
Range e1 e2 -> Range (f e1) (f e2)
|
||||||
ExplicitList es -> ExplicitList (map f es)
|
ExplicitList es -> ExplicitList (map f es)
|
||||||
|
@ -28,7 +30,7 @@ subst old new expr =
|
||||||
anyShadow =
|
anyShadow =
|
||||||
any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
|
any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
|
||||||
|
|
||||||
Var x -> if x == old then new else expr
|
Var (V.Raw x) -> if x == old then new else expr
|
||||||
Case e cases -> Case (f e) $ map (second f) cases
|
Case e cases -> Case (f e) $ map (second f) cases
|
||||||
Data name es -> Data name (map f es)
|
Data name es -> Data name (map f es)
|
||||||
Access e x -> Access (f e) x
|
Access e x -> Access (f e) x
|
||||||
|
|
|
@ -1,62 +1,62 @@
|
||||||
{-# OPTIONS_GHC -Wall #-}
|
{-# OPTIONS_GHC -Wall #-}
|
||||||
module Type.Constrain.Declaration where
|
module Type.Constrain.Declaration where
|
||||||
|
|
||||||
import SourceSyntax.Declaration
|
import qualified SourceSyntax.Annotation as A
|
||||||
|
import qualified SourceSyntax.Declaration as D
|
||||||
import qualified SourceSyntax.Expression as E
|
import qualified SourceSyntax.Expression as E
|
||||||
import qualified SourceSyntax.Location as L
|
|
||||||
import qualified SourceSyntax.Pattern as P
|
import qualified SourceSyntax.Pattern as P
|
||||||
import qualified SourceSyntax.Type as T
|
import qualified SourceSyntax.Type as T
|
||||||
|
|
||||||
toExpr :: [Declaration] -> [E.Def]
|
toExpr :: [D.Declaration] -> [E.Def]
|
||||||
toExpr = concatMap toDefs
|
toExpr = concatMap toDefs
|
||||||
|
|
||||||
toDefs :: Declaration -> [E.Def]
|
toDefs :: D.Declaration -> [E.Def]
|
||||||
toDefs decl =
|
toDefs decl =
|
||||||
case decl of
|
case decl of
|
||||||
Definition def -> [def]
|
D.Definition def -> [def]
|
||||||
|
|
||||||
Datatype name tvars constructors -> concatMap toDefs' constructors
|
D.Datatype name tvars constructors -> concatMap toDefs' constructors
|
||||||
where
|
where
|
||||||
toDefs' (ctor, tipes) =
|
toDefs' (ctor, tipes) =
|
||||||
let vars = take (length tipes) arguments
|
let vars = take (length tipes) arguments
|
||||||
tbody = T.Data name $ map T.Var tvars
|
tbody = T.Data name $ map T.Var tvars
|
||||||
body = L.none . E.Data ctor $ map (L.none . E.Var) vars
|
body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars
|
||||||
in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
|
in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
|
||||||
|
|
||||||
TypeAlias name _ tipe@(T.Record fields ext) ->
|
D.TypeAlias name _ tipe@(T.Record fields ext) ->
|
||||||
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
|
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
|
||||||
where
|
where
|
||||||
args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
|
args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
|
||||||
|
|
||||||
var = L.none . E.Var
|
var = A.none . E.rawVar
|
||||||
vars = take (length args) arguments
|
vars = take (length args) arguments
|
||||||
|
|
||||||
efields = zip (map fst fields) (map var vars)
|
efields = zip (map fst fields) (map var vars)
|
||||||
record = case ext of
|
record = case ext of
|
||||||
Nothing -> L.none $ E.Record efields
|
Nothing -> A.none $ E.Record efields
|
||||||
Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
|
Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
|
||||||
|
|
||||||
-- Type aliases must be added to an extended equality dictionary,
|
-- Type aliases must be added to an extended equality dictionary,
|
||||||
-- but they do not require any basic constraints.
|
-- but they do not require any basic constraints.
|
||||||
TypeAlias _ _ _ -> []
|
D.TypeAlias _ _ _ -> []
|
||||||
|
|
||||||
Port port ->
|
D.Port port ->
|
||||||
case port of
|
case port of
|
||||||
Out name expr@(L.L s _) tipe ->
|
D.Out name expr@(A.A s _) tipe ->
|
||||||
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
|
[ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
|
||||||
In name tipe ->
|
D.In name tipe ->
|
||||||
[ definition name (L.none $ E.PortIn name tipe) tipe ]
|
[ definition name (A.none $ E.PortIn name tipe) tipe ]
|
||||||
|
|
||||||
-- no constraints are needed for fixity declarations
|
-- no constraints are needed for fixity declarations
|
||||||
Fixity _ _ _ -> []
|
D.Fixity _ _ _ -> []
|
||||||
|
|
||||||
|
|
||||||
arguments :: [String]
|
arguments :: [String]
|
||||||
arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
|
arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
|
||||||
|
|
||||||
buildFunction :: E.LExpr -> [String] -> E.LExpr
|
buildFunction :: E.Expr -> [String] -> E.Expr
|
||||||
buildFunction body@(L.L s _) vars =
|
buildFunction body@(A.A s _) vars =
|
||||||
foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
|
foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
|
||||||
|
|
||||||
definition :: String -> E.LExpr -> T.Type -> E.Def
|
definition :: String -> E.Expr -> T.Type -> E.Def
|
||||||
definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
|
definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)
|
||||||
|
|
|
@ -1,44 +1,45 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Type.Constrain.Expression where
|
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.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import qualified Control.Monad as Monad
|
import qualified Control.Monad as Monad
|
||||||
import Control.Monad.Error
|
import Control.Monad.Error
|
||||||
|
import qualified Data.List as List
|
||||||
|
import qualified Data.Map as Map
|
||||||
import qualified Text.PrettyPrint as PP
|
import qualified Text.PrettyPrint as PP
|
||||||
|
|
||||||
import SourceSyntax.Location as Loc
|
import SourceSyntax.Annotation as Ann
|
||||||
import SourceSyntax.Pattern (Pattern(PVar), boundVars)
|
|
||||||
import SourceSyntax.Expression
|
import SourceSyntax.Expression
|
||||||
import qualified SourceSyntax.Type as SrcT
|
import qualified SourceSyntax.Pattern as P
|
||||||
|
import qualified SourceSyntax.Type as ST
|
||||||
|
import qualified SourceSyntax.Variable as V
|
||||||
import Type.Type hiding (Descriptor(..))
|
import Type.Type hiding (Descriptor(..))
|
||||||
import Type.Fragment
|
import Type.Fragment
|
||||||
import qualified Type.Environment as Env
|
import qualified Type.Environment as Env
|
||||||
import qualified Type.Constrain.Literal as Literal
|
import qualified Type.Constrain.Literal as Literal
|
||||||
import qualified Type.Constrain.Pattern as Pattern
|
import qualified Type.Constrain.Pattern as Pattern
|
||||||
|
|
||||||
constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
|
constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
|
||||||
constrain env (L span expr) tipe =
|
constrain env (A region expr) tipe =
|
||||||
let list t = Env.get env Env.types "_List" <| t
|
let list t = Env.get env Env.types "_List" <| t
|
||||||
and = L span . CAnd
|
and = A region . CAnd
|
||||||
true = L span CTrue
|
true = A region CTrue
|
||||||
t1 === t2 = L span (CEqual t1 t2)
|
t1 === t2 = A region (CEqual t1 t2)
|
||||||
x <? t = L span (CInstance x t)
|
x <? t = A region (CInstance x t)
|
||||||
clet schemes c = L span (CLet schemes c)
|
clet schemes c = A region (CLet schemes c)
|
||||||
in
|
in
|
||||||
case expr of
|
case expr of
|
||||||
Literal lit -> liftIO $ Literal.constrain env span lit tipe
|
Literal lit -> liftIO $ Literal.constrain env region lit tipe
|
||||||
|
|
||||||
Var name | name == saveEnvName -> return (L span CSaveEnv)
|
Var (V.Raw name)
|
||||||
|
| name == saveEnvName -> return (A region CSaveEnv)
|
||||||
| otherwise -> return (name <? tipe)
|
| otherwise -> return (name <? tipe)
|
||||||
|
|
||||||
Range lo hi ->
|
Range lo hi ->
|
||||||
exists $ \x -> do
|
existsNumber $ \n -> do
|
||||||
clo <- constrain env lo x
|
clo <- constrain env lo n
|
||||||
chi <- constrain env hi x
|
chi <- constrain env hi n
|
||||||
return $ and [clo, chi, list x === tipe]
|
return $ and [clo, chi, list n === tipe]
|
||||||
|
|
||||||
ExplicitList exprs ->
|
ExplicitList exprs ->
|
||||||
exists $ \x -> do
|
exists $ \x -> do
|
||||||
|
@ -55,7 +56,7 @@ constrain env (L span expr) tipe =
|
||||||
Lambda p e ->
|
Lambda p e ->
|
||||||
exists $ \t1 ->
|
exists $ \t1 ->
|
||||||
exists $ \t2 -> do
|
exists $ \t2 -> do
|
||||||
fragment <- try span $ Pattern.constrain env p t1
|
fragment <- try region $ Pattern.constrain env p t1
|
||||||
c2 <- constrain env e t2
|
c2 <- constrain env e t2
|
||||||
let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
|
let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
|
||||||
(typeConstraint fragment /\ c2 ))
|
(typeConstraint fragment /\ c2 ))
|
||||||
|
@ -79,7 +80,7 @@ constrain env (L span expr) tipe =
|
||||||
exists $ \t -> do
|
exists $ \t -> do
|
||||||
ce <- constrain env exp t
|
ce <- constrain env exp t
|
||||||
let branch (p,e) = do
|
let branch (p,e) = do
|
||||||
fragment <- try span $ Pattern.constrain env p t
|
fragment <- try region $ Pattern.constrain env p t
|
||||||
clet [toScheme fragment] <$> constrain env e tipe
|
clet [toScheme fragment] <$> constrain env e tipe
|
||||||
and . (:) ce <$> mapM branch branches
|
and . (:) ce <$> mapM branch branches
|
||||||
|
|
||||||
|
@ -112,11 +113,11 @@ constrain env (L span expr) tipe =
|
||||||
Modify e fields ->
|
Modify e fields ->
|
||||||
exists $ \t -> do
|
exists $ \t -> do
|
||||||
oldVars <- forM fields $ \_ -> liftIO (var Flexible)
|
oldVars <- forM fields $ \_ -> liftIO (var Flexible)
|
||||||
let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
|
let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))
|
||||||
cOld <- ex oldVars <$> constrain env e (record oldFields t)
|
cOld <- ex oldVars <$> constrain env e (record oldFields t)
|
||||||
|
|
||||||
newVars <- forM fields $ \_ -> liftIO (var Flexible)
|
newVars <- forM fields $ \_ -> liftIO (var Flexible)
|
||||||
let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
|
let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))
|
||||||
let cNew = tipe === record newFields t
|
let cNew = tipe === record newFields t
|
||||||
|
|
||||||
cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
|
cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
|
||||||
|
@ -126,7 +127,7 @@ constrain env (L span expr) tipe =
|
||||||
Record fields ->
|
Record fields ->
|
||||||
do vars <- forM fields $ \_ -> liftIO (var Flexible)
|
do vars <- forM fields $ \_ -> liftIO (var Flexible)
|
||||||
cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
|
cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
|
||||||
let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
|
let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))
|
||||||
recordType = record fields' (TermN EmptyRecord1)
|
recordType = record fields' (TermN EmptyRecord1)
|
||||||
return . ex vars . and $ tipe === recordType : cs
|
return . ex vars . and $ tipe === recordType : cs
|
||||||
|
|
||||||
|
@ -158,14 +159,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =
|
||||||
do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
|
do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
|
||||||
-- Currently, qs is always [].
|
-- Currently, qs is always [].
|
||||||
case (pattern, maybeTipe) of
|
case (pattern, maybeTipe) of
|
||||||
(PVar name, Just tipe) -> do
|
(P.Var name, Just tipe) -> do
|
||||||
flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
|
flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
|
||||||
let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
|
let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
|
||||||
env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
|
env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
|
||||||
(vars, typ) <- Env.instantiateType env tipe Map.empty
|
(vars, typ) <- Env.instantiateType env tipe Map.empty
|
||||||
let scheme = Scheme { rigidQuantifiers = [],
|
let scheme = Scheme { rigidQuantifiers = [],
|
||||||
flexibleQuantifiers = flexiVars ++ vars,
|
flexibleQuantifiers = flexiVars ++ vars,
|
||||||
constraint = Loc.noneNoDocs CTrue,
|
constraint = Ann.noneNoDocs CTrue,
|
||||||
header = Map.singleton name typ }
|
header = Map.singleton name typ }
|
||||||
c <- constrain env' expr typ
|
c <- constrain env' expr typ
|
||||||
return ( scheme : schemes
|
return ( scheme : schemes
|
||||||
|
@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
|
||||||
, c2
|
, c2
|
||||||
, fl rigidVars c /\ c1 )
|
, fl rigidVars c /\ c1 )
|
||||||
|
|
||||||
(PVar name, Nothing) -> do
|
(P.Var name, Nothing) -> do
|
||||||
v <- liftIO $ var Flexible
|
v <- liftIO $ var Flexible
|
||||||
let tipe = VarN v
|
let tipe = VarN v
|
||||||
inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
|
inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
|
||||||
|
@ -191,19 +192,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =
|
||||||
_ -> error (show pattern)
|
_ -> error (show pattern)
|
||||||
|
|
||||||
expandPattern :: Def -> [Def]
|
expandPattern :: Def -> [Def]
|
||||||
expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
|
expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
|
||||||
case pattern of
|
case pattern of
|
||||||
PVar _ -> [def]
|
P.Var _ -> [def]
|
||||||
_ -> Definition (PVar x) lexpr maybeType : map toDef vars
|
_ -> Definition (P.Var x) lexpr maybeType : map toDef vars
|
||||||
where
|
where
|
||||||
vars = Set.toList $ boundVars pattern
|
vars = P.boundVarList pattern
|
||||||
x = "$" ++ concat vars
|
x = "$" ++ concat vars
|
||||||
mkVar = L s . Var
|
mkVar = A r . rawVar
|
||||||
toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
|
toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
|
||||||
|
|
||||||
try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
|
try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
|
||||||
try span computation = do
|
try region computation = do
|
||||||
result <- liftIO $ runErrorT computation
|
result <- liftIO $ runErrorT computation
|
||||||
case result of
|
case result of
|
||||||
Left err -> throwError [err span]
|
Left err -> throwError [err region]
|
||||||
Right value -> return value
|
Right value -> return value
|
||||||
|
|
|
@ -1,14 +1,15 @@
|
||||||
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Type.Constrain.Literal where
|
module Type.Constrain.Literal where
|
||||||
|
|
||||||
|
import SourceSyntax.Annotation
|
||||||
import SourceSyntax.Literal
|
import SourceSyntax.Literal
|
||||||
import SourceSyntax.Location
|
|
||||||
import Type.Type
|
import Type.Type
|
||||||
import Type.Environment as Env
|
import Type.Environment as Env
|
||||||
|
|
||||||
constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
|
constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
|
||||||
constrain env span literal tipe =
|
constrain env region literal tipe =
|
||||||
do tipe' <- litType
|
do tipe' <- litType
|
||||||
return . L span $ CEqual tipe tipe'
|
return . A region $ CEqual tipe tipe'
|
||||||
where
|
where
|
||||||
prim name = return (Env.get env Env.types name)
|
prim name = return (Env.get env Env.types name)
|
||||||
|
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# OPTIONS_GHC -W #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
module Type.Constrain.Pattern where
|
module Type.Constrain.Pattern where
|
||||||
|
|
||||||
|
@ -8,31 +9,29 @@ import Control.Monad.Error
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Text.PrettyPrint as PP
|
import qualified Text.PrettyPrint as PP
|
||||||
|
|
||||||
import SourceSyntax.Pattern
|
import qualified SourceSyntax.Annotation as A
|
||||||
import SourceSyntax.Location
|
import qualified SourceSyntax.Pattern as P
|
||||||
import SourceSyntax.PrettyPrint
|
import SourceSyntax.PrettyPrint (pretty)
|
||||||
import Text.PrettyPrint (render)
|
|
||||||
import qualified SourceSyntax.Location as Loc
|
|
||||||
import Type.Type
|
import Type.Type
|
||||||
import Type.Fragment
|
import Type.Fragment
|
||||||
import Type.Environment as Env
|
import Type.Environment as Env
|
||||||
import qualified Type.Constrain.Literal as Literal
|
import qualified Type.Constrain.Literal as Literal
|
||||||
|
|
||||||
|
|
||||||
constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
|
constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
|
||||||
constrain env pattern tipe =
|
constrain env pattern tipe =
|
||||||
let span = Loc.NoSpan (render $ pretty pattern)
|
let region = A.None (pretty pattern)
|
||||||
t1 === t2 = Loc.L span (CEqual t1 t2)
|
t1 === t2 = A.A region (CEqual t1 t2)
|
||||||
x <? t = Loc.L span (CInstance x t)
|
x <? t = A.A region (CInstance x t)
|
||||||
in
|
in
|
||||||
case pattern of
|
case pattern of
|
||||||
PAnything -> return emptyFragment
|
P.Anything -> return emptyFragment
|
||||||
|
|
||||||
PLiteral lit -> do
|
P.Literal lit -> do
|
||||||
c <- liftIO $ Literal.constrain env span lit tipe
|
c <- liftIO $ Literal.constrain env region lit tipe
|
||||||
return $ emptyFragment { typeConstraint = c }
|
return $ emptyFragment { typeConstraint = c }
|
||||||
|
|
||||||
PVar name -> do
|
P.Var name -> do
|
||||||
v <- liftIO $ var Flexible
|
v <- liftIO $ var Flexible
|
||||||
return $ Fragment {
|
return $ Fragment {
|
||||||
typeEnv = Map.singleton name (VarN v),
|
typeEnv = Map.singleton name (VarN v),
|
||||||
|
@ -40,14 +39,14 @@ constrain env pattern tipe =
|
||||||
typeConstraint = VarN v === tipe
|
typeConstraint = VarN v === tipe
|
||||||
}
|
}
|
||||||
|
|
||||||
PAlias name p -> do
|
P.Alias name p -> do
|
||||||
fragment <- constrain env p tipe
|
fragment <- constrain env p tipe
|
||||||
return $ fragment {
|
return $ fragment {
|
||||||
typeEnv = Map.insert name tipe (typeEnv fragment),
|
typeEnv = Map.insert name tipe (typeEnv fragment),
|
||||||
typeConstraint = name <? tipe /\ typeConstraint fragment
|
typeConstraint = name <? tipe /\ typeConstraint fragment
|
||||||
}
|
}
|
||||||
|
|
||||||
PData name patterns -> do
|
P.Data name patterns -> do
|
||||||
(kind, cvars, args, result) <- liftIO $ freshDataScheme env name
|
(kind, cvars, args, result) <- liftIO $ freshDataScheme env name
|
||||||
let msg = concat [ "Constructor '", name, "' expects ", show kind
|
let msg = concat [ "Constructor '", name, "' expects ", show kind
|
||||||
, " argument", if kind == 1 then "" else "s"
|
, " argument", if kind == 1 then "" else "s"
|
||||||
|
@ -63,7 +62,7 @@ constrain env pattern tipe =
|
||||||
vars = cvars ++ vars fragment
|
vars = cvars ++ vars fragment
|
||||||
}
|
}
|
||||||
|
|
||||||
PRecord fields -> do
|
P.Record fields -> do
|
||||||
pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
|
pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
|
||||||
let tenv = Map.fromList (map (second VarN) pairs)
|
let tenv = Map.fromList (map (second VarN) pairs)
|
||||||
c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
|
c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
|
||||||
|
@ -73,7 +72,7 @@ constrain env pattern tipe =
|
||||||
typeConstraint = c
|
typeConstraint = c
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Error (SrcSpan -> PP.Doc) where
|
instance Error (A.Region -> PP.Doc) where
|
||||||
noMsg _ = PP.empty
|
noMsg _ = PP.empty
|
||||||
strMsg str span =
|
strMsg str span =
|
||||||
PP.vcat [ PP.text $ "Type error " ++ show span
|
PP.vcat [ PP.text $ "Type error " ++ show span
|
||||||
|
|
|
@ -1,32 +1,35 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
|
|
||||||
|
{-| 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 (mainType, occurs, portTypes) where
|
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.
|
|
||||||
|
|
||||||
import Control.Applicative ((<$>),(<*>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import qualified Data.List as List
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
import qualified Data.Traversable as Traverse
|
||||||
import qualified Data.UnionFind.IO as UF
|
import qualified Data.UnionFind.IO as UF
|
||||||
import Type.Type ( Variable, structure, Term1(..), toSrcType )
|
import Text.PrettyPrint as P
|
||||||
|
|
||||||
|
import qualified SourceSyntax.Annotation as A
|
||||||
|
import qualified SourceSyntax.Expression as E
|
||||||
|
import qualified SourceSyntax.Helpers as Help
|
||||||
|
import qualified SourceSyntax.PrettyPrint as SPP
|
||||||
|
import qualified SourceSyntax.Type as ST
|
||||||
|
import qualified Transform.Expression as Expr
|
||||||
|
import qualified Type.Type as TT
|
||||||
import qualified Type.State as TS
|
import qualified Type.State as TS
|
||||||
import qualified Type.Alias as Alias
|
import qualified Type.Alias as Alias
|
||||||
import Text.PrettyPrint as P
|
|
||||||
import SourceSyntax.PrettyPrint (pretty)
|
|
||||||
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
|
|
||||||
|
|
||||||
throw err = Left [ P.vcat err ]
|
throw err = Left [ P.vcat err ]
|
||||||
|
|
||||||
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
|
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
|
||||||
mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
|
mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
|
||||||
where
|
where
|
||||||
mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
|
mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)
|
||||||
mainCheck rules env =
|
mainCheck rules env =
|
||||||
case Map.lookup "main" env of
|
case Map.lookup "main" env of
|
||||||
Nothing -> Right env
|
Nothing -> Right env
|
||||||
|
@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
|
||||||
acceptable = [ "Graphics.Element.Element"
|
acceptable = [ "Graphics.Element.Element"
|
||||||
, "Signal.Signal Graphics.Element.Element" ]
|
, "Signal.Signal Graphics.Element.Element" ]
|
||||||
|
|
||||||
tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
|
tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
|
||||||
err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
|
err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
|
||||||
, P.text "Instead 'main' has type:\n"
|
, P.text "Instead 'main' has type:\n"
|
||||||
, P.nest 4 . pretty $ Alias.realias rules mainType
|
, P.nest 4 . SPP.pretty $ Alias.realias rules mainType
|
||||||
, P.text " " ]
|
, P.text " " ]
|
||||||
|
|
||||||
data Direction = In | Out
|
data Direction = In | Out
|
||||||
|
|
||||||
portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
|
portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
|
||||||
portTypes rules expr =
|
portTypes rules expr =
|
||||||
const () <$> Expr.checkPorts (check In) (check Out) expr
|
const () <$> Expr.checkPorts (check In) (check Out) expr
|
||||||
where
|
where
|
||||||
check = isValid True False False
|
check = isValid True False False
|
||||||
isValid isTopLevel seenFunc seenSignal direction name tipe =
|
isValid isTopLevel seenFunc seenSignal direction name tipe =
|
||||||
case tipe of
|
case tipe of
|
||||||
T.Data ctor ts
|
ST.Data ctor ts
|
||||||
| isJs ctor || isElm ctor -> mapM_ valid ts
|
| isJs ctor || isElm ctor -> mapM_ valid ts
|
||||||
| ctor == "Signal.Signal" -> handleSignal ts
|
| ctor == "Signal.Signal" -> handleSignal ts
|
||||||
| otherwise -> err' True "an unsupported type"
|
| otherwise -> err' True "an unsupported type"
|
||||||
|
|
||||||
T.Var _ -> err "free type variables"
|
ST.Var _ -> err "free type variables"
|
||||||
|
|
||||||
T.Lambda _ _ ->
|
ST.Lambda _ _ ->
|
||||||
case direction of
|
case direction of
|
||||||
In -> err "functions"
|
In -> err "functions"
|
||||||
Out | seenFunc -> err "higher-order functions"
|
Out | seenFunc -> err "higher-order functions"
|
||||||
| seenSignal -> err "signals that contain functions"
|
| seenSignal -> err "signals that contain functions"
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
forM_ (T.collectLambdas tipe)
|
forM_ (ST.collectLambdas tipe)
|
||||||
(isValid' True seenSignal direction name)
|
(isValid' True seenSignal direction name)
|
||||||
|
|
||||||
T.Record _ (Just _) -> err "extended records with free type variables"
|
ST.Record _ (Just _) -> err "extended records with free type variables"
|
||||||
|
|
||||||
T.Record fields Nothing ->
|
ST.Record fields Nothing ->
|
||||||
mapM_ (\(k,v) -> (,) k <$> valid v) fields
|
mapM_ (\(k,v) -> (,) k <$> valid v) fields
|
||||||
|
|
||||||
where
|
where
|
||||||
|
@ -100,7 +103,7 @@ portTypes rules expr =
|
||||||
[ txt [ "Type Error: the value ", dir "coming in" "sent out"
|
[ txt [ "Type Error: the value ", dir "coming in" "sent out"
|
||||||
, " through port '", name, "' is invalid." ]
|
, " through port '", name, "' is invalid." ]
|
||||||
, txt [ "It contains ", kind, ":\n" ]
|
, txt [ "It contains ", kind, ":\n" ]
|
||||||
, (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
|
, (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
|
||||||
, txt [ "Acceptable values for ", dir "incoming" "outgoing"
|
, txt [ "Acceptable values for ", dir "incoming" "outgoing"
|
||||||
, " ports include JavaScript values and" ]
|
, " ports include JavaScript values and" ]
|
||||||
, txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
|
, txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
|
||||||
|
@ -112,37 +115,37 @@ portTypes rules expr =
|
||||||
, txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
|
, 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 :: (String, TT.Variable) -> StateT TS.SolverState IO ()
|
||||||
occurs (name, variable) =
|
occurs (name, variable) =
|
||||||
do vars <- liftIO $ infiniteVars [] variable
|
do vars <- liftIO $ infiniteVars [] variable
|
||||||
case vars of
|
case vars of
|
||||||
[] -> return ()
|
[] -> return ()
|
||||||
var:_ -> do
|
var:_ -> do
|
||||||
desc <- liftIO $ UF.descriptor var
|
desc <- liftIO $ UF.descriptor var
|
||||||
case structure desc of
|
case TT.structure desc of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
|
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
|
||||||
Just _ ->
|
Just _ ->
|
||||||
do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
|
do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
|
||||||
var' <- liftIO $ UF.fresh desc
|
var' <- liftIO $ UF.fresh desc
|
||||||
TS.addError (L.NoSpan name) (Just msg) var var'
|
TS.addError (A.None (P.text name)) (Just msg) var var'
|
||||||
where
|
where
|
||||||
msg = "Infinite types are not allowed"
|
msg = "Infinite types are not allowed"
|
||||||
fallback _ = return $ P.text msg
|
fallback _ = return $ P.text msg
|
||||||
|
|
||||||
infiniteVars :: [Variable] -> Variable -> IO [Variable]
|
infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
|
||||||
infiniteVars seen var =
|
infiniteVars seen var =
|
||||||
let go = infiniteVars (var:seen) in
|
let go = infiniteVars (var:seen) in
|
||||||
if var `elem` seen
|
if var `elem` seen
|
||||||
then return [var]
|
then return [var]
|
||||||
else do
|
else do
|
||||||
desc <- UF.descriptor var
|
desc <- UF.descriptor var
|
||||||
case structure desc of
|
case TT.structure desc of
|
||||||
Nothing -> return []
|
Nothing -> return []
|
||||||
Just struct ->
|
Just struct ->
|
||||||
case struct of
|
case struct of
|
||||||
App1 a b -> (++) <$> go a <*> go b
|
TT.App1 a b -> (++) <$> go a <*> go b
|
||||||
Fun1 a b -> (++) <$> go a <*> go b
|
TT.Fun1 a b -> (++) <$> go a <*> go b
|
||||||
Var1 a -> go a
|
TT.Var1 a -> go a
|
||||||
EmptyRecord1 -> return []
|
TT.EmptyRecord1 -> return []
|
||||||
Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
|
TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
|
||||||
|
|
|
@ -5,24 +5,23 @@ import qualified Data.Map as Map
|
||||||
|
|
||||||
import Type.Type
|
import Type.Type
|
||||||
import SourceSyntax.Pattern
|
import SourceSyntax.Pattern
|
||||||
import SourceSyntax.Location (noneNoDocs)
|
import SourceSyntax.Annotation (noneNoDocs)
|
||||||
|
|
||||||
data Fragment = Fragment {
|
data Fragment = Fragment
|
||||||
typeEnv :: Map.Map String Type,
|
{ typeEnv :: Map.Map String Type
|
||||||
vars :: [Variable],
|
, vars :: [Variable]
|
||||||
typeConstraint :: TypeConstraint
|
, typeConstraint :: TypeConstraint
|
||||||
} deriving Show
|
} deriving Show
|
||||||
|
|
||||||
emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
|
emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
|
||||||
|
|
||||||
joinFragment f1 f2 = Fragment {
|
joinFragment f1 f2 = Fragment
|
||||||
typeEnv = Map.union (typeEnv f1) (typeEnv f2),
|
{ typeEnv = Map.union (typeEnv f1) (typeEnv f2)
|
||||||
vars = vars f1 ++ vars f2,
|
, vars = vars f1 ++ vars f2
|
||||||
typeConstraint = typeConstraint f1 /\ typeConstraint f2
|
, typeConstraint = typeConstraint f1 /\ typeConstraint f2
|
||||||
}
|
}
|
||||||
|
|
||||||
joinFragments = List.foldl' (flip joinFragment) emptyFragment
|
joinFragments = List.foldl' (flip joinFragment) emptyFragment
|
||||||
|
|
||||||
|
|
||||||
toScheme fragment =
|
toScheme fragment =
|
||||||
Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
|
Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
|
|
@ -9,7 +9,7 @@ import qualified Type.Constrain.Expression as TcExpr
|
||||||
import qualified Type.Solve as Solve
|
import qualified Type.Solve as Solve
|
||||||
|
|
||||||
import SourceSyntax.Module as Module
|
import SourceSyntax.Module as Module
|
||||||
import SourceSyntax.Location (noneNoDocs)
|
import SourceSyntax.Annotation (noneNoDocs)
|
||||||
import SourceSyntax.Type (Type)
|
import SourceSyntax.Type (Type)
|
||||||
import Text.PrettyPrint
|
import Text.PrettyPrint
|
||||||
import qualified Type.State as TS
|
import qualified Type.State as TS
|
||||||
|
|
|
@ -3,15 +3,15 @@ module Type.Solve (solve) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import qualified Data.UnionFind.IO as UF
|
import qualified Data.List as List
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Traversable as Traversable
|
import qualified Data.Traversable as Traversable
|
||||||
import qualified Data.List as List
|
import qualified Data.UnionFind.IO as UF
|
||||||
import Type.Type
|
import Type.Type
|
||||||
import Type.Unify
|
import Type.Unify
|
||||||
import qualified Type.ExtraChecks as Check
|
import qualified Type.ExtraChecks as Check
|
||||||
import qualified Type.State as TS
|
import qualified Type.State as TS
|
||||||
import SourceSyntax.Location (Located(L), SrcSpan)
|
import qualified SourceSyntax.Annotation as A
|
||||||
|
|
||||||
|
|
||||||
-- | Every variable has rank less than or equal to the maxRank of the pool.
|
-- | Every variable has rank less than or equal to the maxRank of the pool.
|
||||||
|
@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
|
||||||
|
|
||||||
|
|
||||||
solve :: TypeConstraint -> StateT TS.SolverState IO ()
|
solve :: TypeConstraint -> StateT TS.SolverState IO ()
|
||||||
solve (L span constraint) =
|
solve (A.A region constraint) =
|
||||||
case constraint of
|
case constraint of
|
||||||
CTrue -> return ()
|
CTrue -> return ()
|
||||||
|
|
||||||
|
@ -105,11 +105,11 @@ solve (L span constraint) =
|
||||||
CEqual term1 term2 -> do
|
CEqual term1 term2 -> do
|
||||||
t1 <- TS.flatten term1
|
t1 <- TS.flatten term1
|
||||||
t2 <- TS.flatten term2
|
t2 <- TS.flatten term2
|
||||||
unify span t1 t2
|
unify region t1 t2
|
||||||
|
|
||||||
CAnd cs -> mapM_ solve cs
|
CAnd cs -> mapM_ solve cs
|
||||||
|
|
||||||
CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
|
CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
|
||||||
oldEnv <- TS.getEnv
|
oldEnv <- TS.getEnv
|
||||||
mapM TS.introduce fqs
|
mapM TS.introduce fqs
|
||||||
solve constraint'
|
solve constraint'
|
||||||
|
@ -117,7 +117,7 @@ solve (L span constraint) =
|
||||||
|
|
||||||
CLet schemes constraint' -> do
|
CLet schemes constraint' -> do
|
||||||
oldEnv <- TS.getEnv
|
oldEnv <- TS.getEnv
|
||||||
headers <- Map.unions `fmap` mapM (solveScheme span) schemes
|
headers <- Map.unions `fmap` mapM (solveScheme region) schemes
|
||||||
TS.modifyEnv $ \env -> Map.union headers env
|
TS.modifyEnv $ \env -> Map.union headers env
|
||||||
solve constraint'
|
solve constraint'
|
||||||
mapM Check.occurs $ Map.toList headers
|
mapM Check.occurs $ Map.toList headers
|
||||||
|
@ -134,10 +134,10 @@ solve (L span constraint) =
|
||||||
error ("Could not find '" ++ name ++ "' when solving type constraints.")
|
error ("Could not find '" ++ name ++ "' when solving type constraints.")
|
||||||
|
|
||||||
t <- TS.flatten term
|
t <- TS.flatten term
|
||||||
unify span freshCopy t
|
unify region freshCopy t
|
||||||
|
|
||||||
solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
|
solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
|
||||||
solveScheme span scheme =
|
solveScheme region scheme =
|
||||||
case scheme of
|
case scheme of
|
||||||
Scheme [] [] constraint header -> do
|
Scheme [] [] constraint header -> do
|
||||||
solve constraint
|
solve constraint
|
||||||
|
@ -154,39 +154,39 @@ solveScheme span scheme =
|
||||||
header' <- Traversable.traverse TS.flatten header
|
header' <- Traversable.traverse TS.flatten header
|
||||||
solve constraint
|
solve constraint
|
||||||
|
|
||||||
allDistinct span rigidQuantifiers
|
allDistinct region rigidQuantifiers
|
||||||
youngPool <- TS.getPool
|
youngPool <- TS.getPool
|
||||||
TS.switchToPool oldPool
|
TS.switchToPool oldPool
|
||||||
generalize youngPool
|
generalize youngPool
|
||||||
mapM (isGeneric span) rigidQuantifiers
|
mapM (isGeneric region) rigidQuantifiers
|
||||||
return header'
|
return header'
|
||||||
|
|
||||||
|
|
||||||
-- Checks that all of the given variables belong to distinct equivalence classes.
|
-- Checks that all of the given variables belong to distinct equivalence classes.
|
||||||
-- Also checks that their structure is Nothing, so they represent a variable, not
|
-- Also checks that their structure is Nothing, so they represent a variable, not
|
||||||
-- a more complex term.
|
-- a more complex term.
|
||||||
allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
|
allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
|
||||||
allDistinct span vars = do
|
allDistinct region vars = do
|
||||||
seen <- TS.uniqueMark
|
seen <- TS.uniqueMark
|
||||||
let check var = do
|
let check var = do
|
||||||
desc <- liftIO $ UF.descriptor var
|
desc <- liftIO $ UF.descriptor var
|
||||||
case structure desc of
|
case structure desc of
|
||||||
Just _ -> TS.addError span (Just msg) var var
|
Just _ -> TS.addError region (Just msg) var var
|
||||||
where msg = "Cannot generalize something that is not a type variable."
|
where msg = "Cannot generalize something that is not a type variable."
|
||||||
|
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
if mark desc == seen
|
if mark desc == seen
|
||||||
then let msg = "Duplicate variable during generalization."
|
then let msg = "Duplicate variable during generalization."
|
||||||
in TS.addError span (Just msg) var var
|
in TS.addError region (Just msg) var var
|
||||||
else return ()
|
else return ()
|
||||||
liftIO $ UF.setDescriptor var (desc { mark = seen })
|
liftIO $ UF.setDescriptor var (desc { mark = seen })
|
||||||
mapM_ check vars
|
mapM_ check vars
|
||||||
|
|
||||||
-- Check that a variable has rank == noRank, meaning that it can be generalized.
|
-- Check that a variable has rank == noRank, meaning that it can be generalized.
|
||||||
isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
|
isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
|
||||||
isGeneric span var = do
|
isGeneric region var = do
|
||||||
desc <- liftIO $ UF.descriptor var
|
desc <- liftIO $ UF.descriptor var
|
||||||
if rank desc == noRank
|
if rank desc == noRank
|
||||||
then return ()
|
then return ()
|
||||||
else let msg = "Unable to generalize a type variable. It is not unranked."
|
else let msg = "Unable to generalize a type variable. It is not unranked."
|
||||||
in TS.addError span (Just msg) var var
|
in TS.addError region (Just msg) var var
|
||||||
|
|
|
@ -1,16 +1,17 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Type.State where
|
module Type.State where
|
||||||
|
|
||||||
import Type.Type
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import qualified Data.UnionFind.IO as UF
|
|
||||||
import Control.Monad.State
|
|
||||||
import Control.Applicative ((<$>),(<*>), Applicative)
|
import Control.Applicative ((<$>),(<*>), Applicative)
|
||||||
|
import Control.Monad.State
|
||||||
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Traversable as Traversable
|
import qualified Data.Traversable as Traversable
|
||||||
import Text.PrettyPrint as P
|
import qualified Data.UnionFind.IO as UF
|
||||||
|
|
||||||
|
import qualified SourceSyntax.Annotation as A
|
||||||
import SourceSyntax.PrettyPrint
|
import SourceSyntax.PrettyPrint
|
||||||
import SourceSyntax.Location
|
import Text.PrettyPrint as P
|
||||||
import qualified Type.Alias as Alias
|
import qualified Type.Alias as Alias
|
||||||
|
import Type.Type
|
||||||
|
|
||||||
-- Pool
|
-- Pool
|
||||||
-- Holds a bunch of variables
|
-- Holds a bunch of variables
|
||||||
|
@ -46,7 +47,7 @@ initialState = SS {
|
||||||
modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
|
modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
|
||||||
modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
|
modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
|
||||||
|
|
||||||
addError span hint t1 t2 =
|
addError region hint t1 t2 =
|
||||||
modify $ \state -> state { sErrors = makeError : sErrors state }
|
modify $ \state -> state { sErrors = makeError : sErrors state }
|
||||||
where
|
where
|
||||||
makeError rules = do
|
makeError rules = do
|
||||||
|
@ -54,24 +55,15 @@ addError span hint t1 t2 =
|
||||||
t1' <- prettiest <$> toSrcType t1
|
t1' <- prettiest <$> toSrcType t1
|
||||||
t2' <- prettiest <$> toSrcType t2
|
t2' <- prettiest <$> toSrcType t2
|
||||||
return . P.vcat $
|
return . P.vcat $
|
||||||
[ P.text $ "Type error" ++ location ++ ":"
|
[ P.text "Type error" <+> pretty region <> P.colon
|
||||||
, maybe P.empty P.text hint
|
, maybe P.empty P.text hint
|
||||||
, display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
|
, P.text ""
|
||||||
|
, P.nest 8 $ A.getRegionDocs region
|
||||||
|
, P.text ""
|
||||||
, P.text " Expected Type:" <+> t1'
|
, P.text " Expected Type:" <+> t1'
|
||||||
, P.text " Actual Type:" <+> t2'
|
, P.text " Actual Type:" <+> t2'
|
||||||
]
|
]
|
||||||
|
|
||||||
location = case span of
|
|
||||||
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)
|
|
||||||
|
|
||||||
display msg =
|
|
||||||
P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
|
|
||||||
, P.text " " ]
|
|
||||||
|
|
||||||
|
|
||||||
switchToPool pool = modifyPool (\_ -> pool)
|
switchToPool pool = modifyPool (\_ -> pool)
|
||||||
|
|
||||||
getPool :: StateT SolverState IO Pool
|
getPool :: StateT SolverState IO Pool
|
||||||
|
|
|
@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Monad.Error
|
import Control.Monad.Error
|
||||||
import Data.Traversable (traverse)
|
import Data.Traversable (traverse)
|
||||||
import SourceSyntax.Location
|
import SourceSyntax.Annotation
|
||||||
import SourceSyntax.Helpers (isTuple)
|
import SourceSyntax.Helpers (isTuple)
|
||||||
import qualified SourceSyntax.Type as Src
|
import qualified SourceSyntax.Type as Src
|
||||||
|
|
||||||
|
@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
|
||||||
infixl 8 /\
|
infixl 8 /\
|
||||||
|
|
||||||
(/\) :: Constraint a b -> Constraint a b -> Constraint a b
|
(/\) :: Constraint a b -> Constraint a b -> Constraint a b
|
||||||
a@(L _ c1) /\ b@(L _ c2) =
|
a@(A _ c1) /\ b@(A _ c2) =
|
||||||
case (c1, c2) of
|
case (c1, c2) of
|
||||||
(CTrue, _) -> b
|
(CTrue, _) -> b
|
||||||
(_, CTrue) -> a
|
(_, CTrue) -> a
|
||||||
|
@ -128,17 +128,24 @@ structuredVar structure = UF.fresh $ Descriptor {
|
||||||
|
|
||||||
-- ex qs constraint == exists qs. constraint
|
-- ex qs constraint == exists qs. constraint
|
||||||
ex :: [Variable] -> TypeConstraint -> TypeConstraint
|
ex :: [Variable] -> TypeConstraint -> TypeConstraint
|
||||||
ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
|
ex fqs constraint@(A ann _) =
|
||||||
|
A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
|
||||||
|
|
||||||
-- fl qs constraint == forall qs. constraint
|
-- fl qs constraint == forall qs. constraint
|
||||||
fl :: [Variable] -> TypeConstraint -> TypeConstraint
|
fl :: [Variable] -> TypeConstraint -> TypeConstraint
|
||||||
fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
|
fl rqs constraint@(A ann _) =
|
||||||
|
A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
|
||||||
|
|
||||||
exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
|
exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
|
||||||
exists f = do
|
exists f = do
|
||||||
v <- liftIO $ var Flexible
|
v <- liftIO $ var Flexible
|
||||||
ex [v] <$> f (VarN v)
|
ex [v] <$> f (VarN v)
|
||||||
|
|
||||||
|
existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
|
||||||
|
existsNumber f = do
|
||||||
|
v <- liftIO $ var (Is Number)
|
||||||
|
ex [v] <$> f (VarN v)
|
||||||
|
|
||||||
|
|
||||||
instance Show a => Show (UF.Point a) where
|
instance Show a => Show (UF.Point a) where
|
||||||
show point = unsafePerformIO $ fmap show (UF.descriptor point)
|
show point = unsafePerformIO $ fmap show (UF.descriptor point)
|
||||||
|
@ -148,8 +155,8 @@ instance PrettyType a => PrettyType (UF.Point a) where
|
||||||
pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
|
pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
|
||||||
|
|
||||||
|
|
||||||
instance PrettyType a => PrettyType (Located a) where
|
instance PrettyType t => PrettyType (Annotated a t) where
|
||||||
pretty when (L _ e) = pretty when e
|
pretty when (A _ e) = pretty when e
|
||||||
|
|
||||||
|
|
||||||
instance PrettyType a => PrettyType (Term1 a) where
|
instance PrettyType a => PrettyType (Term1 a) where
|
||||||
|
@ -212,12 +219,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
|
||||||
CAnd cs ->
|
CAnd cs ->
|
||||||
P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
|
P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
|
||||||
|
|
||||||
CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
|
CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
|
||||||
P.sep [ binder, pretty Never c ]
|
P.sep [ binder, pretty Never c ]
|
||||||
where
|
where
|
||||||
mergeExists vs (L _ c) =
|
mergeExists vs (A _ c) =
|
||||||
case c of
|
case c of
|
||||||
CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'
|
CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
|
||||||
_ -> (vs, c)
|
_ -> (vs, c)
|
||||||
|
|
||||||
(fqs', c) = mergeExists fqs constraint
|
(fqs', c) = mergeExists fqs constraint
|
||||||
|
@ -233,7 +240,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
|
||||||
P.text name <+> P.text "<" <+> prty tipe
|
P.text name <+> P.text "<" <+> prty tipe
|
||||||
|
|
||||||
instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
|
instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
|
||||||
pretty _ (Scheme rqs fqs (L _ constraint) headers) =
|
pretty _ (Scheme rqs fqs (A _ constraint) headers) =
|
||||||
P.sep [ forall, cs, headers' ]
|
P.sep [ forall, cs, headers' ]
|
||||||
where
|
where
|
||||||
prty = pretty Never
|
prty = pretty Never
|
||||||
|
@ -297,8 +304,8 @@ class Crawl t where
|
||||||
-> t
|
-> t
|
||||||
-> StateT CrawlState IO t
|
-> StateT CrawlState IO t
|
||||||
|
|
||||||
instance Crawl a => Crawl (Located a) where
|
instance Crawl e => Crawl (Annotated a e) where
|
||||||
crawl nextState (L s e) = L s <$> crawl nextState e
|
crawl nextState (A ann e) = A ann <$> crawl nextState e
|
||||||
|
|
||||||
instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
|
instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
|
||||||
crawl nextState constraint =
|
crawl nextState constraint =
|
||||||
|
|
|
@ -1,27 +1,27 @@
|
||||||
{-# OPTIONS_GHC -W #-}
|
{-# OPTIONS_GHC -W #-}
|
||||||
module Type.Unify (unify) where
|
module Type.Unify (unify) where
|
||||||
|
|
||||||
import Type.Type
|
import Control.Monad.State
|
||||||
import qualified Data.UnionFind.IO as UF
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Maybe as Maybe
|
import qualified Data.Maybe as Maybe
|
||||||
|
import qualified Data.UnionFind.IO as UF
|
||||||
|
import qualified SourceSyntax.Annotation as A
|
||||||
import qualified Type.State as TS
|
import qualified Type.State as TS
|
||||||
import Control.Monad.State
|
import Type.Type
|
||||||
import SourceSyntax.Location
|
|
||||||
import Type.PrettyPrint
|
import Type.PrettyPrint
|
||||||
import Text.PrettyPrint (render)
|
import Text.PrettyPrint (render)
|
||||||
|
|
||||||
unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
|
unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
|
||||||
unify span variable1 variable2 = do
|
unify region variable1 variable2 = do
|
||||||
equivalent <- liftIO $ UF.equivalent variable1 variable2
|
equivalent <- liftIO $ UF.equivalent variable1 variable2
|
||||||
if equivalent then return ()
|
if equivalent then return ()
|
||||||
else actuallyUnify span variable1 variable2
|
else actuallyUnify region variable1 variable2
|
||||||
|
|
||||||
actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
|
actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
|
||||||
actuallyUnify span variable1 variable2 = do
|
actuallyUnify region variable1 variable2 = do
|
||||||
desc1 <- liftIO $ UF.descriptor variable1
|
desc1 <- liftIO $ UF.descriptor variable1
|
||||||
desc2 <- liftIO $ UF.descriptor variable2
|
desc2 <- liftIO $ UF.descriptor variable2
|
||||||
let unify' = unify span
|
let unify' = unify region
|
||||||
|
|
||||||
name' :: Maybe String
|
name' :: Maybe String
|
||||||
name' = case (name desc1, name desc2) of
|
name' = case (name desc1, name desc2) of
|
||||||
|
@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
|
||||||
|
|
||||||
unifyNumber svar name
|
unifyNumber svar name
|
||||||
| name `elem` ["Int","Float","number"] = flexAndUnify svar
|
| name `elem` ["Int","Float","number"] = flexAndUnify svar
|
||||||
| otherwise = TS.addError span (Just hint) variable1 variable2
|
| otherwise = TS.addError region (Just hint) variable1 variable2
|
||||||
where hint = "A number must be an Int or Float."
|
where hint = "A number must be an Int or Float."
|
||||||
|
|
||||||
comparableError maybe =
|
comparableError maybe =
|
||||||
TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
|
TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
|
||||||
where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
|
where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
|
||||||
|
|
||||||
unifyComparable var name
|
unifyComparable var name
|
||||||
|
@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
|
||||||
List _ -> flexAndUnify varSuper
|
List _ -> flexAndUnify varSuper
|
||||||
_ -> comparableError Nothing
|
_ -> comparableError Nothing
|
||||||
|
|
||||||
rigidError variable = TS.addError span (Just hint) variable1 variable2
|
rigidError variable = TS.addError region (Just hint) variable1 variable2
|
||||||
where
|
where
|
||||||
var = "'" ++ render (pretty Never variable) ++ "'"
|
var = "'" ++ render (pretty Never variable) ++ "'"
|
||||||
hint = "Cannot unify rigid type variable " ++ var ++
|
hint = "Cannot unify rigid type variable " ++ var ++
|
||||||
|
@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
|
||||||
|
|
||||||
(Rigid, _, _, _) -> rigidError variable1
|
(Rigid, _, _, _) -> rigidError variable1
|
||||||
(_, Rigid, _, _) -> rigidError variable2
|
(_, Rigid, _, _) -> rigidError variable2
|
||||||
_ -> TS.addError span Nothing variable1 variable2
|
_ -> TS.addError region Nothing variable1 variable2
|
||||||
|
|
||||||
case (structure desc1, structure desc2) of
|
case (structure desc1, structure desc2) of
|
||||||
(Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
|
(Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
|
||||||
|
@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do
|
||||||
eat (_:xs) (_:ys) = eat xs ys
|
eat (_:xs) (_:ys) = eat xs ys
|
||||||
eat xs _ = xs
|
eat xs _ = xs
|
||||||
|
|
||||||
_ -> TS.addError span Nothing variable1 variable2
|
_ -> TS.addError region Nothing variable1 variable2
|
||||||
|
|
||||||
|
|
|
@ -1,123 +0,0 @@
|
||||||
module Automaton ( pure, state, hiddenState, run, step
|
|
||||||
, (<<<), (>>>), combine, count, average
|
|
||||||
) where
|
|
||||||
|
|
||||||
{-| This library is a way to package up dynamic behavior. It makes it easier to
|
|
||||||
dynamically create dynamic components. See the [original release
|
|
||||||
notes](http://elm-lang.org/blog/announce/0.5.0.elm) on this library to get a feel for how
|
|
||||||
it can be used.
|
|
||||||
|
|
||||||
# Create
|
|
||||||
@docs pure, state, hiddenState
|
|
||||||
|
|
||||||
# Evaluate
|
|
||||||
@docs run, step
|
|
||||||
|
|
||||||
# Combine
|
|
||||||
@docs (>>>), (<<<), combine
|
|
||||||
|
|
||||||
# Common Automatons
|
|
||||||
@docs count, average
|
|
||||||
-}
|
|
||||||
|
|
||||||
import open Basics
|
|
||||||
import Signal (lift,foldp,Signal)
|
|
||||||
import open List
|
|
||||||
import Maybe (Just, Nothing)
|
|
||||||
|
|
||||||
data Automaton a b = Step (a -> (Automaton a b, b))
|
|
||||||
|
|
||||||
{-| Run an automaton on a given signal. The automaton steps forward whenever the
|
|
||||||
input signal updates.
|
|
||||||
-}
|
|
||||||
run : Automaton a b -> b -> Signal a -> Signal b
|
|
||||||
run auto base inputs =
|
|
||||||
let step a (Step f, _) = f a
|
|
||||||
in lift (\(x,y) -> y) (foldp step (auto,base) inputs)
|
|
||||||
|
|
||||||
{-| Step an automaton forward once with a given input. -}
|
|
||||||
step : a -> Automaton a b -> (Automaton a b, b)
|
|
||||||
step a (Step f) = f a
|
|
||||||
|
|
||||||
{-| Compose two automatons, chaining them together. -}
|
|
||||||
(>>>) : Automaton a b -> Automaton b c -> Automaton a c
|
|
||||||
f >>> g =
|
|
||||||
Step (\a -> let (f', b) = step a f
|
|
||||||
(g', c) = step b g
|
|
||||||
in (f' >>> g', c))
|
|
||||||
|
|
||||||
{-| Compose two automatons, chaining them together. -}
|
|
||||||
(<<<) : Automaton b c -> Automaton a b -> Automaton a c
|
|
||||||
g <<< f = f >>> g
|
|
||||||
|
|
||||||
{-| Combine a list of automatons into a single automaton that produces a
|
|
||||||
list.
|
|
||||||
-}
|
|
||||||
combine : [Automaton a b] -> Automaton a [b]
|
|
||||||
combine autos =
|
|
||||||
Step (\a -> let (autos', bs) = unzip (map (step a) autos)
|
|
||||||
in (combine autos', bs))
|
|
||||||
|
|
||||||
{-| Create an automaton with no memory. It just applies the given function to
|
|
||||||
every input.
|
|
||||||
-}
|
|
||||||
pure : (a -> b) -> Automaton a b
|
|
||||||
pure f = Step (\x -> (pure f, f x))
|
|
||||||
|
|
||||||
|
|
||||||
{-| Create an automaton with state. Requires an initial state and a step
|
|
||||||
function to step the state forward. For example, an automaton that counted
|
|
||||||
how many steps it has taken would look like this:
|
|
||||||
|
|
||||||
count = Automaton a Int
|
|
||||||
count = state 0 (\\_ c -> c+1)
|
|
||||||
|
|
||||||
It is a stateful automaton. The initial state is zero, and the step function
|
|
||||||
increments the state on every step.
|
|
||||||
-}
|
|
||||||
state : b -> (a -> b -> b) -> Automaton a b
|
|
||||||
state s f = Step (\x -> let s' = f x s
|
|
||||||
in (state s' f, s'))
|
|
||||||
|
|
||||||
{-| Create an automaton with hidden state. Requires an initial state and a
|
|
||||||
step function to step the state forward and produce an output.
|
|
||||||
-}
|
|
||||||
hiddenState : s -> (a -> s -> (s,b)) -> Automaton a b
|
|
||||||
hiddenState s f = Step (\x -> let (s',out) = f x s
|
|
||||||
in (hiddenState s' f, out))
|
|
||||||
|
|
||||||
{-| Count the number of steps taken. -}
|
|
||||||
count : Automaton a Int
|
|
||||||
count = state 0 (\_ c -> c + 1)
|
|
||||||
|
|
||||||
type Queue t = ([t],[t])
|
|
||||||
empty = ([],[])
|
|
||||||
enqueue x (en,de) = (x::en, de)
|
|
||||||
dequeue q = case q of
|
|
||||||
([],[]) -> Nothing
|
|
||||||
(en,[]) -> dequeue ([], reverse en)
|
|
||||||
(en,hd::tl) -> Just (hd, (en,tl))
|
|
||||||
|
|
||||||
{-| Computes the running average of the last `n` inputs. -}
|
|
||||||
average : Int -> Automaton Float Float
|
|
||||||
average k =
|
|
||||||
let step n (ns,len,sum) =
|
|
||||||
if len == k then stepFull n (ns,len,sum)
|
|
||||||
else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))
|
|
||||||
stepFull n (ns,len,sum) =
|
|
||||||
case dequeue ns of
|
|
||||||
Nothing -> ((ns,len,sum), 0)
|
|
||||||
Just (m,ns') -> let sum' = sum + n - m
|
|
||||||
in ((enqueue n ns', len, sum'), sum' / toFloat len)
|
|
||||||
in hiddenState (empty,0,0) step
|
|
||||||
|
|
||||||
|
|
||||||
{-- TODO(evancz): See the following papers for ideas on how to make this
|
|
||||||
library faster and better:
|
|
||||||
|
|
||||||
- Functional Reactive Programming, Continued
|
|
||||||
- Causal commutative arrows and their optimization
|
|
||||||
|
|
||||||
Speeding things up is a really low priority. Language features and
|
|
||||||
libraries with nice APIs and are way more important!
|
|
||||||
--}
|
|
|
@ -1,149 +0,0 @@
|
||||||
module AutomatonV2 where
|
|
||||||
{-| This library is a way to package up dynamic behavior. It makes it easier to
|
|
||||||
dynamically create dynamic components. See the [original release
|
|
||||||
notes](/blog/announce/version-0.5.0.elm) on this library to get a feel for how
|
|
||||||
it can be used.
|
|
||||||
-}
|
|
||||||
|
|
||||||
import open Basics
|
|
||||||
import Signal (lift,foldp,Signal)
|
|
||||||
import open List
|
|
||||||
import Maybe (Just, Nothing)
|
|
||||||
|
|
||||||
data Automaton input output = Pure (input -> output)
|
|
||||||
| Stateful state (input -> state -> (output,state))
|
|
||||||
|
|
||||||
-- The basics
|
|
||||||
|
|
||||||
-- AFRP name: arr
|
|
||||||
pure: (i -> o) -> Automaton i o
|
|
||||||
pure = Pure
|
|
||||||
|
|
||||||
-- AFRP name: >>>
|
|
||||||
andThen: Automaton i inter -> Automaton inter o -> Automaton i o
|
|
||||||
andThen first second =
|
|
||||||
case first of
|
|
||||||
Pure f -> case second of -- f is the function from first
|
|
||||||
Pure s -> Pure (s . f) -- s is the function from second
|
|
||||||
Stateful b s -> Stateful b (\i -> s (f i)) -- b is the base state from second
|
|
||||||
Stateful fb f -> case second of -- fb is the base state from first
|
|
||||||
Pure s -> Stateful fb (\i st -> -- sb is the base state from second
|
|
||||||
let (inter, st') = f i st -- i is the input
|
|
||||||
in (s inter, st')) -- st is the input state
|
|
||||||
Stateful sb s -> Stateful (fb, sb) (\i (fst, sst) -> -- inter is the intermediate value
|
|
||||||
let (inter, fst') = f i fst -- st' is the new state
|
|
||||||
(o, sst') = s inter sst -- fst and sst are the state of first and second
|
|
||||||
in (o, (fst', sst'))) -- ect...
|
|
||||||
|
|
||||||
-- AFRP name: first
|
|
||||||
extendDown: Automaton i o -> Automaton (i,extra) (o,extra)
|
|
||||||
extendDown auto = case auto of
|
|
||||||
Pure fun -> Pure (\(i,extra) -> (fun i, extra))
|
|
||||||
Stateful base fun -> Stateful base (\(i,extra) s -> (fun i s, extra))
|
|
||||||
|
|
||||||
-- AFRP name: loop
|
|
||||||
loop: s -> Automaton (i,s) (o,s) -> Automaton i o
|
|
||||||
loop base auto = case auto of
|
|
||||||
Pure fun -> Stateful base (curry fun)
|
|
||||||
Stateful base2 fun -> -- fun: (i, s) -> s2 -> ((o, s), s2)
|
|
||||||
let newFun = (\i (s,s2) ->
|
|
||||||
let ((o, s'), s2') = fun (i, s) s2
|
|
||||||
in (o, (s', s2'))) -- newFun: i -> (s, s2) -> (o, (s, s2))
|
|
||||||
in Stateful (base, base2) newFun
|
|
||||||
|
|
||||||
-- Run an automaton on a given signal
|
|
||||||
run: Automaton i o -> o -> Signal i -> Signal o
|
|
||||||
run auto baseOut input = case auto of
|
|
||||||
Pure fun -> lift fun input
|
|
||||||
Stateful base fun -> lift fst
|
|
||||||
(foldp (\i (o, s) -> fun i s)
|
|
||||||
(baseOut, base) input)
|
|
||||||
|
|
||||||
|
|
||||||
-- Other frequently used functions/operators
|
|
||||||
|
|
||||||
-- Create an automaton with state. Requires an initial state and a step
|
|
||||||
-- function to step the state forward. For example, an automaton that counted
|
|
||||||
-- how many steps it has taken would look like this:
|
|
||||||
--
|
|
||||||
-- count = Automaton a Int
|
|
||||||
-- count = state 0 (\\_ c -> c+1)
|
|
||||||
--
|
|
||||||
-- It is a stateful automaton. The initial state is zero, and the step function
|
|
||||||
-- increments the state on every step.
|
|
||||||
state : s -> (i -> s -> s) -> Automaton i s
|
|
||||||
state base fun = loop base (pure (\(i,s) ->
|
|
||||||
let s' = fun i s
|
|
||||||
in (s',s')))
|
|
||||||
|
|
||||||
-- Create an automaton with hidden state. Requires an initial state and a
|
|
||||||
-- step function to step the state forward and produce an output.
|
|
||||||
hiddenState : s -> (i -> s -> (s,o)) -> Automaton i o
|
|
||||||
hiddenState base fun = loop base (pure (\(i,s) ->
|
|
||||||
let (o,s') = fun i s
|
|
||||||
in (s',o)))
|
|
||||||
|
|
||||||
-- AFRP name: second
|
|
||||||
extendUp: Automaton i o -> Automaton (extra,i) (extra,o)
|
|
||||||
extendUp auto =
|
|
||||||
let swap (a, b) = (b, a)
|
|
||||||
in pure swap `andThen` extendDown auto `andThen` pure swap
|
|
||||||
|
|
||||||
-- (parallel composition)
|
|
||||||
pair: Automaton i1 o1 -> Automaton i2 o2 -> Automaton (i1,i2) (o1,o2)
|
|
||||||
pair f g = extendDown f `andThen` extendUp g
|
|
||||||
|
|
||||||
branch : Automaton i o1 -> Automaton i o2 -> Automaton i (o1,o2)
|
|
||||||
branch f g =
|
|
||||||
let double = pure (\i -> (i,i))
|
|
||||||
in double `andThen` pair f g
|
|
||||||
|
|
||||||
combi: Automaton i o -> Automaton i [o] -> Automaton i [o]
|
|
||||||
combi a1 a2 = (a1 `branch` a2) `andThen` pure (uncurry (::))
|
|
||||||
|
|
||||||
-- Combine a list of automatons into a single automaton that produces a list.
|
|
||||||
combine : [Automaton i o] -> Automaton i [o]
|
|
||||||
combine autos =
|
|
||||||
let l = length autos
|
|
||||||
in if l == 0
|
|
||||||
then pure (\_ -> [])
|
|
||||||
else foldr combi (last autos `andThen` pure (\a -> [a])) (take (l-1) autos)
|
|
||||||
|
|
||||||
|
|
||||||
-- Examples of automata
|
|
||||||
|
|
||||||
-- Count the number of steps taken.
|
|
||||||
count : Automaton a Int
|
|
||||||
count = state 0 (\_ c -> c + 1)
|
|
||||||
|
|
||||||
type Queue t = ([t],[t])
|
|
||||||
empty = ([],[])
|
|
||||||
enqueue x (en,de) = (x::en, de)
|
|
||||||
dequeue q = case q of
|
|
||||||
([],[]) -> Nothing
|
|
||||||
(en,[]) -> dequeue ([], reverse en)
|
|
||||||
(en,hd::tl) -> Just (hd, (en,tl))
|
|
||||||
|
|
||||||
-- Computes the running average of the last `n` inputs.
|
|
||||||
average : Int -> Automaton Float Float
|
|
||||||
average k =
|
|
||||||
let step n (ns,len,sum) =
|
|
||||||
if len == k then stepFull n (ns,len,sum)
|
|
||||||
else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))
|
|
||||||
stepFull n (ns,len,sum) =
|
|
||||||
case dequeue ns of
|
|
||||||
Nothing -> ((ns,len,sum), 0)
|
|
||||||
Just (m,ns') -> let sum' = sum + n - m
|
|
||||||
in ((enqueue n ns', len, sum'), sum' / toFloat len)
|
|
||||||
in hiddenState (empty,0,0) step
|
|
||||||
|
|
||||||
|
|
||||||
{-- TODO(evancz): See the following papers for ideas on how to make this
|
|
||||||
library faster and better:
|
|
||||||
|
|
||||||
- Functional Reactive Programming, Continued -- took some inspirations from this paper (Apanatshka)
|
|
||||||
- Causal commutative arrows and their optimization
|
|
||||||
|
|
||||||
Speeding things up is a really low priority. Language features and
|
|
||||||
libraries with nice APIs and are way more important!
|
|
||||||
--}
|
|
|
@ -39,6 +39,9 @@ which happen to be radians.
|
||||||
# Polar Coordinates
|
# Polar Coordinates
|
||||||
@docs toPolar, fromPolar
|
@docs toPolar, fromPolar
|
||||||
|
|
||||||
|
# Floating Point Checks
|
||||||
|
@docs isNaN, isInfinite
|
||||||
|
|
||||||
# Tuples
|
# Tuples
|
||||||
@docs fst, snd
|
@docs fst, snd
|
||||||
|
|
||||||
|
@ -271,6 +274,30 @@ ceiling = Native.Basics.ceiling
|
||||||
toFloat : Int -> Float
|
toFloat : Int -> Float
|
||||||
toFloat = Native.Basics.toFloat
|
toFloat = Native.Basics.toFloat
|
||||||
|
|
||||||
|
{- | Determines whether a float is an undefined or unrepresentable number.
|
||||||
|
NaN stands for *not a number* and it is [a standardized part of floating point
|
||||||
|
numbers](http://en.wikipedia.org/wiki/NaN).
|
||||||
|
|
||||||
|
isNaN (0/0) == True
|
||||||
|
isNaN (sqrt -1) == True
|
||||||
|
isNaN (1/0) == False -- infinity is a number
|
||||||
|
isNaN 1 == False
|
||||||
|
-}
|
||||||
|
isNaN : Float -> Bool
|
||||||
|
isNaN = Native.Basics.isNaN
|
||||||
|
|
||||||
|
{- | Determines whether a float is positive or negative infinity.
|
||||||
|
|
||||||
|
isInfinite (0/0) == False
|
||||||
|
isInfinite (sqrt -1) == False
|
||||||
|
isInfinite (1/0) == True
|
||||||
|
isInfinite 1 == False
|
||||||
|
|
||||||
|
Notice that NaN is not infinite! For float `n` to be finite implies that
|
||||||
|
`not (isInfinite n || isNaN n)` evaluates to `True`.
|
||||||
|
-}
|
||||||
|
isInfinite : Float -> Bool
|
||||||
|
isInfinite = Native.Basics.isInfinite
|
||||||
|
|
||||||
-- Function Helpers
|
-- Function Helpers
|
||||||
|
|
||||||
|
|
|
@ -5,7 +5,7 @@ module Date where
|
||||||
issues with internationalization or locale formatting.
|
issues with internationalization or locale formatting.
|
||||||
|
|
||||||
# Conversions
|
# Conversions
|
||||||
@docs read, toTime
|
@docs read, toTime, fromTime
|
||||||
|
|
||||||
# Extractions
|
# Extractions
|
||||||
@docs year, month, Month, day, dayOfWeek, Day, hour, minute, second
|
@docs year, month, Month, day, dayOfWeek, Day, hour, minute, second
|
||||||
|
@ -36,6 +36,10 @@ read = Native.Date.read
|
||||||
toTime : Date -> Time
|
toTime : Date -> Time
|
||||||
toTime = Native.Date.toTime
|
toTime = Native.Date.toTime
|
||||||
|
|
||||||
|
{-| Take a UNIX time and convert it to a `Date` -}
|
||||||
|
fromTime : Time -> Date
|
||||||
|
fromTime = Native.Date.fromTime
|
||||||
|
|
||||||
{-| Extract the year of a given date. Given the date 23 June 1990 at 11:45AM
|
{-| Extract the year of a given date. Given the date 23 June 1990 at 11:45AM
|
||||||
this returns the integer `1990`. -}
|
this returns the integer `1990`. -}
|
||||||
year : Date -> Int
|
year : Date -> Int
|
||||||
|
|
17
libraries/Debug.elm
Normal file
17
libraries/Debug.elm
Normal file
|
@ -0,0 +1,17 @@
|
||||||
|
module Debug where
|
||||||
|
{-| This library is for investigating bugs or performance problems. It should
|
||||||
|
*not* be used in production code.
|
||||||
|
-}
|
||||||
|
|
||||||
|
import Native.Debug
|
||||||
|
|
||||||
|
{-| Log a tagged value on the developer console, and then return the value.
|
||||||
|
|
||||||
|
1 + log "number" 1 -- equals 2, logs "number: 1"
|
||||||
|
length (log "start" []) -- equals 0, logs "start: []"
|
||||||
|
|
||||||
|
Notice that `log` is not a pure function! It should *only* be used for
|
||||||
|
investigating bugs or performance problems.
|
||||||
|
-}
|
||||||
|
log : String -> a -> a
|
||||||
|
log = Native.Debug.log
|
|
@ -31,11 +31,10 @@ Insert, remove, and query operations all take *O(log n)* time.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
|
||||||
import open Basics
|
import Basics (..)
|
||||||
import open Maybe
|
import Maybe (..)
|
||||||
import Native.Error
|
import Native.Error
|
||||||
import List
|
import List
|
||||||
import String
|
|
||||||
import Native.Utils
|
import Native.Utils
|
||||||
|
|
||||||
-- BBlack and NBlack should only be used during the deletion
|
-- BBlack and NBlack should only be used during the deletion
|
||||||
|
@ -197,7 +196,7 @@ lessBlackTree t = case t of
|
||||||
|
|
||||||
reportRemBug : String -> NColor -> String -> String -> a
|
reportRemBug : String -> NColor -> String -> String -> a
|
||||||
reportRemBug msg c lgot rgot =
|
reportRemBug msg c lgot rgot =
|
||||||
Native.Error.raise . String.concat <| [
|
Native.Error.raise <| List.concat [
|
||||||
"Internal red-black tree invariant violated, expected ",
|
"Internal red-black tree invariant violated, expected ",
|
||||||
msg,
|
msg,
|
||||||
"and got",
|
"and got",
|
||||||
|
|
|
@ -26,28 +26,50 @@ data Either a b = Left a | Right b
|
||||||
|
|
||||||
{-| Apply the first function to a `Left` and the second function to a `Right`.
|
{-| Apply the first function to a `Left` and the second function to a `Right`.
|
||||||
This allows the extraction of a value from an `Either`.
|
This allows the extraction of a value from an `Either`.
|
||||||
|
|
||||||
|
either (\n -> n + 1) sqrt (Left 4) == 5
|
||||||
|
either (\n -> n + 1) sqrt (Right 4) == 2
|
||||||
|
|
||||||
|
map : (a -> b) -> Either err a -> Either err b
|
||||||
|
map f e = either Left (\x -> Right (f x)) e
|
||||||
-}
|
-}
|
||||||
either : (a -> c) -> (b -> c) -> Either a b -> c
|
either : (a -> c) -> (b -> c) -> Either a b -> c
|
||||||
either f g e = case e of { Left x -> f x ; Right y -> g y }
|
either f g e = case e of { Left x -> f x ; Right y -> g y }
|
||||||
|
|
||||||
{-| True if the value is a `Left`. -}
|
{-| True if the value is a `Left`.
|
||||||
|
|
||||||
|
isLeft (Left "Cat") == True
|
||||||
|
isLeft (Right 1123) == False
|
||||||
|
-}
|
||||||
isLeft : Either a b -> Bool
|
isLeft : Either a b -> Bool
|
||||||
isLeft e = case e of { Left _ -> True ; _ -> False }
|
isLeft e = case e of { Left _ -> True ; _ -> False }
|
||||||
|
|
||||||
{-| True if the value is a `Right`. -}
|
{-| True if the value is a `Right`.
|
||||||
|
|
||||||
|
isRight (Left "Cat") == False
|
||||||
|
isRight (Right 1123) == True
|
||||||
|
-}
|
||||||
isRight : Either a b -> Bool
|
isRight : Either a b -> Bool
|
||||||
isRight e = case e of { Right _ -> True ; _ -> False }
|
isRight e = case e of { Right _ -> True ; _ -> False }
|
||||||
|
|
||||||
{-| Keep only the values held in `Left` values. -}
|
{-| Keep only the values held in `Left` values.
|
||||||
|
|
||||||
|
lefts [Left 3, Right 'a', Left 5, Right "eight"] == [3,5]
|
||||||
|
-}
|
||||||
lefts : [Either a b] -> [a]
|
lefts : [Either a b] -> [a]
|
||||||
lefts es = List.foldr consLeft [] es
|
lefts es = List.foldr consLeft [] es
|
||||||
|
|
||||||
{-| Keep only the values held in `Right` values. -}
|
{-| Keep only the values held in `Right` values.
|
||||||
|
|
||||||
|
rights [Left 3, Right 'a', Left 5, Right 'b'] == ['a','b']
|
||||||
|
-}
|
||||||
rights : [Either a b] -> [b]
|
rights : [Either a b] -> [b]
|
||||||
rights es = List.foldr consRight [] es
|
rights es = List.foldr consRight [] es
|
||||||
|
|
||||||
{-| Split into two lists, lefts on the left and rights on the right. So we
|
{-| Split into two lists, lefts on the left and rights on the right. So we
|
||||||
have the equivalence: `(partition es == (lefts es, rights es))`
|
have the equivalence: `(partition es == (lefts es, rights es))`
|
||||||
|
|
||||||
|
partition [Left 3, Right 'a', Left 5, Right 'b'] == ([3,5],['a','b'])
|
||||||
-}
|
-}
|
||||||
partition : [Either a b] -> ([a],[b])
|
partition : [Either a b] -> ([a],[b])
|
||||||
partition es = List.foldr consEither ([],[]) es
|
partition es = List.foldr consEither ([],[]) es
|
||||||
|
|
|
@ -30,7 +30,7 @@ it as a single unit.
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import open Basics
|
import Basics (..)
|
||||||
import List
|
import List
|
||||||
import Either (Either, Left, Right)
|
import Either (Either, Left, Right)
|
||||||
import Transform2D (Transform2D, identity)
|
import Transform2D (Transform2D, identity)
|
||||||
|
|
|
@ -37,12 +37,12 @@ If you need more precision, you can create custom positions.
|
||||||
midRightAt, topLeftAt, topRightAt, bottomLeftAt, bottomRightAt
|
midRightAt, topLeftAt, topRightAt, bottomLeftAt, bottomRightAt
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import open Basics
|
import Basics (..)
|
||||||
import Native.Utils
|
import Native.Utils
|
||||||
import JavaScript as JS
|
import JavaScript as JS
|
||||||
import JavaScript (JSString)
|
import JavaScript (JSString)
|
||||||
import List as List
|
import List as List
|
||||||
import open Color
|
import Color (..)
|
||||||
import Maybe (Maybe, Just, Nothing)
|
import Maybe (Maybe, Just, Nothing)
|
||||||
|
|
||||||
type Properties = {
|
type Properties = {
|
||||||
|
@ -53,7 +53,8 @@ type Properties = {
|
||||||
color : Maybe Color,
|
color : Maybe Color,
|
||||||
href : JSString,
|
href : JSString,
|
||||||
tag : JSString,
|
tag : JSString,
|
||||||
hover : ()
|
hover : (),
|
||||||
|
click : ()
|
||||||
}
|
}
|
||||||
|
|
||||||
type Element = { props : Properties, element : ElementPrim }
|
type Element = { props : Properties, element : ElementPrim }
|
||||||
|
@ -128,7 +129,9 @@ link href e = let p = e.props in
|
||||||
|
|
||||||
emptyStr = JS.fromString ""
|
emptyStr = JS.fromString ""
|
||||||
newElement w h e =
|
newElement w h e =
|
||||||
{ props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr (), element = e }
|
{ props = Properties (Native.Utils.guid ()) w h 1 Nothing emptyStr emptyStr () ()
|
||||||
|
, element = e
|
||||||
|
}
|
||||||
|
|
||||||
data ElementPrim
|
data ElementPrim
|
||||||
= Image ImageStyle Int Int JSString
|
= Image ImageStyle Int Int JSString
|
||||||
|
|
|
@ -1,199 +1,178 @@
|
||||||
module Graphics.Input where
|
module Graphics.Input where
|
||||||
|
|
||||||
{-| This module is for creating standard input widgets such as buttons and
|
{-| This module is for creating standard input widgets such as buttons and
|
||||||
text boxes. In general, functions in this library return a signal representing
|
text fields. All functions in this library follow a general pattern in which
|
||||||
events from the user.
|
you create an `Input` that many elements can report to:
|
||||||
|
|
||||||
The simplest inputs are *one-way inputs*, meaning the user can update
|
```haskell
|
||||||
them, but the programmer cannot. If you need to update an input from
|
clicks : Input ()
|
||||||
within the program you want the slightly more complex *two-way inputs*.
|
clicks = input ()
|
||||||
This document will always show the one-way inputs first, *then* the
|
|
||||||
two-way inputs.
|
|
||||||
|
|
||||||
# Buttons
|
clickableYogi : Element
|
||||||
@docs button, customButton, buttons, customButtons
|
clickableYogi = clickable clicks.handle () (image 40 40 "/yogi.jpg")
|
||||||
|
```
|
||||||
|
|
||||||
# Fields
|
Whenever the user clicks on the resulting `clickableYogi` element, it sends an
|
||||||
@docs field, password, email, fields, FieldState, emptyFieldState
|
update to the `clicks` input. You will see this pattern again and again in
|
||||||
|
examples in this library, so just read on to get a better idea of how it works!
|
||||||
|
|
||||||
# Checkboxes
|
# Creating Inputs
|
||||||
@docs checkbox, checkboxes
|
@docs Input, input
|
||||||
|
|
||||||
# Drop Downs
|
# Basic Input Elements
|
||||||
@docs stringDropDown, dropDown
|
|
||||||
|
To learn about text fields, see the
|
||||||
|
[`Graphics.Input.Field`](Graphics-Input-Field) library.
|
||||||
|
|
||||||
|
@docs button, customButton, checkbox, dropDown
|
||||||
|
|
||||||
|
# Clicks and Hovers
|
||||||
|
@docs clickable, hoverable
|
||||||
|
|
||||||
# Mouse Hover
|
|
||||||
@docs hoverable, hoverables
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import Basics (String)
|
import Signal (Signal)
|
||||||
import Signal (Signal,lift,dropRepeats)
|
|
||||||
import Native.Graphics.Input
|
|
||||||
import List
|
|
||||||
import Graphics.Element (Element)
|
import Graphics.Element (Element)
|
||||||
import Maybe (Maybe)
|
import Native.Graphics.Input
|
||||||
import JavaScript (JSString)
|
|
||||||
|
|
||||||
id x = x
|
{-| This is the key abstraction of this library. An `Input` is a record
|
||||||
|
of two fields:
|
||||||
|
|
||||||
{-| Create a group of buttons.
|
1. `signal` — all values coming to this input from “the world”
|
||||||
|
2. `handle` — a way to refer to this particular input and send it values
|
||||||
|
|
||||||
* The first argument is the default value of the `events` signal.
|
This will make more sense as you see more examples.
|
||||||
* The `events` signal represents all of the activity in this group
|
|
||||||
of buttons.
|
|
||||||
* The `button` function creates a button
|
|
||||||
with the given name, like “Submit” or “Cancel”.
|
|
||||||
The `a` value is sent to `events` whenever the button is pressed.
|
|
||||||
-}
|
-}
|
||||||
buttons : a -> { events : Signal a,
|
type Input a = { signal : Signal a, handle : Handle a }
|
||||||
button : a -> String -> Element }
|
|
||||||
buttons = Native.Graphics.Input.buttons
|
|
||||||
|
|
||||||
{-| Create a button with a given label. The result is an `Element` and
|
data Handle a = Handle
|
||||||
a signal of units. This signal triggers whenever the button is pressed.
|
|
||||||
|
{-| This creates a new `Input`. You provide a single argument that will serve
|
||||||
|
as the initial value of the input’s `signal`. For example:
|
||||||
|
|
||||||
|
numbers : Input Int
|
||||||
|
numbers = input 42
|
||||||
|
|
||||||
|
The initial value of `numbers.signal` is 42, and you will be able
|
||||||
|
to pipe updates to the input using `numbers.handle`.
|
||||||
|
|
||||||
|
Note: This is an inherently impure function. Specifically, `(input ())` and
|
||||||
|
`(input ())` are actually two different inputs with different signals and handles.
|
||||||
-}
|
-}
|
||||||
button : String -> (Element, Signal ())
|
input : a -> Input a
|
||||||
button txt =
|
input = Native.Graphics.Input.input
|
||||||
let pool = buttons ()
|
|
||||||
in (pool.button () txt, pool.events)
|
|
||||||
|
|
||||||
{-| Create a group of custom buttons.
|
{-| Create a standard button. The following example begins making a basic
|
||||||
|
calculator:
|
||||||
|
|
||||||
* The first argument is the default value of the `events` signal.
|
data Keys = Number Int | Plus | Minus | Clear
|
||||||
* The `events` signal represents all of the activity in this group
|
|
||||||
of custom buttons.
|
keys : Input Keys
|
||||||
* The `customButton` function creates a button with three different visual
|
keys = input Clear
|
||||||
states, one for up, hovering, and down. The resulting button has dimensions
|
|
||||||
large enough to fit all three possible `Elements`.
|
calculator : Element
|
||||||
The `a` value is sent to `events` whenever the button is pressed.
|
calculator =
|
||||||
|
flow right [ button keys.handle (Number 1) "1"
|
||||||
|
, button keys.handle (Number 2) "2"
|
||||||
|
, button keys.handle Plus "+"
|
||||||
|
]
|
||||||
|
|
||||||
|
If the user presses the "+" button, `keys.signal` will update to `Plus`. If the
|
||||||
|
users presses "2", `keys.signal` will update to `(Number 2)`.
|
||||||
-}
|
-}
|
||||||
customButtons : a -> { events : Signal a,
|
button : Handle a -> a -> String -> Element
|
||||||
customButton : a -> Element -> Element -> Element -> Element }
|
button = Native.Graphics.Input.button
|
||||||
customButtons = Native.Graphics.Input.customButtons
|
|
||||||
|
|
||||||
{-| Create a button with custom states for up, hovering, and down
|
{-| Same as `button` but lets you customize buttons to look however you want.
|
||||||
(given in that order). The result is an `Element` and a signal of
|
|
||||||
units. This signal triggers whenever the button is pressed.
|
click : Input ()
|
||||||
|
click = input ()
|
||||||
|
|
||||||
|
prettyButton : Element
|
||||||
|
prettyButton =
|
||||||
|
customButton click.handle
|
||||||
|
(image 100 40 "/button_up.jpg")
|
||||||
|
(image 100 40 "/button_hover.jpg")
|
||||||
|
(image 100 40 "/button_down.jpg")
|
||||||
-}
|
-}
|
||||||
customButton : Element -> Element -> Element -> (Element, Signal ())
|
customButton : Handle a -> a -> Element -> Element -> Element -> Element
|
||||||
customButton up hover down =
|
customButton = Native.Graphics.Input.customButton
|
||||||
let pool = customButtons ()
|
|
||||||
in (pool.customButton () up hover down, pool.events)
|
|
||||||
|
|
||||||
{-| Create a group of checkboxes.
|
{-| Create a checkbox. The following example creates three synced checkboxes:
|
||||||
|
|
||||||
* The first argument is the default value of the `events` signal.
|
check : Input Bool
|
||||||
* The `events` signal represents all of the activity in this group
|
check = input False
|
||||||
of checkboxes.
|
|
||||||
* The `checkbox` function creates a
|
boxes : Bool -> Element
|
||||||
checkbox with a given state. The `(Bool -> a)` function is used
|
boxes checked =
|
||||||
when the checkbox is modified. It takes the new state and turns
|
let box = container 40 40 middle (checkbox check.handle id checked)
|
||||||
it into a value that can be sent to `events`. For example, this
|
in flow right [ box, box, box ]
|
||||||
lets you add an ID to distinguish between checkboxes.
|
|
||||||
|
main : Signal Element
|
||||||
|
main = boxes <~ check.signal
|
||||||
-}
|
-}
|
||||||
checkboxes : a -> { events : Signal a,
|
checkbox : Handle a -> (Bool -> a) -> Bool -> Element
|
||||||
checkbox : (Bool -> a) -> Bool -> Element }
|
checkbox = Native.Graphics.Input.checkbox
|
||||||
checkboxes = Native.Graphics.Input.checkboxes
|
|
||||||
|
|
||||||
{-| Create a checkbox with a given start state. Unlike `button`, this
|
{-| Create a drop-down menu. The following drop-down lets you choose your
|
||||||
result is a *signal* of elements. That is because a checkbox has state
|
favorite British sport:
|
||||||
that updates based on user input. The boolean signal represents the
|
|
||||||
current state of the checkbox.
|
data Sport = Football | Cricket | Snooker
|
||||||
|
|
||||||
|
sport : Input (Maybe Sport)
|
||||||
|
sport = input Nothing
|
||||||
|
|
||||||
|
sportDropDown : Element
|
||||||
|
sportDropDown =
|
||||||
|
dropDown sport.handle
|
||||||
|
[ ("" , Nothing)
|
||||||
|
, ("Football", Just Football)
|
||||||
|
, ("Cricket" , Just Cricket)
|
||||||
|
, ("Snooker" , Just Snooker)
|
||||||
|
]
|
||||||
|
|
||||||
|
If the user selects "Football" from the drop down menue, `sport.signal`
|
||||||
|
will update to `Just Football`.
|
||||||
-}
|
-}
|
||||||
checkbox : Bool -> (Signal Element, Signal Bool)
|
dropDown : Handle a -> [(String,a)] -> Element
|
||||||
checkbox b =
|
|
||||||
let cbs = checkboxes b
|
|
||||||
in (lift (cbs.checkbox id) cbs.events, cbs.events)
|
|
||||||
|
|
||||||
{-| Detect when the mouse is hovering over some elements. This
|
|
||||||
allows you to create and destroy elements dynamically and still
|
|
||||||
detect hover information.
|
|
||||||
-}
|
|
||||||
hoverables : a -> { events : Signal a,
|
|
||||||
hoverable : (Bool -> a) -> Element -> Element }
|
|
||||||
hoverables = Native.Graphics.Input.hoverables
|
|
||||||
|
|
||||||
{-| Detect when the mouse is hovering over a specific `Element`. -}
|
|
||||||
hoverable : Element -> (Element, Signal Bool)
|
|
||||||
hoverable elem =
|
|
||||||
let pool = hoverables False
|
|
||||||
in (pool.hoverable id elem, pool.events)
|
|
||||||
|
|
||||||
{-| Represents the current state of a text field. The `string` represents the
|
|
||||||
characters filling the text field. The `selectionStart` and `selectionEnd`
|
|
||||||
values represent what the user has selected with their mouse or keyboard.
|
|
||||||
For example:
|
|
||||||
|
|
||||||
{ string="She sells sea shells", selectionStart=3, selectionEnd=0 }
|
|
||||||
|
|
||||||
This means the user highlighted the substring `"She"` backwards.
|
|
||||||
-}
|
|
||||||
type FieldState = { string:String, selectionStart:Int, selectionEnd:Int }
|
|
||||||
|
|
||||||
{-| Create a group of text input fields.
|
|
||||||
|
|
||||||
* The first argument is the default value of the `events` signal.
|
|
||||||
* The `events` signal represents all of the activity in this group
|
|
||||||
of text fields.
|
|
||||||
* The `field` function creates a
|
|
||||||
field with the given ghost text and initial field state.
|
|
||||||
When the field is modified, the `(FieldState -> a)` function
|
|
||||||
takes the new state and turns
|
|
||||||
it into a value that can be sent to `events`. For example, this
|
|
||||||
lets you add an ID to distinguish between input fields.
|
|
||||||
-}
|
|
||||||
fields : a -> { events : Signal a,
|
|
||||||
field : (FieldState -> a) -> String -> FieldState -> Element }
|
|
||||||
fields = Native.Graphics.Input.fields
|
|
||||||
|
|
||||||
{-| The empty field state:
|
|
||||||
|
|
||||||
{ string="", selectionStart=0, selectionEnd=0 }
|
|
||||||
-}
|
|
||||||
emptyFieldState : FieldState
|
|
||||||
emptyFieldState = { string="", selectionStart=0, selectionEnd=0 }
|
|
||||||
|
|
||||||
{-| Create a field with the given default text. The output is an element
|
|
||||||
that updates to match the user input and a signal of strings representing
|
|
||||||
the content of the field.
|
|
||||||
-}
|
|
||||||
field : String -> (Signal Element, Signal String)
|
|
||||||
field placeHolder =
|
|
||||||
let tfs = fields emptyFieldState
|
|
||||||
changes = dropRepeats tfs.events
|
|
||||||
in (lift (tfs.field id placeHolder) changes,
|
|
||||||
dropRepeats (lift .string changes))
|
|
||||||
|
|
||||||
{-| Same as `field` but the UI element blocks out each characters. -}
|
|
||||||
password : String -> (Signal Element, Signal String)
|
|
||||||
password placeHolder =
|
|
||||||
let tfs = Native.Graphics.Input.passwords emptyFieldState
|
|
||||||
changes = dropRepeats tfs.events
|
|
||||||
in (lift (tfs.field id placeHolder) changes,
|
|
||||||
dropRepeats (lift .string changes))
|
|
||||||
|
|
||||||
{-| Same as `field` but it adds an annotation that this field is for email
|
|
||||||
addresses. This is helpful for auto-complete and for mobile users who may
|
|
||||||
get a custom keyboard with an `@` and `.com` button.
|
|
||||||
-}
|
|
||||||
email : String -> (Signal Element, Signal String)
|
|
||||||
email placeHolder =
|
|
||||||
let tfs = Native.Graphics.Input.emails emptyFieldState
|
|
||||||
changes = dropRepeats tfs.events
|
|
||||||
in (lift (tfs.field id placeHolder) changes,
|
|
||||||
dropRepeats (lift .string changes))
|
|
||||||
|
|
||||||
{-| Create a drop-down menu. When the user selects a string,
|
|
||||||
the current state of the drop-down is set to the associated
|
|
||||||
value. This lets you avoid manually mapping the string onto
|
|
||||||
functions and values.
|
|
||||||
-}
|
|
||||||
dropDown : [(String,a)] -> (Signal Element, Signal a)
|
|
||||||
dropDown = Native.Graphics.Input.dropDown
|
dropDown = Native.Graphics.Input.dropDown
|
||||||
|
|
||||||
{-| Create a drop-down menu for selecting strings. The resulting
|
{-| Detect mouse hovers over a specific `Element`. In the following example,
|
||||||
signal of strings represents the string that is currently selected.
|
we will create a hoverable picture called `cat`.
|
||||||
|
|
||||||
|
hover : Input Bool
|
||||||
|
hover = input False
|
||||||
|
|
||||||
|
cat : Element
|
||||||
|
cat = image 30 30 "/cat.jpg"
|
||||||
|
|> hoverable hover.handle id
|
||||||
|
|
||||||
|
When the mouse hovers above the `cat` element, `hover.signal` will become
|
||||||
|
`True`. When the mouse leaves it, `hover.signal` will become `False`.
|
||||||
-}
|
-}
|
||||||
stringDropDown : [String] -> (Signal Element, Signal String)
|
hoverable : Handle a -> (Bool -> a) -> Element -> Element
|
||||||
stringDropDown strs =
|
hoverable = Native.Graphics.Input.hoverable
|
||||||
dropDown (List.map (\s -> (s,s)) strs)
|
|
||||||
|
{-| Detect mouse clicks on a specific `Element`. In the following example,
|
||||||
|
we will create a clickable picture called `cat`.
|
||||||
|
|
||||||
|
data Picture = Cat | Hat
|
||||||
|
|
||||||
|
picture : Input Picture
|
||||||
|
picture = input Cat
|
||||||
|
|
||||||
|
cat : Element
|
||||||
|
cat = image 30 30 "/cat.jpg"
|
||||||
|
|> clickable picture.handle Cat
|
||||||
|
|
||||||
|
hat : Element
|
||||||
|
hat = image 30 30 "/hat.jpg"
|
||||||
|
|> clickable picture.handle Hat
|
||||||
|
|
||||||
|
When the user clicks on the `cat` element, `picture.signal` receives
|
||||||
|
an update containing the value `Cat`. When the user clicks on the `hat` element,
|
||||||
|
`picture.signal` receives an update containing the value `Hat`. This lets you
|
||||||
|
distinguish which element was clicked. In a more complex example, they could be
|
||||||
|
distinguished with IDs or more complex data structures.
|
||||||
|
-}
|
||||||
|
clickable : Handle a -> a -> Element -> Element
|
||||||
|
clickable = Native.Graphics.Input.clickable
|
||||||
|
|
170
libraries/Graphics/Input/Field.elm
Normal file
170
libraries/Graphics/Input/Field.elm
Normal file
|
@ -0,0 +1,170 @@
|
||||||
|
module Graphics.Input.Field where
|
||||||
|
{-| This library provides an API for creating and updating text fields.
|
||||||
|
Text fields use exactly the same approach as [`Graphics.Input`](Graphics-Input)
|
||||||
|
for modelling user input, allowing you to keep track of new events and update
|
||||||
|
text fields programmatically.
|
||||||
|
|
||||||
|
# Create Fields
|
||||||
|
@docs field, password, email
|
||||||
|
|
||||||
|
# Field Content
|
||||||
|
@docs Content, Selection, Direction, noContent
|
||||||
|
|
||||||
|
# Field Style
|
||||||
|
@docs Style, Outline, noOutline, Highlight, noHighlight, Dimensions, uniformly
|
||||||
|
-}
|
||||||
|
|
||||||
|
import Color (Color)
|
||||||
|
import Color
|
||||||
|
import Graphics.Element (Element)
|
||||||
|
import Graphics.Input (Input, Handle)
|
||||||
|
import Native.Graphics.Input
|
||||||
|
import Text
|
||||||
|
|
||||||
|
{-| Create uniform dimensions:
|
||||||
|
|
||||||
|
uniformly 4 == { left=4, right=4, top=4, bottom=4 }
|
||||||
|
|
||||||
|
The following example creates an outline where the left, right, top, and bottom
|
||||||
|
edges all have width 1:
|
||||||
|
|
||||||
|
Outline grey (uniformly 1) 4
|
||||||
|
-}
|
||||||
|
uniformly : Int -> Dimensions
|
||||||
|
uniformly n = Dimensions n n n n
|
||||||
|
|
||||||
|
{-| For setting dimensions of a fields padding or border. The left, right, top,
|
||||||
|
and bottom may all have different sizes. The following example creates
|
||||||
|
dimensions such that the left and right are twice as wide as the top and bottom:
|
||||||
|
|
||||||
|
myDimensions : Int -> Dimensions
|
||||||
|
myDimensions n = { left = 2 * n, right = 2 * n, top = n, bottom = n }
|
||||||
|
-}
|
||||||
|
type Dimensions = { left:Int, right:Int, top:Int, bottom:Int }
|
||||||
|
|
||||||
|
{-| A field can have a outline around it. This lets you set its color, width,
|
||||||
|
and radius. The radius allows you to round the corners of your field. Set the
|
||||||
|
width to zero to make it invisible. Here is an example outline that is grey
|
||||||
|
and thin with slightly rounded corners:
|
||||||
|
|
||||||
|
{ color = grey, width = uniformly 1, radius = 4 }
|
||||||
|
-}
|
||||||
|
type Outline = { color:Color, width:Dimensions, radius:Int }
|
||||||
|
|
||||||
|
{-| An outline with zero width, so you cannot see it. -}
|
||||||
|
noOutline : Outline
|
||||||
|
noOutline = Outline Color.grey (uniformly 0) 0
|
||||||
|
|
||||||
|
{-| When a field has focus, it has a blue highlight around it by default. The
|
||||||
|
`Highlight` lets you set the `color` and `width` of this highlight. Set the
|
||||||
|
`width` to zero to turn the highlight off. Here is an example highlight that
|
||||||
|
is blue and thin:
|
||||||
|
|
||||||
|
{ color = blue, width = 1 }
|
||||||
|
-}
|
||||||
|
type Highlight = { color:Color, width:Int }
|
||||||
|
|
||||||
|
{-| An highlight with zero width, so you cannot see it. -}
|
||||||
|
noHighlight : Highlight
|
||||||
|
noHighlight = Highlight Color.blue 0
|
||||||
|
|
||||||
|
{-| Describe the style of a text box. `style` describes the style of the text
|
||||||
|
itself using [`Text.Style`](/Text#Style). `outline` describes the glowing blue
|
||||||
|
outline that shows up when the field has focus. `outline` describes the line
|
||||||
|
surrounding the text field, and `padding` adds whitespace between the `outline`
|
||||||
|
and the text.
|
||||||
|
|
||||||
|
The width and height of the text box *includes* the `padding` and `outline`.
|
||||||
|
Say we have a text box that is 40 pixels tall. It has a uniform outline of
|
||||||
|
1 pixel and a uniform padding of 5 pixels. Both of these must be subtracted
|
||||||
|
from the total height to determine how much room there is for text. The
|
||||||
|
`padding` and `outline` appear on the top and bottom, so there will be 28
|
||||||
|
vertical pixels remaining for the text (40 - 1 - 5 - 5 - 1).
|
||||||
|
-}
|
||||||
|
type Style =
|
||||||
|
{ padding : Dimensions
|
||||||
|
, outline : Outline
|
||||||
|
, highlight : Highlight
|
||||||
|
, style : Text.Style
|
||||||
|
}
|
||||||
|
|
||||||
|
{-| The default style for a text field. The outline is `Color.grey` with width
|
||||||
|
1 and radius 2. The highlight is `Color.blue` with width 1, and the default
|
||||||
|
text color is black.
|
||||||
|
-}
|
||||||
|
defaultStyle : Style
|
||||||
|
defaultStyle =
|
||||||
|
{ padding = uniformly 4
|
||||||
|
, outline = Outline Color.grey (uniformly 1) 2
|
||||||
|
, highlight = Highlight Color.blue 1
|
||||||
|
, style = Text.defaultStyle
|
||||||
|
}
|
||||||
|
|
||||||
|
{-| Represents the current content of a text field. For example:
|
||||||
|
|
||||||
|
content = Content "She sells sea shells" (Selection 0 3 Backward)
|
||||||
|
|
||||||
|
This means the user highlighted the substring `"She"` backwards. The value of
|
||||||
|
`content.string` is `"She sells sea shells"`.
|
||||||
|
-}
|
||||||
|
type Content = { string:String, selection:Selection }
|
||||||
|
|
||||||
|
{-| The selection within a text field. `start` is never greater than `end`:
|
||||||
|
|
||||||
|
Selection 0 0 Forward -- cursor precedes all characters
|
||||||
|
|
||||||
|
Selection 5 9 Backward -- highlighting characters starting after
|
||||||
|
-- the 5th and ending after the 9th
|
||||||
|
-}
|
||||||
|
type Selection = { start:Int, end:Int, direction:Direction }
|
||||||
|
|
||||||
|
{-| The direction of selection. When the user highlights a selection in a text
|
||||||
|
field, they must do it in a particular direction. This determines which end of
|
||||||
|
the selection moves when they change the selection by pressing Shift-Left or
|
||||||
|
Shift-Right.
|
||||||
|
-}
|
||||||
|
data Direction = Forward | Backward
|
||||||
|
|
||||||
|
{-| A field with no content:
|
||||||
|
|
||||||
|
Content "" (Selection 0 0 Forward)
|
||||||
|
-}
|
||||||
|
noContent : Content
|
||||||
|
noContent = Content "" (Selection 0 0 Forward)
|
||||||
|
|
||||||
|
{-| Create a text field. The following example creates a time-varying element
|
||||||
|
called `nameField`. As the user types their name, the field will be updated
|
||||||
|
to match what they have entered.
|
||||||
|
|
||||||
|
name : Input Content
|
||||||
|
name = input noContent
|
||||||
|
|
||||||
|
nameField : Signal Element
|
||||||
|
nameField = field defaultStyle name.handle id "Name" <~ name.signal
|
||||||
|
|
||||||
|
When we use the `field` function, we first give it a visual style. This is
|
||||||
|
the first argument so that it is easier to define your own custom field
|
||||||
|
(`myField = field myStyle`). The next two arguments are a `Handle` and a
|
||||||
|
handler function that processes or augments events before sending them along
|
||||||
|
to the associated `Input`. In the example above we use the `id` function to
|
||||||
|
pass events along unchanged to the `name` `Input`. We then provide the
|
||||||
|
place-holder message to use when no input has been provided yet. Finally,
|
||||||
|
we give the current `Content` of the field. This argument is last because
|
||||||
|
it is most likely to change frequently, making function composition easier.
|
||||||
|
-}
|
||||||
|
field : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
|
||||||
|
field = Native.Graphics.Input.field
|
||||||
|
|
||||||
|
{-| Same as `field` but the UI element blocks out each characters. -}
|
||||||
|
password : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
|
||||||
|
password = Native.Graphics.Input.password
|
||||||
|
|
||||||
|
{-| Same as `field` but it adds an annotation that this field is for email
|
||||||
|
addresses. This is helpful for auto-complete and for mobile users who may
|
||||||
|
get a custom keyboard with an `@` and `.com` button.
|
||||||
|
-}
|
||||||
|
email : Style -> Handle a -> (Content -> a) -> String -> Content -> Element
|
||||||
|
email = Native.Graphics.Input.email
|
||||||
|
|
||||||
|
-- area : Handle a -> (Content -> a) -> Handle b -> ((Int,Int) -> b) -> (Int,Int) -> String -> Content -> Element
|
||||||
|
-- area = Native.Graphics.Input.area
|
|
@ -14,7 +14,7 @@ you have very strict latency requirements.
|
||||||
@docs Response
|
@docs Response
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import open Signal
|
import Signal (..)
|
||||||
import Native.Http
|
import Native.Http
|
||||||
|
|
||||||
{-| The datatype for responses. Success contains only the returned message.
|
{-| The datatype for responses. Success contains only the returned message.
|
||||||
|
|
|
@ -17,7 +17,7 @@ module Json where
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import open Basics
|
import Basics (..)
|
||||||
import Dict
|
import Dict
|
||||||
import Maybe (Maybe)
|
import Maybe (Maybe)
|
||||||
import JavaScript as JS
|
import JavaScript as JS
|
||||||
|
|
|
@ -25,7 +25,7 @@ list must have the same type.
|
||||||
@docs sort, sortBy, sortWith
|
@docs sort, sortBy, sortWith
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import open Basics
|
import Basics (..)
|
||||||
import Native.List
|
import Native.List
|
||||||
|
|
||||||
{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}
|
{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}
|
||||||
|
|
|
@ -21,27 +21,45 @@ numbers).
|
||||||
-}
|
-}
|
||||||
data Maybe a = Just a | Nothing
|
data Maybe a = Just a | Nothing
|
||||||
|
|
||||||
{-| Apply a function to the contents of a `Maybe`.
|
{-| Provide a default value and a function to extract the contents of a `Maybe`.
|
||||||
Return default when given `Nothing`.
|
When given `Nothing` you get the default, when given a `Just` you apply the
|
||||||
|
function to the associated value.
|
||||||
|
|
||||||
|
isPositive : Maybe Int -> Bool
|
||||||
|
isPositive maybeInt = maybe False (\n -> n > 0) maybeInt
|
||||||
|
|
||||||
|
map : (a -> b) -> Maybe a -> Maybe b
|
||||||
|
map f m = maybe Nothing (\x -> Just (f x)) m
|
||||||
-}
|
-}
|
||||||
maybe : b -> (a -> b) -> Maybe a -> b
|
maybe : b -> (a -> b) -> Maybe a -> b
|
||||||
maybe b f m = case m of
|
maybe b f m = case m of
|
||||||
Just v -> f v
|
Just v -> f v
|
||||||
Nothing -> b
|
Nothing -> b
|
||||||
|
|
||||||
{-| Check if constructed with `Just`.
|
{-| Check if a maybe happens to be a `Just`.
|
||||||
|
|
||||||
|
isJust (Just 42) == True
|
||||||
|
isJust (Just []) == True
|
||||||
|
isJust Nothing == False
|
||||||
-}
|
-}
|
||||||
isJust : Maybe a -> Bool
|
isJust : Maybe a -> Bool
|
||||||
isJust = maybe False (\_ -> True)
|
isJust = maybe False (\_ -> True)
|
||||||
|
|
||||||
{-| Check if constructed with `Nothing`.
|
{-| Check if constructed with `Nothing`.
|
||||||
|
|
||||||
|
isNothing (Just 42) == False
|
||||||
|
isNothing (Just []) == False
|
||||||
|
isNothing Nothing == True
|
||||||
-}
|
-}
|
||||||
isNothing : Maybe a -> Bool
|
isNothing : Maybe a -> Bool
|
||||||
isNothing = not . isJust
|
isNothing = not . isJust
|
||||||
|
|
||||||
|
cons : Maybe a -> [a] -> [a]
|
||||||
cons mx xs = maybe xs (\x -> x :: xs) mx
|
cons mx xs = maybe xs (\x -> x :: xs) mx
|
||||||
|
|
||||||
{-| Filters out Nothings and extracts the remaining values.
|
{-| Filters out Nothings and extracts the remaining values.
|
||||||
|
|
||||||
|
justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]
|
||||||
-}
|
-}
|
||||||
justs : [Maybe a] -> [a]
|
justs : [Maybe a] -> [a]
|
||||||
justs = foldr cons []
|
justs = foldr cons []
|
||||||
|
|
|
@ -7,7 +7,7 @@ module Mouse where
|
||||||
@docs position, x, y
|
@docs position, x, y
|
||||||
|
|
||||||
# Button Status
|
# Button Status
|
||||||
@docs isDown, clicks, isClicked
|
@docs isDown, clicks
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
@ -31,11 +31,6 @@ True when the button is down, and false otherwise. -}
|
||||||
isDown : Signal Bool
|
isDown : Signal Bool
|
||||||
isDown = Native.Mouse.isDown
|
isDown = Native.Mouse.isDown
|
||||||
|
|
||||||
{-| True immediately after the left mouse-button has been clicked,
|
|
||||||
and false otherwise. -}
|
|
||||||
isClicked : Signal Bool
|
|
||||||
isClicked = Native.Mouse.isClicked
|
|
||||||
|
|
||||||
{-| Always equal to unit. Event triggers on every mouse click. -}
|
{-| Always equal to unit. Event triggers on every mouse click. -}
|
||||||
clicks : Signal ()
|
clicks : Signal ()
|
||||||
clicks = Native.Mouse.clicks
|
clicks = Native.Mouse.clicks
|
||||||
|
|
|
@ -19,6 +19,7 @@ Elm.Native.Basics.make = function(elm) {
|
||||||
return Utils.cmp(n,lo) < 0 ? lo : Utils.cmp(n,hi) > 0 ? hi : n; }
|
return Utils.cmp(n,lo) < 0 ? lo : Utils.cmp(n,hi) > 0 ? hi : n; }
|
||||||
function xor(a,b) { return a !== b; }
|
function xor(a,b) { return a !== b; }
|
||||||
function not(b) { return !b; }
|
function not(b) { return !b; }
|
||||||
|
function isInfinite(n) { return n === Infinity || n === -Infinity }
|
||||||
|
|
||||||
function truncate(n) { return n|0; }
|
function truncate(n) { return n|0; }
|
||||||
|
|
||||||
|
@ -53,6 +54,8 @@ Elm.Native.Basics.make = function(elm) {
|
||||||
floor:Math.floor,
|
floor:Math.floor,
|
||||||
round:Math.round,
|
round:Math.round,
|
||||||
toFloat:function(x) { return x; },
|
toFloat:function(x) { return x; },
|
||||||
|
isNaN:isNaN,
|
||||||
|
isInfinite:isInfinite
|
||||||
};
|
};
|
||||||
|
|
||||||
return elm.Native.Basics.values = basics;
|
return elm.Native.Basics.values = basics;
|
||||||
|
|
|
@ -13,13 +13,13 @@ Elm.Native.Bitwise.make = function(elm) {
|
||||||
function srl(a,offset) { return a >>> offset; }
|
function srl(a,offset) { return a >>> offset; }
|
||||||
|
|
||||||
return elm.Native.Bitwise.values = {
|
return elm.Native.Bitwise.values = {
|
||||||
and: A2(and),
|
and: F2(and),
|
||||||
or : A2(or ),
|
or : F2(or ),
|
||||||
xor: A2(xor),
|
xor: F2(xor),
|
||||||
complement: not,
|
complement: not,
|
||||||
shiftLeft : A2(sll),
|
shiftLeft : F2(sll),
|
||||||
shiftRightArithmatic: A2(sra),
|
shiftRightArithmatic: F2(sra),
|
||||||
shiftRightLogical : A2(srl),
|
shiftRightLogical : F2(srl),
|
||||||
};
|
};
|
||||||
|
|
||||||
};
|
};
|
||||||
|
|
|
@ -6,6 +6,12 @@ Elm.Native.Color.make = function(elm) {
|
||||||
|
|
||||||
var Utils = Elm.Native.Utils.make(elm);
|
var Utils = Elm.Native.Utils.make(elm);
|
||||||
|
|
||||||
|
function toCss(c) {
|
||||||
|
return (c._3 === 1)
|
||||||
|
? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
|
||||||
|
: ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
|
||||||
|
}
|
||||||
|
|
||||||
function complement(rgb) {
|
function complement(rgb) {
|
||||||
var hsv = toHSV(rgb);
|
var hsv = toHSV(rgb);
|
||||||
hsv.hue = (hsv.hue + 180) % 360;
|
hsv.hue = (hsv.hue + 180) % 360;
|
||||||
|
@ -63,7 +69,8 @@ Elm.Native.Color.make = function(elm) {
|
||||||
return elm.Native.Color.values = {
|
return elm.Native.Color.values = {
|
||||||
hsva:F4(hsva),
|
hsva:F4(hsva),
|
||||||
hsv:F3(hsv),
|
hsv:F3(hsv),
|
||||||
complement:complement
|
complement:complement,
|
||||||
|
toCss:toCss
|
||||||
};
|
};
|
||||||
|
|
||||||
};
|
};
|
|
@ -27,6 +27,7 @@ Elm.Native.Date.make = function(elm) {
|
||||||
minute : function(d) { return d.getMinutes(); },
|
minute : function(d) { return d.getMinutes(); },
|
||||||
second : function(d) { return d.getSeconds(); },
|
second : function(d) { return d.getSeconds(); },
|
||||||
toTime : function(d) { return d.getTime(); },
|
toTime : function(d) { return d.getTime(); },
|
||||||
|
fromTime: function(t) { return new window.Date(t); },
|
||||||
dayOfWeek : function(d) { return { ctor:dayTable[d.getDay()] }; }
|
dayOfWeek : function(d) { return { ctor:dayTable[d.getDay()] }; }
|
||||||
};
|
};
|
||||||
|
|
||||||
|
|
24
libraries/Native/Debug.js
Normal file
24
libraries/Native/Debug.js
Normal file
|
@ -0,0 +1,24 @@
|
||||||
|
Elm.Native.Debug = {};
|
||||||
|
Elm.Native.Debug.make = function(elm) {
|
||||||
|
elm.Native = elm.Native || {};
|
||||||
|
elm.Native.Debug = elm.Native.Debug || {};
|
||||||
|
if (elm.Native.Debug.values) return elm.Native.Debug.values;
|
||||||
|
|
||||||
|
var show = Elm.Native.Show.make(elm).show;
|
||||||
|
|
||||||
|
function log(tag,value) {
|
||||||
|
var msg = tag + ': ' + show(value);
|
||||||
|
var process = process || {};
|
||||||
|
if (process.stdout) {
|
||||||
|
process.stdout.write(msg);
|
||||||
|
} else {
|
||||||
|
console.log(msg);
|
||||||
|
}
|
||||||
|
return value;
|
||||||
|
}
|
||||||
|
|
||||||
|
return elm.Native.Debug.values = {
|
||||||
|
log: F2(log)
|
||||||
|
};
|
||||||
|
|
||||||
|
};
|
|
@ -1,6 +1,5 @@
|
||||||
Elm.Native.Graphics.Input = {};
|
Elm.Native.Graphics.Input = {};
|
||||||
Elm.Native.Graphics.Input.make = function(elm) {
|
Elm.Native.Graphics.Input.make = function(elm) {
|
||||||
|
|
||||||
elm.Native = elm.Native || {};
|
elm.Native = elm.Native || {};
|
||||||
elm.Native.Graphics = elm.Native.Graphics || {};
|
elm.Native.Graphics = elm.Native.Graphics || {};
|
||||||
elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
|
elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
|
||||||
|
@ -9,18 +8,26 @@ Elm.Native.Graphics.Input.make = function(elm) {
|
||||||
var Render = ElmRuntime.use(ElmRuntime.Render.Element);
|
var Render = ElmRuntime.use(ElmRuntime.Render.Element);
|
||||||
var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
|
var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
|
||||||
|
|
||||||
|
var toCss = Elm.Native.Color.make(elm).toCss;
|
||||||
|
var Text = Elm.Native.Text.make(elm);
|
||||||
var Signal = Elm.Signal.make(elm);
|
var Signal = Elm.Signal.make(elm);
|
||||||
var newElement = Elm.Graphics.Element.make(elm).newElement;
|
var newElement = Elm.Graphics.Element.make(elm).newElement;
|
||||||
var JS = Elm.Native.JavaScript.make(elm);
|
var JS = Elm.Native.JavaScript.make(elm);
|
||||||
var Utils = Elm.Native.Utils.make(elm);
|
var Utils = Elm.Native.Utils.make(elm);
|
||||||
var Tuple2 = Utils.Tuple2;
|
var Tuple2 = Utils.Tuple2;
|
||||||
|
|
||||||
function dropDown(values) {
|
function input(initialValue) {
|
||||||
|
var signal = Signal.constant(initialValue);
|
||||||
|
return { _:{}, signal:signal, handle:signal };
|
||||||
|
}
|
||||||
|
|
||||||
|
function renderDropDown(signal, values) {
|
||||||
|
return function(_) {
|
||||||
var entries = JS.fromList(values);
|
var entries = JS.fromList(values);
|
||||||
var events = Signal.constant(entries[0]._1);
|
|
||||||
|
|
||||||
var drop = newNode('select');
|
var drop = newNode('select');
|
||||||
drop.style.border = '0 solid';
|
drop.style.border = '0 solid';
|
||||||
|
drop.style.pointerEvents = 'auto';
|
||||||
for (var i = 0; i < entries.length; ++i) {
|
for (var i = 0; i < entries.length; ++i) {
|
||||||
var option = newNode('option');
|
var option = newNode('option');
|
||||||
var name = JS.fromString(entries[i]._0);
|
var name = JS.fromString(entries[i]._0);
|
||||||
|
@ -29,7 +36,7 @@ Elm.Native.Graphics.Input.make = function(elm) {
|
||||||
drop.appendChild(option);
|
drop.appendChild(option);
|
||||||
}
|
}
|
||||||
drop.addEventListener('change', function() {
|
drop.addEventListener('change', function() {
|
||||||
elm.notify(events.id, entries[drop.selectedIndex]._1);
|
elm.notify(signal.id, entries[drop.selectedIndex]._1);
|
||||||
});
|
});
|
||||||
|
|
||||||
var t = drop.cloneNode(true);
|
var t = drop.cloneNode(true);
|
||||||
|
@ -40,89 +47,96 @@ Elm.Native.Graphics.Input.make = function(elm) {
|
||||||
var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
|
var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
|
||||||
var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
|
var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
|
||||||
elm.node.removeChild(t);
|
elm.node.removeChild(t);
|
||||||
|
return drop;
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
||||||
var element = A3(newElement, w, h, {
|
function updateDropDown(node, oldModel, newModel) {
|
||||||
|
}
|
||||||
|
|
||||||
|
function dropDown(signal, values) {
|
||||||
|
return A3(newElement, 100, 24, {
|
||||||
ctor: 'Custom',
|
ctor: 'Custom',
|
||||||
type: 'DropDown',
|
type: 'DropDown',
|
||||||
render: function render(model) { return drop; },
|
render: renderDropDown(signal,values),
|
||||||
update: function update(node, oldModel, newModel) {},
|
update: updateDropDown,
|
||||||
model: {}
|
model: {}
|
||||||
});
|
});
|
||||||
|
|
||||||
return Tuple2(Signal.constant(element), events);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
function buttons(defaultValue) {
|
function renderButton(model) {
|
||||||
var events = Signal.constant(defaultValue);
|
var node = newNode('button');
|
||||||
|
node.style.display = 'block';
|
||||||
function render(model) {
|
node.style.pointerEvents = 'auto';
|
||||||
var b = newNode('button');
|
node.elm_signal = model.signal;
|
||||||
b.style.display = 'block';
|
node.elm_value = model.value;
|
||||||
b.elmEvent = model.event;
|
function click() {
|
||||||
function click() { elm.notify(events.id, b.elmEvent); }
|
elm.notify(node.elm_signal.id, node.elm_value);
|
||||||
b.addEventListener('click', click);
|
}
|
||||||
b.innerHTML = model.text;
|
node.addEventListener('click', click);
|
||||||
return b;
|
node.innerHTML = model.text;
|
||||||
|
return node;
|
||||||
}
|
}
|
||||||
|
|
||||||
function update(node, oldModel, newModel) {
|
function updateButton(node, oldModel, newModel) {
|
||||||
node.elmEvent = newModel.event;
|
node.elm_signal = newModel.signal;
|
||||||
|
node.elm_value = newModel.value;
|
||||||
var txt = newModel.text;
|
var txt = newModel.text;
|
||||||
if (oldModel.text !== txt) node.innerHTML = txt;
|
if (oldModel.text !== txt) node.innerHTML = txt;
|
||||||
}
|
}
|
||||||
|
|
||||||
function button(evnt, txt) {
|
function button(signal, value, text) {
|
||||||
return A3(newElement, 100, 40, {
|
return A3(newElement, 100, 40, {
|
||||||
ctor: 'Custom',
|
ctor: 'Custom',
|
||||||
type: 'Button',
|
type: 'Button',
|
||||||
render: render,
|
render: renderButton,
|
||||||
update: update,
|
update: updateButton,
|
||||||
model: { event:evnt, text:JS.fromString(txt) }
|
model: { signal:signal, value:value, text:JS.fromString(text) }
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
|
||||||
return { _:{}, button:F2(button), events:events };
|
function renderCustomButton(model) {
|
||||||
}
|
|
||||||
|
|
||||||
function customButtons(defaultValue) {
|
|
||||||
var events = Signal.constant(defaultValue);
|
|
||||||
|
|
||||||
function render(model) {
|
|
||||||
var btn = newNode('div');
|
var btn = newNode('div');
|
||||||
btn.elmEvent = model.event;
|
btn.style.pointerEvents = 'auto';
|
||||||
|
btn.elm_signal = model.signal;
|
||||||
|
btn.elm_value = model.value;
|
||||||
|
|
||||||
btn.elmUp = Render.render(model.up);
|
btn.elm_up = Render.render(model.up);
|
||||||
btn.elmHover = Render.render(model.hover);
|
btn.elm_hover = Render.render(model.hover);
|
||||||
btn.elmDown = Render.render(model.down);
|
btn.elm_down = Render.render(model.down);
|
||||||
|
|
||||||
function replace(node) {
|
function replace(node) {
|
||||||
if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
|
if (node !== btn.firstChild) {
|
||||||
|
btn.replaceChild(node, btn.firstChild);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
var overCount = 0;
|
var overCount = 0;
|
||||||
function over(e) {
|
function over(e) {
|
||||||
if (overCount++ > 0) return;
|
if (overCount++ > 0) return;
|
||||||
replace(btn.elmHover);
|
replace(btn.elm_hover);
|
||||||
}
|
}
|
||||||
function out(e) {
|
function out(e) {
|
||||||
if (btn.contains(e.toElement || e.relatedTarget)) return;
|
if (btn.contains(e.toElement || e.relatedTarget)) return;
|
||||||
overCount = 0;
|
overCount = 0;
|
||||||
replace(btn.elmUp);
|
replace(btn.elm_up);
|
||||||
}
|
}
|
||||||
function up() {
|
function up() {
|
||||||
replace(btn.elmHover);
|
replace(btn.elm_hover);
|
||||||
elm.notify(events.id, btn.elmEvent);
|
elm.notify(btn.elm_signal.id, btn.elm_value);
|
||||||
|
}
|
||||||
|
function down() {
|
||||||
|
replace(btn.elm_down);
|
||||||
}
|
}
|
||||||
function down() { replace(btn.elmDown); }
|
|
||||||
btn.addEventListener('mouseover', over);
|
btn.addEventListener('mouseover', over);
|
||||||
btn.addEventListener('mouseout' , out);
|
btn.addEventListener('mouseout' , out);
|
||||||
btn.addEventListener('mousedown', down);
|
btn.addEventListener('mousedown', down);
|
||||||
btn.addEventListener('mouseup' , up);
|
btn.addEventListener('mouseup' , up);
|
||||||
|
|
||||||
btn.appendChild(btn.elmUp);
|
btn.appendChild(btn.elm_up);
|
||||||
|
|
||||||
var clicker = newNode('div');
|
var clicker = newNode('div');
|
||||||
clicker.style.width = btn.elmUp.style.width;
|
clicker.style.width = btn.elm_up.style.width;
|
||||||
clicker.style.height = btn.elmUp.style.height;
|
clicker.style.height = btn.elm_up.style.height;
|
||||||
clicker.style.position = 'absolute';
|
clicker.style.position = 'absolute';
|
||||||
clicker.style.top = 0;
|
clicker.style.top = 0;
|
||||||
btn.appendChild(clicker);
|
btn.appendChild(clicker);
|
||||||
|
@ -130,75 +144,71 @@ Elm.Native.Graphics.Input.make = function(elm) {
|
||||||
return btn;
|
return btn;
|
||||||
}
|
}
|
||||||
|
|
||||||
function update(node, oldModel, newModel) {
|
function updateCustomButton(node, oldModel, newModel) {
|
||||||
node.elmEvent = newModel.event;
|
var signal = newModel.signal;
|
||||||
Render.update(node.elmUp, oldModel.up, newModel.up)
|
node.elm_up.elm_signal = signal;
|
||||||
Render.update(node.elmHover, oldModel.hover, newModel.hover)
|
node.elm_hover.elm_signal = signal;
|
||||||
Render.update(node.elmDown, oldModel.down, newModel.down)
|
node.elm_down.elm_signal = signal;
|
||||||
|
|
||||||
|
var value = newModel.value;
|
||||||
|
node.elm_up.elm_value = value;
|
||||||
|
node.elm_hover.elm_value = value;
|
||||||
|
node.elm_down.elm_value = value;
|
||||||
|
|
||||||
|
Render.update(node.elm_up, oldModel.up, newModel.up)
|
||||||
|
Render.update(node.elm_hover, oldModel.hover, newModel.hover)
|
||||||
|
Render.update(node.elm_down, oldModel.down, newModel.down)
|
||||||
}
|
}
|
||||||
|
|
||||||
function button(evnt, up, hover, down) {
|
function max3(a,b,c) {
|
||||||
|
var ab = a > b ? a : b;
|
||||||
|
return ab > c ? ab : c;
|
||||||
|
}
|
||||||
|
|
||||||
|
function customButton(signal, value, up, hover, down) {
|
||||||
return A3(newElement,
|
return A3(newElement,
|
||||||
Math.max(up.props.width, hover.props.width, down.props.width),
|
max3(up.props.width, hover.props.width, down.props.width),
|
||||||
Math.max(up.props.height, hover.props.height, down.props.height),
|
max3(up.props.height, hover.props.height, down.props.height),
|
||||||
{ ctor: 'Custom',
|
{ ctor: 'Custom',
|
||||||
type: 'CustomButton',
|
type: 'CustomButton',
|
||||||
render: render,
|
render: renderCustomButton,
|
||||||
update: update,
|
update: updateCustomButton,
|
||||||
model: { event:evnt, up:up, hover:hover, down:down }
|
model: { signal:signal, value:value, up:up, hover:hover, down:down }
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
|
||||||
return { _:{}, customButton:F4(button), events:events };
|
function renderCheckbox(model) {
|
||||||
|
var node = newNode('input');
|
||||||
|
node.type = 'checkbox';
|
||||||
|
node.checked = model.checked;
|
||||||
|
node.style.display = 'block';
|
||||||
|
node.style.pointerEvents = 'auto';
|
||||||
|
node.elm_signal = model.signal;
|
||||||
|
node.elm_handler = model.handler;
|
||||||
|
function change() {
|
||||||
|
elm.notify(node.elm_signal.id, node.elm_handler(node.checked));
|
||||||
|
}
|
||||||
|
node.addEventListener('change', change);
|
||||||
|
return node;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
function updateCheckbox(node, oldModel, newModel) {
|
||||||
function hoverables(defaultValue) {
|
node.elm_signal = newModel.signal;
|
||||||
var events = Signal.constant(defaultValue);
|
node.elm_handler = newModel.handler;
|
||||||
function hoverable(handler, elem) {
|
|
||||||
function onHover(bool) {
|
|
||||||
elm.notify(events.id, handler(bool));
|
|
||||||
}
|
|
||||||
var props = Utils.replace([['hover',onHover]], elem.props);
|
|
||||||
return { props:props, element:elem.element };
|
|
||||||
}
|
|
||||||
return { _:{}, hoverable:F2(hoverable), events:events };
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
function checkboxes(defaultValue) {
|
|
||||||
var events = Signal.constant(defaultValue);
|
|
||||||
|
|
||||||
function render(model) {
|
|
||||||
var b = newNode('input');
|
|
||||||
b.type = 'checkbox';
|
|
||||||
b.checked = model.checked;
|
|
||||||
b.style.display = 'block';
|
|
||||||
b.elmHandler = model.handler;
|
|
||||||
function change() { elm.notify(events.id, b.elmHandler(b.checked)); }
|
|
||||||
b.addEventListener('change', change);
|
|
||||||
return b;
|
|
||||||
}
|
|
||||||
|
|
||||||
function update(node, oldModel, newModel) {
|
|
||||||
node.elmHandler = newModel.handler;
|
|
||||||
node.checked = newModel.checked;
|
node.checked = newModel.checked;
|
||||||
return true;
|
return true;
|
||||||
}
|
}
|
||||||
|
|
||||||
function box(handler, checked) {
|
function checkbox(signal, handler, checked) {
|
||||||
return A3(newElement, 13, 13, {
|
return A3(newElement, 13, 13, {
|
||||||
ctor: 'Custom',
|
ctor: 'Custom',
|
||||||
type: 'CheckBox',
|
type: 'CheckBox',
|
||||||
render: render,
|
render: renderCheckbox,
|
||||||
update: update,
|
update: updateCheckbox,
|
||||||
model: { checked:checked, handler:handler }
|
model: { signal:signal, handler:handler, checked:checked }
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
|
||||||
return { _:{}, checkbox:F2(box), events:events };
|
|
||||||
}
|
|
||||||
|
|
||||||
function setRange(node, start, end, dir) {
|
function setRange(node, start, end, dir) {
|
||||||
if (node.parentNode) {
|
if (node.parentNode) {
|
||||||
node.setSelectionRange(start, end, dir);
|
node.setSelectionRange(start, end, dir);
|
||||||
|
@ -207,97 +217,191 @@ Elm.Native.Graphics.Input.make = function(elm) {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
function mkTextPool(type) { return function fields(defaultValue) {
|
function updateIfNeeded(css, attribute, latestAttribute) {
|
||||||
var events = Signal.constant(defaultValue);
|
if (css[attribute] !== latestAttribute) {
|
||||||
|
css[attribute] = latestAttribute;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
function cssDimensions(dimensions) {
|
||||||
|
return dimensions.top + 'px ' +
|
||||||
|
dimensions.right + 'px ' +
|
||||||
|
dimensions.bottom + 'px ' +
|
||||||
|
dimensions.left + 'px';
|
||||||
|
}
|
||||||
|
function updateFieldStyle(css, style) {
|
||||||
|
updateIfNeeded(css, 'padding', cssDimensions(style.padding));
|
||||||
|
|
||||||
var state = null;
|
var outline = style.outline;
|
||||||
|
updateIfNeeded(css, 'border-width', cssDimensions(outline.width));
|
||||||
|
updateIfNeeded(css, 'border-color', toCss(outline.color));
|
||||||
|
updateIfNeeded(css, 'border-radius', outline.radius + 'px');
|
||||||
|
|
||||||
function render(model) {
|
var highlight = style.highlight;
|
||||||
|
if (highlight.width === 0) {
|
||||||
|
css.outline = 'none';
|
||||||
|
} else {
|
||||||
|
updateIfNeeded(css, 'outline-width', highlight.width + 'px');
|
||||||
|
updateIfNeeded(css, 'outline-color', toCss(highlight.color));
|
||||||
|
}
|
||||||
|
|
||||||
|
var textStyle = style.style;
|
||||||
|
updateIfNeeded(css, 'color', toCss(textStyle.color));
|
||||||
|
if (textStyle.typeface.ctor !== '[]') {
|
||||||
|
updateIfNeeded(css, 'font-family', Text.toTypefaces(textStyle.typeface));
|
||||||
|
}
|
||||||
|
if (textStyle.height.ctor !== "Nothing") {
|
||||||
|
updateIfNeeded(css, 'font-size', textStyle.height._0 + 'px');
|
||||||
|
}
|
||||||
|
updateIfNeeded(css, 'font-weight', textStyle.bold ? 'bold' : 'normal');
|
||||||
|
updateIfNeeded(css, 'font-style', textStyle.italic ? 'italic' : 'normal');
|
||||||
|
if (textStyle.line.ctor !== 'Nothing') {
|
||||||
|
updateIfNeeded(css, 'text-decoration', Text.toLine(textStyle.line._0));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
function renderField(model) {
|
||||||
var field = newNode('input');
|
var field = newNode('input');
|
||||||
field.elmHandler = model.handler;
|
updateFieldStyle(field.style, model.style);
|
||||||
|
field.style.borderStyle = 'solid';
|
||||||
|
field.style.pointerEvents = 'auto';
|
||||||
|
|
||||||
field.id = 'test';
|
field.type = model.type;
|
||||||
field.type = type;
|
|
||||||
field.placeholder = JS.fromString(model.placeHolder);
|
field.placeholder = JS.fromString(model.placeHolder);
|
||||||
field.value = JS.fromString(model.state.string);
|
field.value = JS.fromString(model.content.string);
|
||||||
setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
|
|
||||||
field.style.border = 'none';
|
|
||||||
state = model.state;
|
|
||||||
|
|
||||||
function update() {
|
field.elm_signal = model.signal;
|
||||||
var start = field.selectionStart,
|
field.elm_handler = model.handler;
|
||||||
end = field.selectionEnd;
|
field.elm_old_value = field.value;
|
||||||
if (field.selectionDirection === 'backward') {
|
|
||||||
start = end;
|
function inputUpdate(event) {
|
||||||
end = field.selectionStart;
|
var curr = field.elm_old_value;
|
||||||
|
var next = field.value;
|
||||||
|
if (curr === next) {
|
||||||
|
return;
|
||||||
}
|
}
|
||||||
state = { _:{},
|
|
||||||
string:JS.toString(field.value),
|
var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
|
||||||
selectionStart:start,
|
var start = field.selectionStart;
|
||||||
selectionEnd:end };
|
var end = field.selectionEnd;
|
||||||
elm.notify(events.id, field.elmHandler(state));
|
field.value = field.elm_old_value;
|
||||||
|
|
||||||
|
elm.notify(field.elm_signal.id, field.elm_handler({
|
||||||
|
_:{},
|
||||||
|
string: JS.toString(next),
|
||||||
|
selection: {
|
||||||
|
_:{},
|
||||||
|
start: start,
|
||||||
|
end: end,
|
||||||
|
direction: { ctor: direction }
|
||||||
|
},
|
||||||
|
}));
|
||||||
}
|
}
|
||||||
function mousedown() {
|
|
||||||
update();
|
function mouseUpdate(event) {
|
||||||
|
var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
|
||||||
|
elm.notify(field.elm_signal.id, field.elm_handler({
|
||||||
|
_:{},
|
||||||
|
string: field.value,
|
||||||
|
selection: {
|
||||||
|
_:{},
|
||||||
|
start: field.selectionStart,
|
||||||
|
end: field.selectionEnd,
|
||||||
|
direction: { ctor: direction }
|
||||||
|
},
|
||||||
|
}));
|
||||||
|
}
|
||||||
|
function mousedown(event) {
|
||||||
|
mouseUpdate(event);
|
||||||
elm.node.addEventListener('mouseup', mouseup);
|
elm.node.addEventListener('mouseup', mouseup);
|
||||||
}
|
}
|
||||||
function mouseup() {
|
function mouseup(event) {
|
||||||
update();
|
mouseUpdate(event);
|
||||||
elm.node.removeEventListener('mouseup', mouseup)
|
elm.node.removeEventListener('mouseup', mouseup)
|
||||||
}
|
}
|
||||||
field.addEventListener('keyup', update);
|
field.addEventListener('input', inputUpdate);
|
||||||
field.addEventListener('mousedown', mousedown);
|
field.addEventListener('mousedown', mousedown);
|
||||||
|
field.addEventListener('focus', function() {
|
||||||
|
field.elm_hasFocus = true;
|
||||||
|
});
|
||||||
|
field.addEventListener('blur', function() {
|
||||||
|
field.elm_hasFocus = false;
|
||||||
|
});
|
||||||
|
|
||||||
return field;
|
return field;
|
||||||
}
|
}
|
||||||
|
|
||||||
function update(node, oldModel, newModel) {
|
function updateField(field, oldModel, newModel) {
|
||||||
node.elmHandler = newModel.handler;
|
if (oldModel.style !== newModel.style) {
|
||||||
if (state === newModel.state) return;
|
updateFieldStyle(field.style, newModel.style);
|
||||||
var newStr = JS.fromString(newModel.state.string);
|
|
||||||
if (node.value !== newStr) node.value = newStr;
|
|
||||||
|
|
||||||
var start = newModel.state.selectionStart;
|
|
||||||
var end = newModel.state.selectionEnd;
|
|
||||||
var direction = 'forward';
|
|
||||||
if (end < start) {
|
|
||||||
start = end;
|
|
||||||
end = newModel.state.selectionStart;
|
|
||||||
direction = 'backward';
|
|
||||||
}
|
}
|
||||||
|
field.elm_signal = newModel.signal;
|
||||||
|
field.elm_handler = newModel.handler;
|
||||||
|
|
||||||
if (node.selectionStart !== start
|
field.type = newModel.type;
|
||||||
|| node.selectionEnd !== end
|
field.placeholder = JS.fromString(newModel.placeHolder);
|
||||||
|| node.selectionDirection !== direction) {
|
var value = JS.fromString(newModel.content.string);
|
||||||
setRange(node, start, end, direction);
|
field.value = value;
|
||||||
|
field.elm_old_value = value;
|
||||||
|
if (field.elm_hasFocus) {
|
||||||
|
var selection = newModel.content.selection;
|
||||||
|
var direction = selection.direction.ctor === 'Forward' ? 'forward' : 'backward';
|
||||||
|
setRange(field, selection.start, selection.end, direction);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
function field(handler, placeHolder, state) {
|
function mkField(type) {
|
||||||
return A3(newElement, 200, 30,
|
function field(style, signal, handler, placeHolder, content) {
|
||||||
{ ctor: 'Custom',
|
var padding = style.padding;
|
||||||
type: type + 'Input',
|
var outline = style.outline.width;
|
||||||
render: render,
|
var adjustWidth = padding.left + padding.right + outline.left + outline.right;
|
||||||
update: update,
|
var adjustHeight = padding.top + padding.bottom + outline.top + outline.bottom;
|
||||||
model: { handler:handler,
|
return A3(newElement, 200, 30, {
|
||||||
|
ctor: 'Custom',
|
||||||
|
type: type + 'Field',
|
||||||
|
adjustWidth: adjustWidth,
|
||||||
|
adjustHeight: adjustHeight,
|
||||||
|
render: renderField,
|
||||||
|
update: updateField,
|
||||||
|
model: {
|
||||||
|
signal:signal,
|
||||||
|
handler:handler,
|
||||||
placeHolder:placeHolder,
|
placeHolder:placeHolder,
|
||||||
state:state }
|
content:content,
|
||||||
|
style:style,
|
||||||
|
type:type
|
||||||
|
}
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
|
return F5(field);
|
||||||
return { _:{}, field:F3(field), events:events };
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
function hoverable(signal, handler, elem) {
|
||||||
|
function onHover(bool) {
|
||||||
|
elm.notify(signal.id, handler(bool));
|
||||||
|
}
|
||||||
|
var props = Utils.replace([['hover',onHover]], elem.props);
|
||||||
|
return { props:props, element:elem.element };
|
||||||
|
}
|
||||||
|
|
||||||
|
function clickable(signal, value, elem) {
|
||||||
|
function onClick(bool) {
|
||||||
|
elm.notify(signal.id, value);
|
||||||
|
}
|
||||||
|
var props = Utils.replace([['click',onClick]], elem.props);
|
||||||
|
return { props:props, element:elem.element };
|
||||||
}
|
}
|
||||||
|
|
||||||
return elm.Native.Graphics.Input.values = {
|
return elm.Native.Graphics.Input.values = {
|
||||||
buttons:buttons,
|
input:input,
|
||||||
customButtons:customButtons,
|
button:F3(button),
|
||||||
hoverables:hoverables,
|
customButton:F5(customButton),
|
||||||
checkboxes:checkboxes,
|
checkbox:F3(checkbox),
|
||||||
fields:mkTextPool('text'),
|
dropDown:F2(dropDown),
|
||||||
emails:mkTextPool('email'),
|
field:mkField('text'),
|
||||||
passwords:mkTextPool('password'),
|
email:mkField('email'),
|
||||||
dropDown:dropDown
|
password:mkField('password'),
|
||||||
|
hoverable:F3(hoverable),
|
||||||
|
clickable:F3(clickable)
|
||||||
};
|
};
|
||||||
|
|
||||||
};
|
};
|
||||||
|
|
|
@ -15,18 +15,16 @@ Elm.Native.Regex.make = function(elm) {
|
||||||
function caseInsensitive(re) {
|
function caseInsensitive(re) {
|
||||||
return new RegExp(re.source, 'gi');
|
return new RegExp(re.source, 'gi');
|
||||||
}
|
}
|
||||||
function pattern(raw) {
|
function regex(raw) {
|
||||||
return new RegExp(raw, 'g');
|
return new RegExp(raw, 'g');
|
||||||
}
|
}
|
||||||
|
|
||||||
function contains(re, string) {
|
function contains(re, string) {
|
||||||
return re.test(JS.fromString(string));
|
return JS.fromString(string).match(re) !== null;
|
||||||
}
|
}
|
||||||
|
|
||||||
function findAll(re, string) {
|
|
||||||
return find(Infinity, re, string);
|
|
||||||
}
|
|
||||||
function find(n, re, str) {
|
function find(n, re, str) {
|
||||||
|
n = n.ctor === "All" ? Infinity : n._0;
|
||||||
var out = [];
|
var out = [];
|
||||||
var number = 0;
|
var number = 0;
|
||||||
var string = JS.fromString(str);
|
var string = JS.fromString(str);
|
||||||
|
@ -51,10 +49,8 @@ Elm.Native.Regex.make = function(elm) {
|
||||||
return JS.toList(out);
|
return JS.toList(out);
|
||||||
}
|
}
|
||||||
|
|
||||||
function replaceAll(re, replacer, string) {
|
|
||||||
return replace(Infinity, re, replacer, string);
|
|
||||||
}
|
|
||||||
function replace(n, re, replacer, string) {
|
function replace(n, re, replacer, string) {
|
||||||
|
n = n.ctor === "All" ? Infinity : n._0;
|
||||||
var count = 0;
|
var count = 0;
|
||||||
function jsReplacer(match) {
|
function jsReplacer(match) {
|
||||||
if (count++ > n) return match;
|
if (count++ > n) return match;
|
||||||
|
@ -77,10 +73,10 @@ Elm.Native.Regex.make = function(elm) {
|
||||||
return string.replace(re, jsReplacer);
|
return string.replace(re, jsReplacer);
|
||||||
}
|
}
|
||||||
|
|
||||||
function split(re, string) {
|
function split(n, re, str) {
|
||||||
|
if (n === Infinity) {
|
||||||
return JS.toList(JS.fromString(string).split(re));
|
return JS.toList(JS.fromString(string).split(re));
|
||||||
}
|
}
|
||||||
function splitN(n, re, str) {
|
|
||||||
var string = JS.fromString(str);
|
var string = JS.fromString(str);
|
||||||
var result;
|
var result;
|
||||||
var out = [];
|
var out = [];
|
||||||
|
@ -95,18 +91,13 @@ Elm.Native.Regex.make = function(elm) {
|
||||||
}
|
}
|
||||||
|
|
||||||
return Elm.Native.Regex.values = {
|
return Elm.Native.Regex.values = {
|
||||||
pattern: pattern,
|
regex: regex,
|
||||||
caseInsensitive: caseInsensitive,
|
caseInsensitive: caseInsensitive,
|
||||||
escape: escape,
|
escape: escape,
|
||||||
|
|
||||||
contains: F2(contains),
|
contains: F2(contains),
|
||||||
findAll: F2(findAll),
|
|
||||||
find: F3(find),
|
find: F3(find),
|
||||||
|
|
||||||
replaceAll: F3(replaceAll),
|
|
||||||
replace: F4(replace),
|
replace: F4(replace),
|
||||||
|
split: F3(split),
|
||||||
split: F2(split),
|
|
||||||
splitN: F3(splitN),
|
|
||||||
};
|
};
|
||||||
};
|
};
|
|
@ -6,10 +6,7 @@ Elm.Native.Show.make = function(elm) {
|
||||||
|
|
||||||
var NList = Elm.Native.List.make(elm);
|
var NList = Elm.Native.List.make(elm);
|
||||||
var List = Elm.List.make(elm);
|
var List = Elm.List.make(elm);
|
||||||
var Maybe = Elm.Maybe.make(elm);
|
|
||||||
var JS = Elm.JavaScript.make(elm);
|
|
||||||
var Dict = Elm.Dict.make(elm);
|
var Dict = Elm.Dict.make(elm);
|
||||||
var Json = Elm.Json.make(elm);
|
|
||||||
var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;
|
var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;
|
||||||
|
|
||||||
var toString = function(v) {
|
var toString = function(v) {
|
||||||
|
|
|
@ -5,14 +5,15 @@ Elm.Native.Http.make = function(elm) {
|
||||||
elm.Native.Http = elm.Native.Http || {};
|
elm.Native.Http = elm.Native.Http || {};
|
||||||
if (elm.Native.Http.values) return elm.Native.Http.values;
|
if (elm.Native.Http.values) return elm.Native.Http.values;
|
||||||
|
|
||||||
|
|
||||||
var JS = Elm.JavaScript.make(elm);
|
var JS = Elm.JavaScript.make(elm);
|
||||||
var List = Elm.List.make(elm);
|
var List = Elm.List.make(elm);
|
||||||
var Signal = Elm.Signal.make(elm);
|
var Signal = Elm.Signal.make(elm);
|
||||||
|
|
||||||
|
function registerReq(queue,responses) {
|
||||||
function registerReq(queue,responses) { return function(req) {
|
return function(req) {
|
||||||
if (req.url.ctor !== '[]') { sendReq(queue,responses,req); }
|
if (req.url.length > 0) {
|
||||||
|
sendReq(queue,responses,req);
|
||||||
|
}
|
||||||
};
|
};
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -30,9 +31,10 @@ Elm.Native.Http.make = function(elm) {
|
||||||
var response = { value: { ctor:'Waiting' } };
|
var response = { value: { ctor:'Waiting' } };
|
||||||
queue.push(response);
|
queue.push(response);
|
||||||
|
|
||||||
var request = null;
|
var request = (window.ActiveXObject
|
||||||
if (window.ActiveXObject) { request = new ActiveXObject("Microsoft.XMLHTTP"); }
|
? new ActiveXObject("Microsoft.XMLHTTP")
|
||||||
if (window.XMLHttpRequest) { request = new XMLHttpRequest(); }
|
: new XMLHttpRequest());
|
||||||
|
|
||||||
request.onreadystatechange = function(e) {
|
request.onreadystatechange = function(e) {
|
||||||
if (request.readyState === 4) {
|
if (request.readyState === 4) {
|
||||||
response.value = (request.status >= 200 && request.status < 300 ?
|
response.value = (request.status >= 200 && request.status < 300 ?
|
||||||
|
@ -56,6 +58,7 @@ Elm.Native.Http.make = function(elm) {
|
||||||
return A3( Signal.lift2, f, responses, sender );
|
return A3( Signal.lift2, f, responses, sender );
|
||||||
}
|
}
|
||||||
|
|
||||||
return elm.Native.Http.values = {send:send};
|
return elm.Native.Http.values = {
|
||||||
|
send:send
|
||||||
|
};
|
||||||
};
|
};
|
||||||
|
|
|
@ -20,15 +20,12 @@ Elm.Native.Mouse.make = function(elm) {
|
||||||
y.defaultNumberOfKids = 0;
|
y.defaultNumberOfKids = 0;
|
||||||
|
|
||||||
var isDown = Signal.constant(false);
|
var isDown = Signal.constant(false);
|
||||||
var isClicked = Signal.constant(false);
|
|
||||||
var clicks = Signal.constant(Utils.Tuple0);
|
var clicks = Signal.constant(Utils.Tuple0);
|
||||||
|
|
||||||
var node = elm.display === ElmRuntime.Display.FULLSCREEN ? document : elm.node;
|
var node = elm.display === ElmRuntime.Display.FULLSCREEN ? document : elm.node;
|
||||||
|
|
||||||
elm.addListener([isClicked.id, clicks.id], node, 'click', function click() {
|
elm.addListener([clicks.id], node, 'click', function click() {
|
||||||
elm.notify(isClicked.id, true);
|
|
||||||
elm.notify(clicks.id, Utils.Tuple0);
|
elm.notify(clicks.id, Utils.Tuple0);
|
||||||
elm.notify(isClicked.id, false);
|
|
||||||
});
|
});
|
||||||
elm.addListener([isDown.id], node, 'mousedown', function down() {
|
elm.addListener([isDown.id], node, 'mousedown', function down() {
|
||||||
elm.notify(isDown.id, true);
|
elm.notify(isDown.id, true);
|
||||||
|
@ -44,7 +41,6 @@ Elm.Native.Mouse.make = function(elm) {
|
||||||
position: position,
|
position: position,
|
||||||
x:x,
|
x:x,
|
||||||
y:y,
|
y:y,
|
||||||
isClicked: isClicked,
|
|
||||||
isDown: isDown,
|
isDown: isDown,
|
||||||
clicks: clicks
|
clicks: clicks
|
||||||
};
|
};
|
||||||
|
|
|
@ -127,12 +127,6 @@ Elm.Native.Signal.make = function(elm) {
|
||||||
input.kids.push(this);
|
input.kids.push(this);
|
||||||
}
|
}
|
||||||
|
|
||||||
function dropWhen(s1,b,s2) {
|
|
||||||
var pairs = lift2( F2(function(x,y){return {x:x,y:y};}), s1, s2 );
|
|
||||||
var dropped = new DropIf(function(p){return p.x;},{x:true,y:b},pairs);
|
|
||||||
return lift(function(p){return p.y;}, dropped);
|
|
||||||
}
|
|
||||||
|
|
||||||
function timestamp(a) {
|
function timestamp(a) {
|
||||||
function update() { return Utils.Tuple2(Date.now(), a.value); }
|
function update() { return Utils.Tuple2(Date.now(), a.value); }
|
||||||
return new LiftN(update, [a]);
|
return new LiftN(update, [a]);
|
||||||
|
@ -225,9 +219,6 @@ Elm.Native.Signal.make = function(elm) {
|
||||||
keepIf : F3(function(pred,base,sig) {
|
keepIf : F3(function(pred,base,sig) {
|
||||||
return new DropIf(function(x) {return !pred(x);},base,sig); }),
|
return new DropIf(function(x) {return !pred(x);},base,sig); }),
|
||||||
dropIf : F3(function(pred,base,sig) { return new DropIf(pred,base,sig); }),
|
dropIf : F3(function(pred,base,sig) { return new DropIf(pred,base,sig); }),
|
||||||
keepWhen : F3(function(s1,b,s2) {
|
|
||||||
return dropWhen(lift(function(b){return !b;},s1), b, s2); }),
|
|
||||||
dropWhen : F3(dropWhen),
|
|
||||||
dropRepeats : function(s) { return new DropRepeats(s);},
|
dropRepeats : function(s) { return new DropRepeats(s);},
|
||||||
sampleOn : F2(sampleOn),
|
sampleOn : F2(sampleOn),
|
||||||
timestamp : timestamp
|
timestamp : timestamp
|
||||||
|
|
|
@ -144,7 +144,8 @@ Elm.Native.String.make = function(elm) {
|
||||||
return str.indexOf(sub) === 0;
|
return str.indexOf(sub) === 0;
|
||||||
}
|
}
|
||||||
function endsWith(sub, str) {
|
function endsWith(sub, str) {
|
||||||
return str.lastIndexOf(sub) === str.length - sub.length;
|
return str.length >= sub.length &&
|
||||||
|
str.lastIndexOf(sub) === str.length - sub.length;
|
||||||
}
|
}
|
||||||
function indexes(sub, str) {
|
function indexes(sub, str) {
|
||||||
var subLen = sub.length;
|
var subLen = sub.length;
|
||||||
|
|
|
@ -4,11 +4,10 @@ Elm.Native.Text.make = function(elm) {
|
||||||
elm.Native.Text = elm.Native.Text || {};
|
elm.Native.Text = elm.Native.Text || {};
|
||||||
if (elm.Native.Text.values) return elm.Native.Text.values;
|
if (elm.Native.Text.values) return elm.Native.Text.values;
|
||||||
|
|
||||||
var JS = Elm.JavaScript.make(elm);
|
var toCss = Elm.Native.Color.make(elm).toCss;
|
||||||
var Utils = Elm.Native.Utils.make(elm);
|
|
||||||
var Color = Elm.Native.Color.make(elm);
|
|
||||||
var Element = Elm.Graphics.Element.make(elm);
|
var Element = Elm.Graphics.Element.make(elm);
|
||||||
var show = Elm.Native.Show.make(elm).show;
|
var List = Elm.Native.List.make(elm);
|
||||||
|
var Utils = Elm.Native.Utils.make(elm);
|
||||||
|
|
||||||
function makeSpaces(s) {
|
function makeSpaces(s) {
|
||||||
if (s.length == 0) { return s; }
|
if (s.length == 0) { return s; }
|
||||||
|
@ -51,13 +50,51 @@ Elm.Native.Text.make = function(elm) {
|
||||||
return arr.join('<br/>');
|
return arr.join('<br/>');
|
||||||
}
|
}
|
||||||
|
|
||||||
function toText(str) { return Utils.txt(properEscape(JS.fromString(str))); }
|
function toText(str) { return Utils.txt(properEscape(str)); }
|
||||||
|
|
||||||
|
// conversions from Elm values to CSS
|
||||||
|
function toTypefaces(list) {
|
||||||
|
var typefaces = List.toArray(list);
|
||||||
|
for (var i = typefaces.length; i--; ) {
|
||||||
|
var typeface = typefaces[i];
|
||||||
|
if (typeface.indexOf(' ') > -1) {
|
||||||
|
typefaces[i] = "'" + typeface + "'";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return typefaces.join(',');
|
||||||
|
}
|
||||||
|
function toLine(line) {
|
||||||
|
var ctor = line.ctor;
|
||||||
|
return ctor === 'Under' ? 'underline' :
|
||||||
|
ctor === 'Over' ? 'overline' : 'line-through';
|
||||||
|
}
|
||||||
|
|
||||||
|
// setting styles of Text
|
||||||
|
function style(style, text) {
|
||||||
|
var newText = '<span style="color:' + toCss(style.color) + ';'
|
||||||
|
if (style.typeface.ctor !== '[]') {
|
||||||
|
newText += 'font-family:' + toTypefaces(style.typeface) + ';'
|
||||||
|
}
|
||||||
|
if (style.height.ctor !== "Nothing") {
|
||||||
|
newText += 'font-size:' + style.height._0 + 'px;';
|
||||||
|
}
|
||||||
|
if (style.bold) {
|
||||||
|
newText += 'font-weight:bold;';
|
||||||
|
}
|
||||||
|
if (style.italic) {
|
||||||
|
newText += 'font-style:italic;';
|
||||||
|
}
|
||||||
|
if (style.line.ctor !== 'Nothing') {
|
||||||
|
newText += 'text-decoration:' + toLine(style.line._0) + ';';
|
||||||
|
}
|
||||||
|
newText += '">' + Utils.makeText(text) + '</span>'
|
||||||
|
return Utils.txt(newText);
|
||||||
|
}
|
||||||
function height(px, text) {
|
function height(px, text) {
|
||||||
return { style: 'font-size:' + px + 'px;', text:text }
|
return { style: 'font-size:' + px + 'px;', text:text }
|
||||||
}
|
}
|
||||||
function typeface(name, text) {
|
function typeface(names, text) {
|
||||||
return { style: 'font-family:' + name + ';', text:text }
|
return { style: 'font-family:' + toTypefaces(names) + ';', text:text }
|
||||||
}
|
}
|
||||||
function monospace(text) {
|
function monospace(text) {
|
||||||
return { style: 'font-family:monospace;', text:text }
|
return { style: 'font-family:monospace;', text:text }
|
||||||
|
@ -71,25 +108,16 @@ Elm.Native.Text.make = function(elm) {
|
||||||
function link(href, text) {
|
function link(href, text) {
|
||||||
return { href: toText(href), text:text };
|
return { href: toText(href), text:text };
|
||||||
}
|
}
|
||||||
function underline(text) {
|
function line(line, text) {
|
||||||
return { line: ' underline', text:text };
|
return { style: 'text-decoration:' + toLine(line) + ';', text:text };
|
||||||
}
|
|
||||||
function overline(text) {
|
|
||||||
return { line: ' overline', text:text };
|
|
||||||
}
|
|
||||||
function strikeThrough(text) {
|
|
||||||
return { line: ' line-through', text:text };
|
|
||||||
}
|
}
|
||||||
|
|
||||||
function color(c, text) {
|
function color(color, text) {
|
||||||
var color = (c._3 === 1)
|
return { style: 'color:' + toCss(color) + ';', text:text };
|
||||||
? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
|
|
||||||
: ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
|
|
||||||
return { style: 'color:' + color + ';', text:text };
|
|
||||||
}
|
}
|
||||||
|
|
||||||
function position(align) {
|
function block(align) {
|
||||||
function create(text) {
|
return function(text) {
|
||||||
var raw = {
|
var raw = {
|
||||||
ctor :'RawHtml',
|
ctor :'RawHtml',
|
||||||
html : Utils.makeText(text),
|
html : Utils.makeText(text),
|
||||||
|
@ -100,7 +128,6 @@ Elm.Native.Text.make = function(elm) {
|
||||||
var pos = A2(Utils.htmlHeight, 0, raw);
|
var pos = A2(Utils.htmlHeight, 0, raw);
|
||||||
return A3(Element.newElement, pos._0, pos._1, raw);
|
return A3(Element.newElement, pos._0, pos._1, raw);
|
||||||
}
|
}
|
||||||
return create;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
function markdown(text, guid) {
|
function markdown(text, guid) {
|
||||||
|
@ -115,36 +142,25 @@ Elm.Native.Text.make = function(elm) {
|
||||||
return A3(Element.newElement, pos._0, pos._1, raw);
|
return A3(Element.newElement, pos._0, pos._1, raw);
|
||||||
}
|
}
|
||||||
|
|
||||||
var text = position('left');
|
|
||||||
function asText(v) {
|
|
||||||
return text(monospace(toText(show(v))));
|
|
||||||
}
|
|
||||||
|
|
||||||
function plainText(v) {
|
|
||||||
return text(toText(v));
|
|
||||||
}
|
|
||||||
|
|
||||||
return elm.Native.Text.values = {
|
return elm.Native.Text.values = {
|
||||||
toText: toText,
|
toText: toText,
|
||||||
|
|
||||||
height : F2(height),
|
height : F2(height),
|
||||||
italic : italic,
|
italic : italic,
|
||||||
bold : bold,
|
bold : bold,
|
||||||
underline : underline,
|
line : F2(line),
|
||||||
overline : overline,
|
|
||||||
strikeThrough : strikeThrough,
|
|
||||||
monospace : monospace,
|
monospace : monospace,
|
||||||
typeface : F2(typeface),
|
typeface : F2(typeface),
|
||||||
color : F2(color),
|
color : F2(color),
|
||||||
link : F2(link),
|
link : F2(link),
|
||||||
|
|
||||||
justified : position('justify'),
|
leftAligned : block('left'),
|
||||||
centered : position('center'),
|
rightAligned : block('right'),
|
||||||
righted : position('right'),
|
centered : block('center'),
|
||||||
text : text,
|
justified : block('justify'),
|
||||||
plainText : plainText,
|
|
||||||
markdown : markdown,
|
markdown : markdown,
|
||||||
|
|
||||||
asText : asText,
|
toTypefaces:toTypefaces,
|
||||||
|
toLine:toLine,
|
||||||
};
|
};
|
||||||
};
|
};
|
||||||
|
|
24
libraries/Native/Trampoline.js
Normal file
24
libraries/Native/Trampoline.js
Normal file
|
@ -0,0 +1,24 @@
|
||||||
|
Elm.Native.Trampoline = {};
|
||||||
|
Elm.Native.Trampoline.make = function(elm) {
|
||||||
|
elm.Native = elm.Native || {};
|
||||||
|
elm.Native.Trampoline = elm.Native.Trampoline || {};
|
||||||
|
if (elm.Native.Trampoline.values) return elm.Native.Trampoline.values;
|
||||||
|
|
||||||
|
// trampoline : Trampoline a -> a
|
||||||
|
function trampoline(t) {
|
||||||
|
var tramp = t;
|
||||||
|
while(true) {
|
||||||
|
switch(tramp.ctor) {
|
||||||
|
case "Done":
|
||||||
|
return tramp._0;
|
||||||
|
case "Continue":
|
||||||
|
tramp = tramp._0({ctor: "_Tuple0"});
|
||||||
|
continue;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return elm.Native.Trampoline.values = {
|
||||||
|
trampoline:trampoline
|
||||||
|
};
|
||||||
|
};
|
|
@ -9,7 +9,12 @@ Elm.Native.Utils.make = function(elm) {
|
||||||
if (x === y) return true;
|
if (x === y) return true;
|
||||||
if (typeof x === "object") {
|
if (typeof x === "object") {
|
||||||
var c = 0;
|
var c = 0;
|
||||||
for (var i in x) { ++c; if (!eq(x[i],y[i])) return false; }
|
for (var i in x) {
|
||||||
|
++c;
|
||||||
|
if (!eq(x[i],y[i])) {
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
}
|
||||||
return c === Object.keys(y).length;
|
return c === Object.keys(y).length;
|
||||||
}
|
}
|
||||||
if (typeof x === 'function') {
|
if (typeof x === 'function') {
|
||||||
|
@ -76,14 +81,8 @@ Elm.Native.Utils.make = function(elm) {
|
||||||
|
|
||||||
function makeText(text) {
|
function makeText(text) {
|
||||||
var style = '';
|
var style = '';
|
||||||
var line = '';
|
|
||||||
var href = '';
|
var href = '';
|
||||||
while (true) {
|
while (true) {
|
||||||
if (text.line) {
|
|
||||||
line += text.line;
|
|
||||||
text = text.text;
|
|
||||||
continue;
|
|
||||||
}
|
|
||||||
if (text.style) {
|
if (text.style) {
|
||||||
style += text.style;
|
style += text.style;
|
||||||
text = text.text;
|
text = text.text;
|
||||||
|
@ -95,7 +94,6 @@ Elm.Native.Utils.make = function(elm) {
|
||||||
continue;
|
continue;
|
||||||
}
|
}
|
||||||
if (href) text = '<a href="' + href + '">' + text + '</a>';
|
if (href) text = '<a href="' + href + '">' + text + '</a>';
|
||||||
if (line) style += 'text-decoration:' + line + ';';
|
|
||||||
if (style) text = '<span style="' + style + '">' + text + '</span>';
|
if (style) text = '<span style="' + style + '">' + text + '</span>';
|
||||||
return text;
|
return text;
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,8 +0,0 @@
|
||||||
module Prelude where
|
|
||||||
{-| Everything that is automatically imported -}
|
|
||||||
|
|
||||||
import Native.Show
|
|
||||||
|
|
||||||
-- Convert almost any value to its string representation.
|
|
||||||
show : a -> String
|
|
||||||
show = Native.Show.show
|
|
|
@ -3,16 +3,17 @@ module Regex where
|
||||||
same kind of regular expressions accepted by JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions).
|
same kind of regular expressions accepted by JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions).
|
||||||
|
|
||||||
# Create
|
# Create
|
||||||
@docs pattern, caseInsensitive, escape
|
@docs regex, escape, caseInsensitive
|
||||||
|
|
||||||
# Match
|
# Helpful Data Structures
|
||||||
@docs Match
|
|
||||||
|
|
||||||
# Find and Replace
|
These data structures are needed to help define functions like [`find`](#find)
|
||||||
@docs contains, find, findAll, replace, replaceAll
|
and [`replace`](#replace).
|
||||||
|
|
||||||
# Split
|
@docs HowMany, Match
|
||||||
@docs split, splitN
|
|
||||||
|
# Use
|
||||||
|
@docs contains, find, replace, split
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
@ -21,31 +22,35 @@ import Native.Regex
|
||||||
|
|
||||||
data Regex = Regex
|
data Regex = Regex
|
||||||
|
|
||||||
{-| Escape all special characters. So `pattern (escape "$$$")`
|
{-| Escape strings to be regular expressions, making all special characters
|
||||||
will match exactly `"$$$"` even though `$` is a special character.
|
safe. So `regex (escape "^a+")` will match exactly `"^a+"` instead of a series
|
||||||
|
of `a`’s that start at the beginning of the line.
|
||||||
-}
|
-}
|
||||||
escape : String -> String
|
escape : String -> String
|
||||||
escape = Native.Regex.escape
|
escape = Native.Regex.escape
|
||||||
|
|
||||||
{-| Create a Regex that matches patterns [as specified in JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Writing_a_Regular_Expression_Pattern).
|
{-| Create a Regex that matches patterns [as specified in JavaScript](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Writing_a_Regular_Expression_Pattern).
|
||||||
Be careful to escape backslashes properly!
|
|
||||||
|
Be careful to escape backslashes properly! For example, `"\w"` is escaping the
|
||||||
|
letter `w` which is probably not what you want. You probably want `"\\w"`
|
||||||
|
instead, which escapes the backslash.
|
||||||
-}
|
-}
|
||||||
pattern : String -> Regex
|
regex : String -> Regex
|
||||||
pattern = Native.Regex.pattern
|
regex = Native.Regex.regex
|
||||||
|
|
||||||
|
|
||||||
{-| Make a pattern case insensitive -}
|
{-| Make a regex case insensitive -}
|
||||||
caseInsensitive : Regex -> Regex
|
caseInsensitive : Regex -> Regex
|
||||||
caseInsensitive = Native.Regex.caseInsensitive
|
caseInsensitive = Native.Regex.caseInsensitive
|
||||||
|
|
||||||
{-| Check to see if a Regex is contained in a string.
|
{-| Check to see if a Regex is contained in a string.
|
||||||
|
|
||||||
```haskell
|
```haskell
|
||||||
contains (pattern "123") "12345" == True
|
contains (regex "123") "12345" == True
|
||||||
contains (pattern "b+") "aabbcc" == True
|
contains (regex "b+") "aabbcc" == True
|
||||||
|
|
||||||
contains (pattern "789") "12345" == False
|
contains (regex "789") "12345" == False
|
||||||
contains (pattern "z+") "aabbcc" == False
|
contains (regex "z+") "aabbcc" == False
|
||||||
```
|
```
|
||||||
-}
|
-}
|
||||||
contains : Regex -> String -> Bool
|
contains : Regex -> String -> Bool
|
||||||
|
@ -55,11 +60,11 @@ contains = Native.Regex.contains
|
||||||
Here are details on each field:
|
Here are details on each field:
|
||||||
|
|
||||||
* `match` — the full string of the match.
|
* `match` — the full string of the match.
|
||||||
* `submatches` — a pattern might have [subpatterns, surrounded by
|
* `submatches` — a regex might have [subpatterns, surrounded by
|
||||||
parentheses](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Using_Parenthesized_Substring_Matches).
|
parentheses](https://developer.mozilla.org/en/docs/Web/JavaScript/Guide/Regular_Expressions#Using_Parenthesized_Substring_Matches).
|
||||||
If there are N subpatterns, there will be N elements in the `submatches` list.
|
If there are N subpatterns, there will be N elements in the `submatches` list.
|
||||||
Each submatch in this list is a `Maybe` because not all subpatterns may trigger.
|
Each submatch in this list is a `Maybe` because not all subpatterns may trigger.
|
||||||
For example, `(pattern "(a+)|(b+)")` will either match many `a`’s or
|
For example, `(regex "(a+)|(b+)")` will either match many `a`’s or
|
||||||
many `b`’s, but never both.
|
many `b`’s, but never both.
|
||||||
* `index` — the index of the match in the original string.
|
* `index` — the index of the match in the original string.
|
||||||
* `number` — if you find many matches, you can think of each one
|
* `number` — if you find many matches, you can think of each one
|
||||||
|
@ -70,64 +75,52 @@ Here are details on each field:
|
||||||
-}
|
-}
|
||||||
type Match = { match : String, submatches : [Maybe String], index : Int, number : Int }
|
type Match = { match : String, submatches : [Maybe String], index : Int, number : Int }
|
||||||
|
|
||||||
{-| Find all of the matches in a string:
|
{-| `HowMany` is used to specify how many matches you want to make. So
|
||||||
|
`replace All` would replace every match, but `replace (AtMost 2)` would
|
||||||
|
replace at most two matches (i.e. zero, one, two, but never three or more).
|
||||||
|
-}
|
||||||
|
data HowMany = All | AtMost Int
|
||||||
|
|
||||||
|
{-| Find matches in a string:
|
||||||
|
|
||||||
```haskell
|
```haskell
|
||||||
words = findAll (pattern "\\w+") "hello world"
|
findTwoCommas = find (AtMost 2) (regex ",")
|
||||||
|
|
||||||
map .match words == ["hello","world"]
|
-- map .index (findTwoCommas "a,b,c,d,e") == [1,3]
|
||||||
map .index words == [0,6]
|
-- map .index (findTwoCommas "a b c d e") == []
|
||||||
|
|
||||||
places = findAll (pattern "[oi]n a (\\w+)") "I am on a boat in a lake."
|
places = find All (regex "[oi]n a (\\w+)") "I am on a boat in a lake."
|
||||||
|
|
||||||
map .match places== ["on a boat", "in a lake"]
|
-- map .match places == ["on a boat", "in a lake"]
|
||||||
map .submatches places == [ [Just "boat"], [Just "lake"] ]
|
-- map .submatches places == [ [Just "boat"], [Just "lake"] ]
|
||||||
```
|
```
|
||||||
-}
|
-}
|
||||||
findAll : Regex -> String -> [Match]
|
find : HowMany -> Regex -> String -> [Match]
|
||||||
findAll = Native.Regex.findAll
|
|
||||||
|
|
||||||
{-| Same as `findAll`, but `find` will quit searching after the *n<sup>th</sup>* match.
|
|
||||||
That means the resulting list has maximum length N, but *it can be shorter*
|
|
||||||
if there are not that many matches in the given string.
|
|
||||||
-}
|
|
||||||
find : Int -> Regex -> String -> [Match]
|
|
||||||
find = Native.Regex.find
|
find = Native.Regex.find
|
||||||
|
|
||||||
{-| Replace all matches. The function from `Match` to `String` lets
|
{-| Replace matches. The function from `Match` to `String` lets
|
||||||
you use the details of a specific match when making replacements.
|
you use the details of a specific match when making replacements.
|
||||||
|
|
||||||
```haskell
|
```haskell
|
||||||
devowel = replaceAll (pattern "[aeiou]") (\_ -> "")
|
devowel = replace All (regex "[aeiou]") (\_ -> "")
|
||||||
|
|
||||||
devowel "The quick brown fox" == "Th qck brwn fx"
|
-- devowel "The quick brown fox" == "Th qck brwn fx"
|
||||||
|
|
||||||
reverseWords = replaceAll (pattern "\\w+") (\{match} -> String.reverse match)
|
reverseWords = replace All (regex "\\w+") (\{match} -> String.reverse match)
|
||||||
|
|
||||||
reverseWords "deliver mined parts" == "reviled denim strap"
|
-- reverseWords "deliver mined parts" == "reviled denim strap"
|
||||||
```
|
```
|
||||||
-}
|
-}
|
||||||
replaceAll : Regex -> (Match -> String) -> String -> String
|
replace : HowMany -> Regex -> (Match -> String) -> String -> String
|
||||||
replaceAll = Native.Regex.replaceAll
|
|
||||||
|
|
||||||
{-| Same as `replaceAll`, but `replace` will quit after the *n<sup>th</sup>* match.-}
|
|
||||||
replace : Int -> Regex -> (Match -> String) -> String -> String
|
|
||||||
replace = Native.Regex.replace
|
replace = Native.Regex.replace
|
||||||
|
|
||||||
{-| Split a string, using the regex as the separator.
|
{-| Split a string, using the regex as the separator.
|
||||||
|
|
||||||
```haskell
|
```haskell
|
||||||
split (pattern " *, *") "a ,b, c,d" == ["a","b","c","d"]
|
split (AtMost 1) (regex ",") "tom,99,90,85" == ["tom","99,90,85"]
|
||||||
|
|
||||||
|
split All (regex ",") "a,b,c,d" == ["a","b","c","d"]
|
||||||
```
|
```
|
||||||
-}
|
-}
|
||||||
split : Regex -> String -> [String]
|
split : HowMany -> Regex -> String -> [String]
|
||||||
split = Native.Regex.split
|
split = Native.Regex.split
|
||||||
|
|
||||||
{-| Same as `split` but stops after the *n<sup>th</sup>* match.
|
|
||||||
|
|
||||||
```haskell
|
|
||||||
splitN 1 (pattern ": *") "tom: 99,90,85" == ["tom","99,90,85"]
|
|
||||||
```
|
|
||||||
-}
|
|
||||||
splitN : Int -> Regex -> String -> [String]
|
|
||||||
splitN = Native.Regex.splitN
|
|
||||||
|
|
|
@ -32,6 +32,10 @@ the [`Time`](/docs/Signal/Time.elm) library.
|
||||||
import Native.Signal
|
import Native.Signal
|
||||||
import List (foldr)
|
import List (foldr)
|
||||||
|
|
||||||
|
import Basics (fst, snd, not)
|
||||||
|
import Native.Error
|
||||||
|
import Maybe as M
|
||||||
|
|
||||||
data Signal a = Signal
|
data Signal a = Signal
|
||||||
|
|
||||||
{-| Create a constant signal that never changes. -}
|
{-| Create a constant signal that never changes. -}
|
||||||
|
@ -122,7 +126,8 @@ Until the first signal becomes false again, all events will be propagated. Elm
|
||||||
does not allow undefined signals, so a base case must be provided in case the
|
does not allow undefined signals, so a base case must be provided in case the
|
||||||
first signal is not true initially. -}
|
first signal is not true initially. -}
|
||||||
keepWhen : Signal Bool -> a -> Signal a -> Signal a
|
keepWhen : Signal Bool -> a -> Signal a -> Signal a
|
||||||
keepWhen = Native.Signal.keepWhen
|
keepWhen bs def sig =
|
||||||
|
snd <~ (keepIf fst (False, def) ((,) <~ (sampleOn sig bs) ~ sig))
|
||||||
|
|
||||||
{-| Drop events when the first signal is true. When the first signal becomes
|
{-| Drop events when the first signal is true. When the first signal becomes
|
||||||
false, the most recent value of the second signal will be propagated. Until the
|
false, the most recent value of the second signal will be propagated. Until the
|
||||||
|
@ -130,7 +135,7 @@ first signal becomes true again, all events will be propagated. Elm does not
|
||||||
allow undefined signals, s oa base case must be provided in case the first
|
allow undefined signals, s oa base case must be provided in case the first
|
||||||
signal is true initially. -}
|
signal is true initially. -}
|
||||||
dropWhen : Signal Bool -> a -> Signal a -> Signal a
|
dropWhen : Signal Bool -> a -> Signal a -> Signal a
|
||||||
dropWhen = Native.Signal.dropWhen
|
dropWhen bs = keepWhen (not <~ bs)
|
||||||
|
|
||||||
{-| Drop updates that repeat the current value of the signal.
|
{-| Drop updates that repeat the current value of the signal.
|
||||||
|
|
||||||
|
|
|
@ -15,7 +15,7 @@ are enclosed in `"double quotes"`. Strings are *not* lists of characters.
|
||||||
@docs contains, startsWith, endsWith, indexes, indices
|
@docs contains, startsWith, endsWith, indexes, indices
|
||||||
|
|
||||||
# Conversions
|
# Conversions
|
||||||
@docs toInt, toFloat, toList, fromList
|
@docs show, toInt, toFloat, toList, fromList
|
||||||
|
|
||||||
# Formatting
|
# Formatting
|
||||||
Cosmetic operations such as padding with extra characters or trimming whitespace.
|
Cosmetic operations such as padding with extra characters or trimming whitespace.
|
||||||
|
@ -28,10 +28,15 @@ Cosmetic operations such as padding with extra characters or trimming whitespace
|
||||||
@docs map, filter, foldl, foldr, any, all
|
@docs map, filter, foldl, foldr, any, all
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
import Native.Show
|
||||||
import Native.String
|
import Native.String
|
||||||
import Maybe (Maybe)
|
import Maybe (Maybe)
|
||||||
|
|
||||||
{-| Check if a string is empty `(isEmpty "" == True)` -}
|
{-| Check if a string is empty.
|
||||||
|
|
||||||
|
isEmpty "" == True
|
||||||
|
isEmpty "the world" == False
|
||||||
|
-}
|
||||||
isEmpty : String -> Bool
|
isEmpty : String -> Bool
|
||||||
isEmpty = Native.String.isEmpty
|
isEmpty = Native.String.isEmpty
|
||||||
|
|
||||||
|
@ -63,7 +68,11 @@ append = Native.String.append
|
||||||
concat : [String] -> String
|
concat : [String] -> String
|
||||||
concat = Native.String.concat
|
concat = Native.String.concat
|
||||||
|
|
||||||
{-| Get the length of a string `(length "innumerable" == 11)` -}
|
{-| Get the length of a string.
|
||||||
|
|
||||||
|
length "innumerable" == 11
|
||||||
|
|
||||||
|
-}
|
||||||
length : String -> Int
|
length : String -> Int
|
||||||
length = Native.String.length
|
length = Native.String.length
|
||||||
|
|
||||||
|
@ -81,7 +90,10 @@ map = Native.String.map
|
||||||
filter : (Char -> Bool) -> String -> String
|
filter : (Char -> Bool) -> String -> String
|
||||||
filter = Native.String.filter
|
filter = Native.String.filter
|
||||||
|
|
||||||
{-| Reverse a string. `(reverse "stressed" == "desserts")` -}
|
{-| Reverse a string.
|
||||||
|
|
||||||
|
reverse "stressed" == "desserts"
|
||||||
|
-}
|
||||||
reverse : String -> String
|
reverse : String -> String
|
||||||
reverse = Native.String.reverse
|
reverse = Native.String.reverse
|
||||||
|
|
||||||
|
@ -103,6 +115,8 @@ foldr = Native.String.foldr
|
||||||
|
|
||||||
split "," "cat,dog,cow" == ["cat","dog","cow"]
|
split "," "cat,dog,cow" == ["cat","dog","cow"]
|
||||||
split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
|
split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
|
||||||
|
|
||||||
|
Use `Regex.split` if you need something more flexible.
|
||||||
-}
|
-}
|
||||||
split : String -> String -> [String]
|
split : String -> String -> [String]
|
||||||
split = Native.String.split
|
split = Native.String.split
|
||||||
|
@ -115,7 +129,10 @@ split = Native.String.split
|
||||||
join : String -> [String] -> String
|
join : String -> [String] -> String
|
||||||
join = Native.String.join
|
join = Native.String.join
|
||||||
|
|
||||||
{-| Repeat a string N times `(repeat 3 "ha" == "hahaha")` -}
|
{-| Repeat a string N times.
|
||||||
|
|
||||||
|
repeat 3 "ha" == "hahaha"
|
||||||
|
-}
|
||||||
repeat : Int -> String -> String
|
repeat : Int -> String -> String
|
||||||
repeat = Native.String.repeat
|
repeat = Native.String.repeat
|
||||||
|
|
||||||
|
@ -231,7 +248,7 @@ any = Native.String.any
|
||||||
|
|
||||||
all isDigit "90210" == True
|
all isDigit "90210" == True
|
||||||
all isDigit "R2-D2" == False
|
all isDigit "R2-D2" == False
|
||||||
any isDigit "heart" == False
|
all isDigit "heart" == False
|
||||||
-}
|
-}
|
||||||
all : (Char -> Bool) -> String -> Bool
|
all : (Char -> Bool) -> String -> Bool
|
||||||
all = Native.String.all
|
all = Native.String.all
|
||||||
|
@ -241,6 +258,8 @@ all = Native.String.all
|
||||||
contains "the" "theory" == True
|
contains "the" "theory" == True
|
||||||
contains "hat" "theory" == False
|
contains "hat" "theory" == False
|
||||||
contains "THE" "theory" == False
|
contains "THE" "theory" == False
|
||||||
|
|
||||||
|
Use `Regex.contains` if you need something more flexible.
|
||||||
-}
|
-}
|
||||||
contains : String -> String -> Bool
|
contains : String -> String -> Bool
|
||||||
contains = Native.String.contains
|
contains = Native.String.contains
|
||||||
|
@ -274,6 +293,14 @@ indexes = Native.String.indexes
|
||||||
indices : String -> String -> [Int]
|
indices : String -> String -> [Int]
|
||||||
indices = Native.String.indexes
|
indices = Native.String.indexes
|
||||||
|
|
||||||
|
{-| Turn any kind of value into a string.
|
||||||
|
|
||||||
|
show 42 == "42"
|
||||||
|
show [1,2] == "[1,2]"
|
||||||
|
-}
|
||||||
|
show : a -> String
|
||||||
|
show = Native.Show.show
|
||||||
|
|
||||||
{-| Try to convert a string into an int, failing on improperly formatted strings.
|
{-| Try to convert a string into an int, failing on improperly formatted strings.
|
||||||
|
|
||||||
toInt "123" == Just 123
|
toInt "123" == Just 123
|
||||||
|
|
|
@ -1,99 +1,210 @@
|
||||||
module Text where
|
module Text where
|
||||||
|
{-| A library for styling and displaying text. Whlie the `String` library
|
||||||
{-| Functions for displaying text
|
focuses on representing and manipulating strings of character strings, the
|
||||||
|
`Text` library focuses on how those strings should look on screen. It lets
|
||||||
|
you make text bold or italic, set the typeface, set the text size, etc.
|
||||||
|
|
||||||
# Creating Text
|
# Creating Text
|
||||||
@docs toText
|
@docs toText
|
||||||
|
|
||||||
# Creating Elements
|
# Creating Elements
|
||||||
@docs plainText, asText, text, centered, justified, righted
|
|
||||||
|
|
||||||
# Formatting
|
Each of the following functions places `Text` into a box. The function you use
|
||||||
@docs color, typeface, height, link
|
determines the alignment of the text.
|
||||||
|
|
||||||
# Simple Formatting
|
@docs leftAligned, rightAligned, centered, justified
|
||||||
@docs monospace, bold, italic, underline, overline, strikeThrough
|
|
||||||
|
# Links and Style
|
||||||
|
@docs link, Style, style, defaultStyle, Line
|
||||||
|
|
||||||
|
# Convenience Functions
|
||||||
|
|
||||||
|
There are two convenience functions for creating an `Element` which can be
|
||||||
|
useful when debugging or prototyping:
|
||||||
|
|
||||||
|
@docs plainText, asText
|
||||||
|
|
||||||
|
There are also a bunch of functions to set parts of a `Style` individually:
|
||||||
|
|
||||||
|
@docs typeface, monospace, height, color, bold, italic, line
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import open Basics
|
import Basics (..)
|
||||||
import Color (Color)
|
import String
|
||||||
|
import Color (Color, black)
|
||||||
import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
|
import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
|
||||||
import Maybe (Maybe)
|
import Maybe (Maybe, Nothing)
|
||||||
import JavaScript (JSString)
|
import JavaScript (JSString)
|
||||||
|
import Native.Show
|
||||||
import Native.Text
|
import Native.Text
|
||||||
|
|
||||||
data Text = Text
|
data Text = Text
|
||||||
|
|
||||||
{-| Convert a string into text which can be styled and displayed. -}
|
{-| Styles for lines on text. This allows you to add an underline, an overline,
|
||||||
|
or a strike out text:
|
||||||
|
|
||||||
|
line Under (toText "underline")
|
||||||
|
line Over (toText "overline")
|
||||||
|
line Through (toText "strike out")
|
||||||
|
-}
|
||||||
|
data Line = Under | Over | Through
|
||||||
|
|
||||||
|
{-| Representation of all the ways you can style `Text`. If the `typeface` list
|
||||||
|
is empty or the `height` is `Nothing`, the users will fall back on their
|
||||||
|
browser's default settings. The following `Style` is black, 16 pixel tall,
|
||||||
|
underlined, and Times New Roman (assuming that typeface is available on the
|
||||||
|
user's computer):
|
||||||
|
|
||||||
|
{ typeface = [ "Times New Roman", "serif" ]
|
||||||
|
, height = Just 16
|
||||||
|
, color = black
|
||||||
|
, bold = False
|
||||||
|
, italic = False
|
||||||
|
, line = Just Under
|
||||||
|
}
|
||||||
|
-}
|
||||||
|
type Style =
|
||||||
|
{ typeface : [String]
|
||||||
|
, height : Maybe Float
|
||||||
|
, color : Color
|
||||||
|
, bold : Bool
|
||||||
|
, italic : Bool
|
||||||
|
, line : Maybe Line
|
||||||
|
}
|
||||||
|
|
||||||
|
{-| Plain black text. It uses the browsers default typeface and text height.
|
||||||
|
No decorations are used:
|
||||||
|
|
||||||
|
{ typeface = []
|
||||||
|
, height = Nothing
|
||||||
|
, color = black
|
||||||
|
, bold = False
|
||||||
|
, italic = False
|
||||||
|
, line = Nothing
|
||||||
|
}
|
||||||
|
-}
|
||||||
|
defaultStyle : Style
|
||||||
|
defaultStyle =
|
||||||
|
{ typeface = []
|
||||||
|
, height = Nothing
|
||||||
|
, color = black
|
||||||
|
, bold = False
|
||||||
|
, italic = False
|
||||||
|
, line = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
|
{-| Convert a string into text which can be styled and displayed. To show the
|
||||||
|
string `"Hello World!"` on screen in italics, you could say:
|
||||||
|
|
||||||
|
main = leftAligned (italic (toText "Hello World!"))
|
||||||
|
-}
|
||||||
toText : String -> Text
|
toText : String -> Text
|
||||||
toText = Native.Text.toText
|
toText = Native.Text.toText
|
||||||
|
|
||||||
{-| Set the typeface of some text. The first argument should be a comma
|
{-| Set the style of some text. For example, if you design a `Style` called
|
||||||
separated listing of the desired typefaces:
|
`footerStyle` that is specifically for the bottom of your page, you could apply
|
||||||
|
it to text like this:
|
||||||
|
|
||||||
"helvetica, arial, sans-serif"
|
style footerStyle (toText "the old prince / 2007")
|
||||||
|
|
||||||
Works the same as the CSS font-family property.
|
|
||||||
-}
|
-}
|
||||||
typeface : String -> Text -> Text
|
style : Style -> Text -> Text
|
||||||
|
style = Native.Text.style
|
||||||
|
|
||||||
|
{-| Provide a list of prefered typefaces for some text.
|
||||||
|
|
||||||
|
["helvetica","arial","sans-serif"]
|
||||||
|
|
||||||
|
Not every browser has access to the same typefaces, so rendering will use the
|
||||||
|
first typeface in the list that is found on the user's computer. If there are
|
||||||
|
no matches, it will use their default typeface. This works the same as the CSS
|
||||||
|
font-family property.
|
||||||
|
-}
|
||||||
|
typeface : [String] -> Text -> Text
|
||||||
typeface = Native.Text.typeface
|
typeface = Native.Text.typeface
|
||||||
|
|
||||||
{-| Switch to a monospace typeface. Good for code snippets. -}
|
{-| Switch to a monospace typeface. Good for code snippets.
|
||||||
|
|
||||||
|
monospace (toText "foldl (+) 0 [1,2,3]")
|
||||||
|
-}
|
||||||
monospace : Text -> Text
|
monospace : Text -> Text
|
||||||
monospace = Native.Text.monospace
|
monospace = Native.Text.monospace
|
||||||
|
|
||||||
{-| Create a link. -}
|
{-| Create a link by providing a URL and the text of the link:
|
||||||
|
|
||||||
|
link "http://elm-lang.org" (toText "Elm Website")
|
||||||
|
-}
|
||||||
link : String -> Text -> Text
|
link : String -> Text -> Text
|
||||||
link = Native.Text.link
|
link = Native.Text.link
|
||||||
|
|
||||||
{-| Set the height of text in pixels. -}
|
{-| Set the height of some text:
|
||||||
|
|
||||||
|
height 40 (toText "Title")
|
||||||
|
-}
|
||||||
height : Float -> Text -> Text
|
height : Float -> Text -> Text
|
||||||
height = Native.Text.height
|
height = Native.Text.height
|
||||||
|
|
||||||
{-| Set the color of a string. -}
|
{-| Set the color of some text:
|
||||||
|
|
||||||
|
color red (toText "Red")
|
||||||
|
-}
|
||||||
color : Color -> Text -> Text
|
color : Color -> Text -> Text
|
||||||
color = Native.Text.color
|
color = Native.Text.color
|
||||||
|
|
||||||
{-| Make a string bold. -}
|
{-| Make text bold:
|
||||||
|
|
||||||
|
toText "sometimes you want " ++ bold (toText "emphasis")
|
||||||
|
-}
|
||||||
bold : Text -> Text
|
bold : Text -> Text
|
||||||
bold = Native.Text.bold
|
bold = Native.Text.bold
|
||||||
|
|
||||||
{-| Italicize a string. -}
|
{-| Make text italic:
|
||||||
|
|
||||||
|
toText "make it " ++ italic (toText "important")
|
||||||
|
-}
|
||||||
italic : Text -> Text
|
italic : Text -> Text
|
||||||
italic = Native.Text.italic
|
italic = Native.Text.italic
|
||||||
|
|
||||||
{-| Draw a line above a string. -}
|
{-| Put lines on text:
|
||||||
overline : Text -> Text
|
|
||||||
overline = Native.Text.overline
|
|
||||||
|
|
||||||
{-| Underline a string. -}
|
line Under (toText "underlined")
|
||||||
underline : Text -> Text
|
line Over (toText "overlined")
|
||||||
underline = Native.Text.underline
|
line Through (toText "strike out")
|
||||||
|
-}
|
||||||
|
line : Line -> Text -> Text
|
||||||
|
line = Native.Text.line
|
||||||
|
|
||||||
{-| Draw a line through a string. -}
|
{-| `Text` is aligned along the left side of the text block. This is sometimes
|
||||||
strikeThrough : Text -> Text
|
known as *ragged right*.
|
||||||
strikeThrough = Native.Text.strikeThrough
|
-}
|
||||||
|
leftAligned : Text -> Element
|
||||||
|
leftAligned = Native.Text.leftAligned
|
||||||
|
|
||||||
{-| Display justified, styled text. -}
|
{-| `Text` is aligned along the right side of the text block. This is sometimes
|
||||||
justified : Text -> Element
|
known as *ragged left*.
|
||||||
justified = Native.Text.justified
|
-}
|
||||||
|
rightAligned : Text -> Element
|
||||||
|
rightAligned = Native.Text.rightAligned
|
||||||
|
|
||||||
{-| Display centered, styled text. -}
|
{-| `Text` is centered in the text block. There is equal spacing on either side
|
||||||
|
of a line of text.
|
||||||
|
-}
|
||||||
centered : Text -> Element
|
centered : Text -> Element
|
||||||
centered = Native.Text.centered
|
centered = Native.Text.centered
|
||||||
|
|
||||||
{-| Display right justified, styled text. -}
|
{-| `Text` is aligned along the left and right sides of the text block. Word
|
||||||
righted : Text -> Element
|
spacing is adjusted to make this possible.
|
||||||
righted = Native.Text.righted
|
-}
|
||||||
|
justified : Text -> Element
|
||||||
|
justified = Native.Text.justified
|
||||||
|
|
||||||
{-| Display styled text. -}
|
{-| Display a string with no styling:
|
||||||
text : Text -> Element
|
|
||||||
text = Native.Text.text
|
|
||||||
|
|
||||||
{-| Display a plain string. -}
|
plainText string = leftAligned (toText string)
|
||||||
|
-}
|
||||||
plainText : String -> Element
|
plainText : String -> Element
|
||||||
plainText = Native.Text.plainText
|
plainText str =
|
||||||
|
leftAligned (toText str)
|
||||||
|
|
||||||
{-| for internal use only -}
|
{-| for internal use only -}
|
||||||
markdown : Element
|
markdown : Element
|
||||||
|
@ -102,9 +213,10 @@ markdown = Native.Text.markdown
|
||||||
{-| Convert anything to its textual representation and make it displayable in
|
{-| Convert anything to its textual representation and make it displayable in
|
||||||
the browser:
|
the browser:
|
||||||
|
|
||||||
asText == text . monospace . show
|
asText value = text (monospace (show value))
|
||||||
|
|
||||||
Excellent for debugging.
|
Excellent for debugging.
|
||||||
-}
|
-}
|
||||||
asText : a -> Element
|
asText : a -> Element
|
||||||
asText = Native.Text.asText
|
asText value =
|
||||||
|
leftAligned (monospace (toText (Native.Show.show value)))
|
||||||
|
|
|
@ -14,7 +14,7 @@ module Time where
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import open Basics
|
import Basics (..)
|
||||||
import Native.Time
|
import Native.Time
|
||||||
import Signal (Signal)
|
import Signal (Signal)
|
||||||
|
|
||||||
|
|
49
libraries/Trampoline.elm
Normal file
49
libraries/Trampoline.elm
Normal file
|
@ -0,0 +1,49 @@
|
||||||
|
module Trampoline where
|
||||||
|
{-| A [trampoline](http://en.wikipedia.org/wiki/Tail-recursive_function#Through_trampolining)
|
||||||
|
makes it possible to recursively call a function without growing the stack.
|
||||||
|
|
||||||
|
Popular JavaScript implementations do not perform any tail-call elimination, so
|
||||||
|
recursive functions can cause a stack overflow if they go to deep. Trampolines
|
||||||
|
permit unbounded recursion despite limitations in JavaScript.
|
||||||
|
|
||||||
|
This strategy may create many intermediate closures, which is very expensive in
|
||||||
|
JavaScript, so use this library only when it is essential that you recurse deeply.
|
||||||
|
|
||||||
|
# Trampolines
|
||||||
|
@docs trampoline, Trampoline
|
||||||
|
-}
|
||||||
|
|
||||||
|
import Native.Trampoline
|
||||||
|
|
||||||
|
{-| A way to build computations that may be deeply recursive. We will take an
|
||||||
|
example of a tail-recursive function and rewrite it in a way that lets us use
|
||||||
|
a trampoline:
|
||||||
|
|
||||||
|
length : [a] -> Int
|
||||||
|
length list = length' 0 list
|
||||||
|
|
||||||
|
length' : Int -> [a] -> Int
|
||||||
|
length' accum list =
|
||||||
|
case list of
|
||||||
|
[] -> accum
|
||||||
|
hd::tl -> length' (accum+1) tl
|
||||||
|
|
||||||
|
This finds the length of a list, but if the list is too long, it may cause a
|
||||||
|
stack overflow. We can rewrite it as follows:
|
||||||
|
|
||||||
|
length : [a] -> Int
|
||||||
|
length list = trampoline (length' 0 list)
|
||||||
|
|
||||||
|
length' : Int -> [a] -> Trampoline Int
|
||||||
|
length' accum list =
|
||||||
|
case list of
|
||||||
|
[] -> Done accum
|
||||||
|
hd::tl -> Continue (\() -> length' (accum+1) tl)
|
||||||
|
|
||||||
|
Now it uses a trampoline and can recurse without growing the stack!
|
||||||
|
-}
|
||||||
|
data Trampoline a = Done a | Continue (() -> Trampoline a)
|
||||||
|
|
||||||
|
{-| Evaluate a trampolined value in constant space. -}
|
||||||
|
trampoline : Trampoline a -> a
|
||||||
|
trampoline = Native.Trampoline.trampoline
|
|
@ -1,9 +1,9 @@
|
||||||
{ "version": "0.11"
|
{ "version": "0.12"
|
||||||
, "summary": "Elm's standard libraries"
|
, "summary": "Elm's standard libraries"
|
||||||
, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.11, you should be using version 0.11 of the standard libraries."
|
, "description": "The full set of standard libraries for Elm. This library is pegged to the version number of the compiler, so if you are using Elm 0.12, you should be using version 0.12 of the standard libraries."
|
||||||
, "license": "BSD3"
|
, "license": "BSD3"
|
||||||
, "repository": "http://github.com/evancz/Elm.git"
|
, "repository": "http://github.com/evancz/Elm.git"
|
||||||
, "elm-version": "0.11"
|
, "elm-version": "0.12"
|
||||||
, "dependencies": {}
|
, "dependencies": {}
|
||||||
, "exposed-modules":
|
, "exposed-modules":
|
||||||
[ "Basics"
|
[ "Basics"
|
||||||
|
@ -11,11 +11,13 @@
|
||||||
, "Char"
|
, "Char"
|
||||||
, "Color"
|
, "Color"
|
||||||
, "Date"
|
, "Date"
|
||||||
|
, "Debug"
|
||||||
, "Dict"
|
, "Dict"
|
||||||
, "Either"
|
, "Either"
|
||||||
, "Graphics.Element"
|
, "Graphics.Element"
|
||||||
, "Graphics.Collage"
|
, "Graphics.Collage"
|
||||||
, "Graphics.Input"
|
, "Graphics.Input"
|
||||||
|
, "Graphics.Input.Field"
|
||||||
, "Http"
|
, "Http"
|
||||||
, "JavaScript"
|
, "JavaScript"
|
||||||
, "JavaScript.Experimental"
|
, "JavaScript.Experimental"
|
||||||
|
@ -32,6 +34,7 @@
|
||||||
, "Text"
|
, "Text"
|
||||||
, "Time"
|
, "Time"
|
||||||
, "Touch"
|
, "Touch"
|
||||||
|
, "Trampoline"
|
||||||
, "Transform2D"
|
, "Transform2D"
|
||||||
, "WebSocket"
|
, "WebSocket"
|
||||||
, "Window"
|
, "Window"
|
||||||
|
|
|
@ -5,8 +5,8 @@
|
||||||
// structure.
|
// structure.
|
||||||
ElmRuntime.swap = function(from, to) {
|
ElmRuntime.swap = function(from, to) {
|
||||||
function similar(nodeOld,nodeNew) {
|
function similar(nodeOld,nodeNew) {
|
||||||
idOkay = nodeOld.id === nodeNew.id;
|
var idOkay = nodeOld.id === nodeNew.id;
|
||||||
lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
|
var lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
|
||||||
return idOkay && lengthOkay;
|
return idOkay && lengthOkay;
|
||||||
}
|
}
|
||||||
function swap(nodeOld,nodeNew) {
|
function swap(nodeOld,nodeNew) {
|
||||||
|
|
|
@ -91,7 +91,7 @@ function init(display, container, module, ports, moduleToReplace) {
|
||||||
checkPorts(elm);
|
checkPorts(elm);
|
||||||
} catch(e) {
|
} catch(e) {
|
||||||
var directions = "<br/> Open the developer console for more details."
|
var directions = "<br/> Open the developer console for more details."
|
||||||
Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');
|
Module.main = Elm.Text.make(elm).leftAligned('<code>' + e.message + directions + '</code>');
|
||||||
reportAnyErrors = function() { throw e; }
|
reportAnyErrors = function() { throw e; }
|
||||||
}
|
}
|
||||||
inputs = ElmRuntime.filterDeadInputs(inputs);
|
inputs = ElmRuntime.filterDeadInputs(inputs);
|
||||||
|
|
|
@ -254,6 +254,7 @@ function makeCanvas(w,h) {
|
||||||
function render(model) {
|
function render(model) {
|
||||||
var div = newElement('div');
|
var div = newElement('div');
|
||||||
div.style.overflow = 'hidden';
|
div.style.overflow = 'hidden';
|
||||||
|
div.style.position = 'relative';
|
||||||
update(div, model, model);
|
update(div, model, model);
|
||||||
return div;
|
return div;
|
||||||
}
|
}
|
||||||
|
|
|
@ -7,10 +7,16 @@ var newElement = Utils.newElement, extract = Utils.extract,
|
||||||
addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
|
addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
|
||||||
fromList = Utils.fromList, eq = Utils.eq;
|
fromList = Utils.fromList, eq = Utils.eq;
|
||||||
|
|
||||||
function setProps(props, e) {
|
function setProps(elem, e) {
|
||||||
e.style.width = (props.width |0) + 'px';
|
var props = elem.props;
|
||||||
e.style.height = (props.height|0) + 'px';
|
var element = elem.element;
|
||||||
if (props.opacity !== 1) { e.style.opacity = props.opacity; }
|
var width = props.width - (element.adjustWidth || 0);
|
||||||
|
var height = props.height - (element.adjustHeight || 0);
|
||||||
|
e.style.width = (width |0) + 'px';
|
||||||
|
e.style.height = (height|0) + 'px';
|
||||||
|
if (props.opacity !== 1) {
|
||||||
|
e.style.opacity = props.opacity;
|
||||||
|
}
|
||||||
if (props.color.ctor === 'Just') {
|
if (props.color.ctor === 'Just') {
|
||||||
e.style.backgroundColor = extract(props.color._0);
|
e.style.backgroundColor = extract(props.color._0);
|
||||||
}
|
}
|
||||||
|
@ -28,15 +34,30 @@ function setProps(props, e) {
|
||||||
e.appendChild(a);
|
e.appendChild(a);
|
||||||
}
|
}
|
||||||
if (props.hover.ctor !== '_Tuple0') {
|
if (props.hover.ctor !== '_Tuple0') {
|
||||||
var overCount = 0;
|
e.style.pointerEvents = 'auto';
|
||||||
|
e.elm_hover_handler = props.hover;
|
||||||
|
e.elm_hover_count = 0;
|
||||||
e.addEventListener('mouseover', function() {
|
e.addEventListener('mouseover', function() {
|
||||||
if (overCount++ > 0) return;
|
if (e.elm_hover_count++ > 0) return;
|
||||||
props.hover(true);
|
var handler = e.elm_hover_handler;
|
||||||
|
if (handler !== null) {
|
||||||
|
handler(true);
|
||||||
|
}
|
||||||
});
|
});
|
||||||
e.addEventListener('mouseout', function(evt) {
|
e.addEventListener('mouseout', function(evt) {
|
||||||
if (e.contains(evt.toElement || evt.relatedTarget)) return;
|
if (e.contains(evt.toElement || evt.relatedTarget)) return;
|
||||||
overCount = 0;
|
e.elm_hover_count = 0;
|
||||||
props.hover(false);
|
var handler = e.elm_hover_handler;
|
||||||
|
if (handler !== null) {
|
||||||
|
handler(false);
|
||||||
|
}
|
||||||
|
});
|
||||||
|
}
|
||||||
|
if (props.click.ctor !== '_Tuple0') {
|
||||||
|
e.style.pointerEvents = 'auto';
|
||||||
|
e.elm_click_handler = props.click;
|
||||||
|
e.addEventListener('click', function() {
|
||||||
|
e.elm_click_handler(Tuple0);
|
||||||
});
|
});
|
||||||
}
|
}
|
||||||
return e;
|
return e;
|
||||||
|
@ -99,6 +120,8 @@ function goDown(e) { return e }
|
||||||
function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
|
function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
|
||||||
function flowWith(f, array) {
|
function flowWith(f, array) {
|
||||||
var container = newElement('div');
|
var container = newElement('div');
|
||||||
|
if (f == goIn) container.style.pointerEvents = 'none';
|
||||||
|
|
||||||
for (var i = array.length; i--; ) {
|
for (var i = array.length; i--; ) {
|
||||||
container.appendChild(f(render(array[i])));
|
container.appendChild(f(render(array[i])));
|
||||||
}
|
}
|
||||||
|
@ -126,7 +149,12 @@ function toPos(pos) {
|
||||||
|
|
||||||
// must clear right, left, top, bottom, and transform
|
// must clear right, left, top, bottom, and transform
|
||||||
// before calling this function
|
// before calling this function
|
||||||
function setPos(pos,w,h,e) {
|
function setPos(pos,elem,e) {
|
||||||
|
var element = elem.element;
|
||||||
|
var props = elem.props;
|
||||||
|
var w = props.width + (element.adjustWidth ? element.adjustWidth : 0);
|
||||||
|
var h = props.height + (element.adjustHeight ? element.adjustHeight : 0);
|
||||||
|
|
||||||
e.style.position = 'absolute';
|
e.style.position = 'absolute';
|
||||||
e.style.margin = 'auto';
|
e.style.margin = 'auto';
|
||||||
var transform = '';
|
var transform = '';
|
||||||
|
@ -146,7 +174,7 @@ function setPos(pos,w,h,e) {
|
||||||
|
|
||||||
function container(pos,elem) {
|
function container(pos,elem) {
|
||||||
var e = render(elem);
|
var e = render(elem);
|
||||||
setPos(pos, elem.props.width, elem.props.height, e);
|
setPos(pos, elem, e);
|
||||||
var div = newElement('div');
|
var div = newElement('div');
|
||||||
div.style.position = 'relative';
|
div.style.position = 'relative';
|
||||||
div.style.overflow = 'hidden';
|
div.style.overflow = 'hidden';
|
||||||
|
@ -183,7 +211,7 @@ function rawHtml(elem) {
|
||||||
return div;
|
return div;
|
||||||
}
|
}
|
||||||
|
|
||||||
function render(elem) { return setProps(elem.props, makeElement(elem)); }
|
function render(elem) { return setProps(elem, makeElement(elem)); }
|
||||||
function makeElement(e) {
|
function makeElement(e) {
|
||||||
var elem = e.element;
|
var elem = e.element;
|
||||||
switch(elem.ctor) {
|
switch(elem.ctor) {
|
||||||
|
@ -209,7 +237,9 @@ function update(node, curr, next) {
|
||||||
case "RawHtml":
|
case "RawHtml":
|
||||||
// only markdown blocks have guids, so this must be a text block
|
// only markdown blocks have guids, so this must be a text block
|
||||||
if (nextE.guid === null) {
|
if (nextE.guid === null) {
|
||||||
|
if(currE.html.valueOf() !== nextE.html.valueOf()) {
|
||||||
node.innerHTML = nextE.html;
|
node.innerHTML = nextE.html;
|
||||||
|
}
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
if (nextE.guid !== currE.guid) {
|
if (nextE.guid !== currE.guid) {
|
||||||
|
@ -275,7 +305,7 @@ function update(node, curr, next) {
|
||||||
break;
|
break;
|
||||||
case "Container":
|
case "Container":
|
||||||
update(node.firstChild, currE._1, nextE._1);
|
update(node.firstChild, currE._1, nextE._1);
|
||||||
setPos(nextE._0, nextE._1.props.width, nextE._1.props.height, node.firstChild);
|
setPos(nextE._0, nextE._1, node.firstChild);
|
||||||
break;
|
break;
|
||||||
case "Custom":
|
case "Custom":
|
||||||
if (currE.type === nextE.type) {
|
if (currE.type === nextE.type) {
|
||||||
|
@ -289,10 +319,19 @@ function update(node, curr, next) {
|
||||||
}
|
}
|
||||||
|
|
||||||
function updateProps(node, curr, next) {
|
function updateProps(node, curr, next) {
|
||||||
var props = next.props, currP = curr.props, e = node;
|
var props = next.props;
|
||||||
if (props.width !== currP.width) e.style.width = (props.width |0) + 'px';
|
var currP = curr.props;
|
||||||
if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';
|
var e = node;
|
||||||
if (props.opacity !== 1 && props.opacity !== currP.opacity) {
|
var element = next.element;
|
||||||
|
var width = props.width - (element.adjustWidth || 0);
|
||||||
|
var height = props.height - (element.adjustHeight || 0);
|
||||||
|
if (width !== currP.width) {
|
||||||
|
e.style.width = (width|0) + 'px';
|
||||||
|
}
|
||||||
|
if (height !== currP.height) {
|
||||||
|
e.style.height = (height|0) + 'px';
|
||||||
|
}
|
||||||
|
if (props.opacity !== currP.opacity) {
|
||||||
e.style.opacity = props.opacity;
|
e.style.opacity = props.opacity;
|
||||||
}
|
}
|
||||||
var nextColor = (props.color.ctor === 'Just' ?
|
var nextColor = (props.color.ctor === 'Just' ?
|
||||||
|
@ -317,6 +356,20 @@ function updateProps(node, curr, next) {
|
||||||
node.lastNode.href = props.href;
|
node.lastNode.href = props.href;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
// update hover handlers
|
||||||
|
if (props.hover.ctor !== '_Tuple0') {
|
||||||
|
e.elm_hover_handler = props.hover;
|
||||||
|
} else if (e.elm_hover_handler) {
|
||||||
|
e.elm_hover_handler = null;
|
||||||
|
}
|
||||||
|
|
||||||
|
// update click handlers
|
||||||
|
if (props.click.ctor !== '_Tuple0') {
|
||||||
|
e.elm_click_handler = props.click;
|
||||||
|
} else if (e.elm_click_handler) {
|
||||||
|
e.elm_click_handler = null;
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
return { render:render, update:update };
|
return { render:render, update:update };
|
||||||
|
|
|
@ -10,7 +10,7 @@ License-file: LICENSE
|
||||||
|
|
||||||
Author: Evan Czaplicki
|
Author: Evan Czaplicki
|
||||||
Maintainer: info@elm-lang.org
|
Maintainer: info@elm-lang.org
|
||||||
Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
|
Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
|
||||||
|
|
||||||
Category: Compiler, Language
|
Category: Compiler, Language
|
||||||
|
|
||||||
|
|
|
@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)
|
||||||
import Text.PrettyPrint as P
|
import Text.PrettyPrint as P
|
||||||
|
|
||||||
import SourceSyntax.Literal as Lit
|
import SourceSyntax.Literal as Lit
|
||||||
import SourceSyntax.Pattern as Pat
|
import qualified SourceSyntax.Pattern as P
|
||||||
import SourceSyntax.PrettyPrint (Pretty, pretty)
|
import SourceSyntax.PrettyPrint (Pretty, pretty)
|
||||||
import Parse.Helpers (IParser, iParse)
|
import Parse.Helpers (IParser, iParse)
|
||||||
import Parse.Literal (literal)
|
import Parse.Literal (literal)
|
||||||
|
@ -31,9 +31,9 @@ propertyTests =
|
||||||
where
|
where
|
||||||
-- This test was autogenerated from the Pattern test and should be
|
-- This test was autogenerated from the Pattern test and should be
|
||||||
-- left in all its ugly glory.
|
-- left in all its ugly glory.
|
||||||
longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
|
longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
|
||||||
, Pat.PRecord [
|
, P.Record
|
||||||
"q7yclkcm7k_ikstrczv_"
|
[ "q7yclkcm7k_ikstrczv_"
|
||||||
, "wQRv6gKsvvkjw4b5F"
|
, "wQRv6gKsvvkjw4b5F"
|
||||||
,"c9'eFfhk9FTvsMnwF_D"
|
,"c9'eFfhk9FTvsMnwF_D"
|
||||||
,"yqxhEkHvRFwZ"
|
,"yqxhEkHvRFwZ"
|
||||||
|
@ -44,11 +44,12 @@ propertyTests =
|
||||||
,"sHHsX"
|
,"sHHsX"
|
||||||
,"mRKs9d"
|
,"mRKs9d"
|
||||||
,"o2KiCX5'ZRzHJfRi8" ]
|
,"o2KiCX5'ZRzHJfRi8" ]
|
||||||
, Pat.PVar "su'BrrbPUK6I33Eq" ]
|
, P.Var "su'BrrbPUK6I33Eq"
|
||||||
|
]
|
||||||
|
|
||||||
prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
|
prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
|
||||||
prop_parse_print p x =
|
prop_parse_print p x =
|
||||||
either (const False) (== x) . parse_print p $ x
|
either (const False) (== x) . parse_print p $ x
|
||||||
|
|
||||||
parse_print :: (Pretty a) => IParser a -> a -> Either String a
|
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
|
parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
|
||||||
|
|
|
@ -8,98 +8,112 @@ import Test.QuickCheck.Gen
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Parse.Helpers (reserveds)
|
import qualified Parse.Helpers (reserveds)
|
||||||
|
|
||||||
import SourceSyntax.Literal
|
import qualified SourceSyntax.Literal as L
|
||||||
import SourceSyntax.Pattern
|
import qualified SourceSyntax.Pattern as P
|
||||||
import SourceSyntax.Type hiding (listOf)
|
import qualified SourceSyntax.Type as T
|
||||||
|
|
||||||
instance Arbitrary Literal where
|
instance Arbitrary L.Literal where
|
||||||
arbitrary = oneof [ IntNum <$> arbitrary
|
arbitrary =
|
||||||
, FloatNum <$> (arbitrary `suchThat` noE)
|
oneof
|
||||||
, Chr <$> arbitrary
|
[ L.IntNum <$> arbitrary
|
||||||
|
, L.FloatNum <$> (arbitrary `suchThat` noE)
|
||||||
|
, L.Chr <$> arbitrary
|
||||||
-- This is too permissive
|
-- This is too permissive
|
||||||
, Str <$> arbitrary
|
, L.Str <$> arbitrary
|
||||||
-- Booleans aren't actually source syntax
|
-- Booleans aren't actually source syntax
|
||||||
-- , Boolean <$> arbitrary
|
-- , Boolean <$> arbitrary
|
||||||
]
|
]
|
||||||
shrink l = case l of
|
|
||||||
IntNum n -> IntNum <$> shrink n
|
shrink lit =
|
||||||
FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
|
case lit of
|
||||||
Chr c -> Chr <$> shrink c
|
L.IntNum n -> L.IntNum <$> shrink n
|
||||||
Str s -> Str <$> shrink s
|
L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
|
||||||
Boolean b -> Boolean <$> shrink b
|
L.Chr c -> L.Chr <$> shrink c
|
||||||
|
L.Str s -> L.Str <$> shrink s
|
||||||
|
L.Boolean b -> L.Boolean <$> shrink b
|
||||||
|
|
||||||
noE :: Double -> Bool
|
noE :: Double -> Bool
|
||||||
noE = notElem 'e' . show
|
noE = notElem 'e' . show
|
||||||
|
|
||||||
|
genVector :: Int -> (Int -> Gen a) -> Gen [a]
|
||||||
instance Arbitrary Pattern where
|
genVector n generator = do
|
||||||
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)
|
len <- choose (0,n)
|
||||||
let m = n `div` (len + 1)
|
let m = n `div` (len + 1)
|
||||||
vectorOf len $ pat m
|
vectorOf len $ generator m
|
||||||
|
|
||||||
shrink pat = case pat of
|
instance Arbitrary P.Pattern where
|
||||||
PAnything -> []
|
arbitrary = sized pat
|
||||||
PVar v -> PVar <$> shrinkWHead v
|
where
|
||||||
PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
|
pat :: Int -> Gen P.Pattern
|
||||||
PLiteral l -> PLiteral <$> shrink l
|
pat n =
|
||||||
PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
|
oneof
|
||||||
PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
|
[ pure P.Anything
|
||||||
|
, P.Var <$> lowVar
|
||||||
|
, P.Record <$> (listOf1 lowVar)
|
||||||
|
, P.Literal <$> arbitrary
|
||||||
|
, P.Alias <$> lowVar <*> pat (n-1)
|
||||||
|
, P.Data <$> capVar <*> genVector n pat
|
||||||
|
]
|
||||||
|
|
||||||
|
shrink pat =
|
||||||
|
case pat of
|
||||||
|
P.Anything -> []
|
||||||
|
P.Var v -> P.Var <$> shrinkWHead v
|
||||||
|
P.Literal l -> P.Literal <$> shrink l
|
||||||
|
P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)
|
||||||
|
P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)
|
||||||
|
P.Record fs ->
|
||||||
|
P.Record <$> filter (all notNull) (filter notNull (shrink fs))
|
||||||
|
where
|
||||||
|
notNull = not . null
|
||||||
|
|
||||||
shrinkWHead :: Arbitrary a => [a] -> [[a]]
|
shrinkWHead :: Arbitrary a => [a] -> [[a]]
|
||||||
shrinkWHead [] = error "Should be nonempty"
|
shrinkWHead [] = error "Should be nonempty"
|
||||||
shrinkWHead (x:xs) = (x:) <$> shrink xs
|
shrinkWHead (x:xs) = (x:) <$> shrink xs
|
||||||
|
|
||||||
instance Arbitrary Type where
|
instance Arbitrary T.Type where
|
||||||
arbitrary = sized tipe
|
arbitrary = sized tipe
|
||||||
where tipe :: Int -> Gen Type
|
where
|
||||||
tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
|
tipe :: Int -> Gen T.Type
|
||||||
, Var <$> lowVar
|
tipe n =
|
||||||
, Data <$> capVar <*> depthTipes
|
let depthTipe = tipe =<< choose (0,n)
|
||||||
, 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
|
field = (,) <$> lowVar <*> depthTipe
|
||||||
fields = do
|
fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
|
||||||
len <- choose (0,n)
|
|
||||||
let m = n `div` (len + 1)
|
|
||||||
vectorOf len $ (,) <$> lowVar <*> tipe m
|
|
||||||
fields1 = (:) <$> field <*> fields
|
fields1 = (:) <$> field <*> fields
|
||||||
|
in
|
||||||
|
oneof
|
||||||
|
[ T.Lambda <$> depthTipe <*> depthTipe
|
||||||
|
, T.Var <$> lowVar
|
||||||
|
, T.Data <$> capVar <*> genVector n tipe
|
||||||
|
, T.Record <$> fields <*> pure Nothing
|
||||||
|
, T.Record <$> fields1 <*> (Just <$> lowVar)
|
||||||
|
]
|
||||||
|
|
||||||
shrink tipe = case tipe of
|
shrink tipe =
|
||||||
Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
|
case tipe of
|
||||||
Var _ -> []
|
T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
|
||||||
Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
|
T.Var _ -> []
|
||||||
Record fs t -> map snd fs ++ case t of
|
T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
|
||||||
Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
|
T.Record fs t -> map snd fs ++ record
|
||||||
|
where
|
||||||
|
record =
|
||||||
|
case t of
|
||||||
|
Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
|
||||||
Just _ ->
|
Just _ ->
|
||||||
do
|
do fields <- filter (not . null) $ shrinkList shrinkField fs
|
||||||
fields <- filter (not . null) $ shrinkList shrinkField fs
|
return $ T.Record fields t
|
||||||
return $ Record fields t
|
|
||||||
where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
|
shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
|
||||||
|
|
||||||
lowVar :: Gen String
|
lowVar :: Gen String
|
||||||
lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
|
lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
|
||||||
where lower = elements ['a'..'z']
|
where
|
||||||
|
lower = elements ['a'..'z']
|
||||||
|
|
||||||
capVar :: Gen String
|
capVar :: Gen String
|
||||||
capVar = notReserved $ (:) <$> upper <*> listOf varLetter
|
capVar = notReserved $ (:) <$> upper <*> listOf varLetter
|
||||||
where upper = elements ['A'..'Z']
|
where
|
||||||
|
upper = elements ['A'..'Z']
|
||||||
|
|
||||||
varLetter :: Gen Char
|
varLetter :: Gen Char
|
||||||
varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
|
varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']
|
||||||
|
@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds
|
||||||
|
|
||||||
exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
|
exceptFor :: (Ord a) => Gen a -> [a] -> Gen a
|
||||||
exceptFor g xs = g `suchThat` notAnX
|
exceptFor g xs = g `suchThat` notAnX
|
||||||
where notAnX = flip Set.notMember xset
|
where
|
||||||
|
notAnX = flip Set.notMember xset
|
||||||
xset = Set.fromList xs
|
xset = Set.fromList xs
|
||||||
|
|
Loading…
Reference in a new issue