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
|
||||
Version: 0.11
|
||||
Version: 0.12
|
||||
Synopsis: The Elm language module.
|
||||
Description: Elm aims to make client-side web-development more pleasant.
|
||||
It is a statically/strongly typed, functional reactive
|
||||
|
@ -14,7 +14,7 @@ License-file: LICENSE
|
|||
|
||||
Author: Evan Czaplicki
|
||||
Maintainer: info@elm-lang.org
|
||||
Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
|
||||
Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
|
||||
|
||||
Category: Compiler, Language
|
||||
|
||||
|
@ -37,19 +37,19 @@ Library
|
|||
Elm.Internal.Utils,
|
||||
Elm.Internal.Version
|
||||
Hs-Source-Dirs: compiler
|
||||
other-modules: SourceSyntax.Declaration,
|
||||
other-modules: SourceSyntax.Annotation,
|
||||
SourceSyntax.Declaration,
|
||||
SourceSyntax.Expression,
|
||||
SourceSyntax.Helpers,
|
||||
SourceSyntax.Literal,
|
||||
SourceSyntax.Location,
|
||||
SourceSyntax.Module,
|
||||
SourceSyntax.Pattern,
|
||||
SourceSyntax.PrettyPrint,
|
||||
SourceSyntax.Type,
|
||||
SourceSyntax.Variable,
|
||||
Generate.JavaScript,
|
||||
Generate.JavaScript.Helpers,
|
||||
Generate.JavaScript.Ports,
|
||||
Generate.Noscript,
|
||||
Generate.Markdown,
|
||||
Generate.Html,
|
||||
Generate.Cases,
|
||||
|
@ -97,7 +97,7 @@ Library
|
|||
Build-depends: aeson,
|
||||
base >=4.2 && <5,
|
||||
binary >= 0.6.4.0,
|
||||
blaze-html == 0.5.* || == 0.6.*,
|
||||
blaze-html >= 0.5 && < 0.8,
|
||||
blaze-markup,
|
||||
bytestring,
|
||||
cmdargs,
|
||||
|
@ -119,19 +119,19 @@ Executable elm
|
|||
Main-is: Compiler.hs
|
||||
ghc-options: -threaded -O2
|
||||
Hs-Source-Dirs: compiler
|
||||
other-modules: SourceSyntax.Declaration,
|
||||
other-modules: SourceSyntax.Annotation,
|
||||
SourceSyntax.Declaration,
|
||||
SourceSyntax.Expression,
|
||||
SourceSyntax.Helpers,
|
||||
SourceSyntax.Literal,
|
||||
SourceSyntax.Location,
|
||||
SourceSyntax.Module,
|
||||
SourceSyntax.Pattern,
|
||||
SourceSyntax.PrettyPrint,
|
||||
SourceSyntax.Type,
|
||||
SourceSyntax.Variable,
|
||||
Generate.JavaScript,
|
||||
Generate.JavaScript.Helpers,
|
||||
Generate.JavaScript.Ports,
|
||||
Generate.Noscript,
|
||||
Generate.Markdown,
|
||||
Generate.Html,
|
||||
Generate.Cases,
|
||||
|
@ -179,8 +179,8 @@ Executable elm
|
|||
Build-depends: aeson,
|
||||
base >=4.2 && <5,
|
||||
binary >= 0.6.4.0,
|
||||
blaze-html == 0.5.* || == 0.6.*,
|
||||
blaze-markup == 0.5.1.*,
|
||||
blaze-html >= 0.5 && < 0.8,
|
||||
blaze-markup,
|
||||
bytestring,
|
||||
cmdargs,
|
||||
containers >= 0.3,
|
||||
|
@ -200,15 +200,16 @@ Executable elm
|
|||
Executable elm-doc
|
||||
Main-is: Docs.hs
|
||||
Hs-Source-Dirs: compiler
|
||||
other-modules: SourceSyntax.Declaration,
|
||||
other-modules: SourceSyntax.Annotation,
|
||||
SourceSyntax.Declaration,
|
||||
SourceSyntax.Expression,
|
||||
SourceSyntax.Helpers,
|
||||
SourceSyntax.Literal,
|
||||
SourceSyntax.Location,
|
||||
SourceSyntax.Module,
|
||||
SourceSyntax.Pattern,
|
||||
SourceSyntax.PrettyPrint,
|
||||
SourceSyntax.Type,
|
||||
SourceSyntax.Variable,
|
||||
Parse.Binop,
|
||||
Parse.Declaration,
|
||||
Parse.Expression,
|
||||
|
|
3
Setup.hs
3
Setup.hs
|
@ -148,7 +148,8 @@ buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()
|
|||
buildRuntime lbi elmos = do
|
||||
createDirectoryIfMissing True (rtsDir 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"
|
||||
mapM_ (appendTo rts') =<< getFiles ".js" "libraries"
|
||||
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
|
||||
|
||||
* Lazy and Lazy.Stream (thanks to Max New)
|
||||
* sortBy, sortWith (thanks to Max Goldstein)
|
||||
* Ports, a new FFI that is more general and much nicer to use
|
||||
* Basic compiler tests (thanks to Max New)
|
||||
|
||||
## 0.10.1
|
||||
|
||||
* sort, sortBy, sortWith (thanks to Max Goldstein)
|
||||
* elm-repl
|
||||
* Markdown interpolation
|
||||
* Bitwise library
|
||||
* Regex library
|
||||
* Improve Transform2D library (thanks to Michael Søndergaard)
|
|
@ -29,10 +29,7 @@ getSortedDependencies srcDirs builtIns root =
|
|||
result <- runErrorT $ readAllDeps allSrcDirs builtIns root
|
||||
case result of
|
||||
Right deps -> sortDeps deps
|
||||
Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
|
||||
where msg = "\nYou may need to create a " ++
|
||||
Path.dependencyFile ++
|
||||
" file if you\nare trying to use a 3rd party library."
|
||||
Left err -> failure err
|
||||
|
||||
extraDependencies :: IO (Maybe [FilePath])
|
||||
extraDependencies =
|
||||
|
@ -75,20 +72,22 @@ sortDeps depends =
|
|||
msg = "A cyclical module dependency or was detected in:\n"
|
||||
|
||||
readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
|
||||
readAllDeps srcDirs builtIns root =
|
||||
do let ifaces = (Set.fromList . Map.keys) builtIns
|
||||
State.evalStateT (go ifaces root) Set.empty
|
||||
readAllDeps srcDirs rawBuiltIns filePath =
|
||||
State.evalStateT (go Nothing filePath) Set.empty
|
||||
where
|
||||
go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
|
||||
go builtIns root = do
|
||||
root' <- lift $ findSrcFile srcDirs root
|
||||
(name, deps) <- lift $ readDeps root'
|
||||
builtIns :: Set.Set String
|
||||
builtIns = Set.fromList $ Map.keys rawBuiltIns
|
||||
|
||||
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
|
||||
let realDeps = Set.difference (Set.fromList deps) builtIns
|
||||
newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
|
||||
State.put (Set.insert name (Set.union newDeps seen))
|
||||
rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
|
||||
return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
|
||||
State.put (Set.insert moduleName (Set.union newDeps seen))
|
||||
rest <- mapM (go (Just moduleName) . toFilePath) (Set.toList newDeps)
|
||||
return ((makeRelative "." filePath', moduleName, Set.toList realDeps) : concat rest)
|
||||
|
||||
readDeps :: FilePath -> ErrorT String IO (String, [String])
|
||||
readDeps path = do
|
||||
|
@ -98,15 +97,10 @@ readDeps path = do
|
|||
where msg = "Error resolving dependencies in " ++ path ++ ":\n"
|
||||
Right o -> return o
|
||||
|
||||
findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
|
||||
findSrcFile dirs path = foldr tryDir notFound dirs
|
||||
findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
|
||||
findSrcFile parentModuleName dirs path =
|
||||
foldr tryDir notFound dirs
|
||||
where
|
||||
notFound = throwError $ unlines
|
||||
[ "Could not find file: " ++ path
|
||||
, " If it is not in the root directory of your project, use"
|
||||
, " --src-dir to declare additional locations for source files."
|
||||
, " If it is part of a 3rd party library, it needs to be declared"
|
||||
, " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
|
||||
tryDir dir next = do
|
||||
let path' = dir </> path
|
||||
exists <- liftIO $ doesFileExist path'
|
||||
|
@ -114,6 +108,20 @@ findSrcFile dirs path = foldr tryDir notFound dirs
|
|||
then return path'
|
||||
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 name = List.isPrefixOf "Native." name
|
||||
|
||||
|
|
|
@ -2,7 +2,6 @@
|
|||
module Build.Source (build) where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import System.FilePath as FP
|
||||
import Text.PrettyPrint (Doc)
|
||||
|
||||
|
@ -33,7 +32,7 @@ build noPrelude interfaces source =
|
|||
|
||||
let exports'
|
||||
| null exs =
|
||||
let get = Set.toList . Pattern.boundVars in
|
||||
let get = Pattern.boundVarList in
|
||||
concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
|
||||
concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
|
||||
[ name | TypeAlias name _ (Type.Record _ _) <- decls ]
|
||||
|
|
|
@ -1,8 +1,11 @@
|
|||
{-# OPTIONS_GHC -W #-}
|
||||
module Build.Utils where
|
||||
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Environment (getEnv)
|
||||
import System.FilePath ((</>), replaceExtension)
|
||||
import qualified Build.Flags as Flag
|
||||
import qualified Paths_Elm as This
|
||||
|
||||
buildPath :: Flag.Flags -> FilePath -> String -> FilePath
|
||||
buildPath flags filePath ext =
|
||||
|
@ -19,3 +22,14 @@ elmo flags filePath =
|
|||
elmi :: Flag.Flags -> FilePath -> FilePath
|
||||
elmi flags filePath =
|
||||
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 Control.Applicative ((<$>))
|
||||
import Control.Arrow (second)
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Encode.Pretty
|
||||
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.Text as Text
|
||||
|
||||
import SourceSyntax.Helpers (isSymbol)
|
||||
import SourceSyntax.Type (Type(..))
|
||||
import qualified SourceSyntax.Helpers as Help
|
||||
import qualified SourceSyntax.Type as T
|
||||
import qualified SourceSyntax.Expression as E
|
||||
import qualified SourceSyntax.Declaration as D
|
||||
|
||||
|
@ -30,20 +31,24 @@ data Flags = Flags
|
|||
{ files :: [FilePath] }
|
||||
deriving (Data,Typeable,Show,Eq)
|
||||
|
||||
defaultFlags :: Flags
|
||||
defaultFlags = Flags
|
||||
{ files = def &= args &= typ "FILES"
|
||||
} &= help "Generate documentation for Elm"
|
||||
&= summary ("Generate documentation for Elm, (c) Evan Czaplicki")
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
flags <- cmdArgs defaultFlags
|
||||
mapM parseFile (files flags)
|
||||
mapM_ parseFile (files flags)
|
||||
|
||||
config :: Config
|
||||
config = Config { confIndent = 2, confCompare = keyOrder keys }
|
||||
where
|
||||
keys = ["name","document","comment","raw","aliases","datatypes"
|
||||
keys = ["tag","name","document","comment","raw","aliases","datatypes"
|
||||
,"values","typeVariables","type","constructors"]
|
||||
|
||||
parseFile :: FilePath -> IO ()
|
||||
parseFile path = do
|
||||
source <- readFile path
|
||||
case iParse docs source of
|
||||
|
@ -69,6 +74,7 @@ docComment = do
|
|||
let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents
|
||||
return $ dropWhile (==' ') (reverse reversed)
|
||||
|
||||
moduleDocs :: IParser (String, [String], String)
|
||||
moduleDocs = do
|
||||
optional freshLine
|
||||
(names,exports) <- moduleDef
|
||||
|
@ -121,7 +127,7 @@ collect infixes types aliases adts things =
|
|||
where
|
||||
nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes
|
||||
addDefaultInfix name pairs
|
||||
| all isSymbol name = addInfix (D.L, 9 :: Int) pairs
|
||||
| all Help.isSymbol name = addInfix (D.L, 9 :: Int) pairs
|
||||
| otherwise = pairs
|
||||
|
||||
customOps = Map.intersectionWith addInfix infixes types
|
||||
|
@ -138,7 +144,7 @@ collect infixes types aliases adts things =
|
|||
let fields = ["typeVariables" .= vars, "type" .= tipe ]
|
||||
in collect infixes types (insert name fields aliases) adts rest
|
||||
D.Datatype name vars ctors ->
|
||||
let tipe = Data name (map Var vars)
|
||||
let tipe = T.Data name (map T.Var vars)
|
||||
fields = ["typeVariables" .= vars
|
||||
, "constructors" .= map (ctorToJson tipe) ctors ]
|
||||
in collect infixes types aliases (insert name fields adts) rest
|
||||
|
@ -147,17 +153,35 @@ collect infixes types aliases adts things =
|
|||
obj name fields =
|
||||
[ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields
|
||||
|
||||
instance ToJSON Type where
|
||||
toJSON tipe =
|
||||
case tipe of
|
||||
Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]
|
||||
Var x -> toJSON x
|
||||
Data name ts -> toJSON (toJSON name : map toJSON ts)
|
||||
Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'
|
||||
where fields' = case ext of
|
||||
Nothing -> fields
|
||||
Just x -> ("_", Var x) : fields
|
||||
instance ToJSON T.Type where
|
||||
toJSON tipe =
|
||||
object $
|
||||
case tipe of
|
||||
T.Lambda _ _ ->
|
||||
let tipes = T.collectLambdas tipe in
|
||||
[ "tag" .= ("function" :: Text.Text)
|
||||
, "args" .= toJSON (init tipes)
|
||||
, "result" .= toJSON (last tipes)
|
||||
]
|
||||
|
||||
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) =
|
||||
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
|
||||
|
||||
import System.IO.Unsafe
|
||||
import qualified Paths_Elm as This
|
||||
import Build.Utils (getDataFile)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
-- |Name of directory for all of a project's dependencies.
|
||||
dependencyDirectory :: FilePath
|
||||
|
@ -15,9 +16,9 @@ dependencyFile = "elm_dependencies.json"
|
|||
{-# NOINLINE runtime #-}
|
||||
-- |The absolute path to Elm's runtime system.
|
||||
runtime :: FilePath
|
||||
runtime = unsafePerformIO $ This.getDataFileName "elm-runtime.js"
|
||||
runtime = unsafePerformIO $ getDataFile "elm-runtime.js"
|
||||
|
||||
{-# NOINLINE docs #-}
|
||||
-- |The absolute path to Elm's core library documentation.
|
||||
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.Maybe (fromMaybe)
|
||||
|
||||
import SourceSyntax.Location
|
||||
import SourceSyntax.Literal
|
||||
import SourceSyntax.Pattern
|
||||
import SourceSyntax.Annotation
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Literal
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import qualified SourceSyntax.Variable as V
|
||||
import Transform.Substitute
|
||||
|
||||
|
||||
toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
|
||||
toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
|
||||
toMatch patterns = do
|
||||
v <- newVar
|
||||
(,) v <$> match [v] (map (first (:[])) patterns) Fail
|
||||
|
@ -27,7 +28,7 @@ data Match
|
|||
= Match String [Clause] Match
|
||||
| Break
|
||||
| Fail
|
||||
| Other LExpr
|
||||
| Other Expr
|
||||
| Seq [Match]
|
||||
deriving Show
|
||||
|
||||
|
@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
|
|||
matchSubst _ Break = Break
|
||||
matchSubst _ Fail = Fail
|
||||
matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
|
||||
matchSubst pairs (Other (L s e)) =
|
||||
Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
|
||||
matchSubst pairs (Other (A a e)) =
|
||||
Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
|
||||
matchSubst pairs (Match n cs m) =
|
||||
Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
|
||||
where varSubst v = fromMaybe v (lookup v pairs)
|
||||
|
@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
|
|||
|
||||
isCon (p:_, _) =
|
||||
case p of
|
||||
PData _ _ -> True
|
||||
PLiteral _ -> True
|
||||
_ -> False
|
||||
P.Data _ _ -> True
|
||||
P.Literal _ -> True
|
||||
_ -> False
|
||||
|
||||
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 [] [([],e)] Fail = return $ Other e
|
||||
match [] [([],e)] Break = return $ Other e
|
||||
|
@ -67,46 +68,46 @@ match vs@(v:_) cs def
|
|||
where
|
||||
cs' = map (dealias v) cs
|
||||
|
||||
dealias v c@(p:ps, L s e) =
|
||||
dealias v c@(p:ps, A a e) =
|
||||
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
|
||||
|
||||
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
|
||||
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
|
||||
subOnePattern pattern e =
|
||||
case pattern of
|
||||
PVar x -> subst x (Var v) e
|
||||
PAnything -> e
|
||||
PRecord fs ->
|
||||
foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
|
||||
P.Var x -> subst x (rawVar v) e
|
||||
P.Anything -> e
|
||||
P.Record 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
|
||||
where
|
||||
css = groupBy eq (sortBy cmp cs)
|
||||
|
||||
cmp (p1:_,_) (p2:_,_) =
|
||||
case (p1,p2) of
|
||||
(PData n1 _, PData n2 _) -> compare n1 n2
|
||||
(P.Data n1 _, P.Data n2 _) -> compare n1 n2
|
||||
_ -> compare p1 p2
|
||||
|
||||
eq (p1:_,_) (p2:_,_) =
|
||||
case (p1,p2) of
|
||||
(PData n1 _, PData n2 _) -> n1 == n2
|
||||
(P.Data n1 _, P.Data n2 _) -> n1 == n2
|
||||
_ -> p1 == p2
|
||||
|
||||
toClause cs =
|
||||
case head cs of
|
||||
(PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
|
||||
(PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
|
||||
(P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
|
||||
(P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
|
||||
|
||||
matchClause :: Either String Literal
|
||||
-> [String]
|
||||
-> [([Pattern],LExpr)]
|
||||
-> [([P.Pattern],Expr)]
|
||||
-> Match
|
||||
-> State Int Clause
|
||||
matchClause c (_:vs) cs def =
|
||||
|
@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
|
|||
|
||||
flatten (p:ps, e) =
|
||||
case p of
|
||||
PData _ ps' -> (ps' ++ ps, e)
|
||||
PLiteral _ -> (ps, e)
|
||||
P.Data _ ps' -> (ps' ++ ps, e)
|
||||
P.Literal _ -> (ps, e)
|
||||
|
||||
getVars =
|
||||
case head cs of
|
||||
(PData _ ps : _, _) -> forM ps (const newVar)
|
||||
(PLiteral _ : _, _) -> return []
|
||||
(P.Data _ ps : _, _) -> forM ps (const newVar)
|
||||
(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)
|
||||
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 #-}
|
||||
module Generate.JavaScript (generate) where
|
||||
|
||||
import Control.Arrow (first,(***))
|
||||
import Control.Applicative ((<$>),(<*>))
|
||||
import Control.Arrow (first,(***))
|
||||
import Control.Monad.State
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Language.ECMAScript3.PrettyPrint
|
||||
import Language.ECMAScript3.Syntax
|
||||
|
||||
import Generate.JavaScript.Helpers
|
||||
import qualified Generate.Cases as Case
|
||||
import qualified Generate.JavaScript.Ports as Port
|
||||
import qualified Generate.Markdown as MD
|
||||
import SourceSyntax.Annotation
|
||||
import SourceSyntax.Expression
|
||||
import qualified SourceSyntax.Helpers as Help
|
||||
import SourceSyntax.Literal
|
||||
import SourceSyntax.Pattern as Pattern
|
||||
import SourceSyntax.Location
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Module
|
||||
import Language.ECMAScript3.Syntax
|
||||
import Language.ECMAScript3.PrettyPrint
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import SourceSyntax.PrettyPrint (renderPretty)
|
||||
import qualified SourceSyntax.Variable as V
|
||||
import qualified Transform.SafeNames as MakeSafe
|
||||
|
||||
varDecl :: String -> Expression () -> VarDecl ()
|
||||
|
@ -50,10 +52,10 @@ literal lit =
|
|||
FloatNum n -> NumLit () n
|
||||
Boolean b -> BoolLit () b
|
||||
|
||||
expression :: LExpr -> State Int (Expression ())
|
||||
expression (L span expr) =
|
||||
expression :: Expr -> State Int (Expression ())
|
||||
expression (A region expr) =
|
||||
case expr of
|
||||
Var x -> return $ ref x
|
||||
Var (V.Raw x) -> return $ obj x
|
||||
Literal lit -> return $ literal lit
|
||||
|
||||
Range lo hi ->
|
||||
|
@ -85,17 +87,16 @@ expression (L span expr) =
|
|||
do fields' <- forM fields $ \(f,e) -> do
|
||||
(,) f <$> expression e
|
||||
let fieldMap = List.foldl' combine Map.empty fields'
|
||||
return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
|
||||
return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
|
||||
where
|
||||
combine r (k,v) = Map.insertWith (++) k [v] r
|
||||
prop = PropId () . var
|
||||
hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
|
||||
Map.toList . Map.filter (not . null) $ Map.map tail 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)
|
||||
body' <- expression body
|
||||
return $ case length args < 2 || length args > 9 of
|
||||
|
@ -104,13 +105,14 @@ expression (L span expr) =
|
|||
where
|
||||
depattern (args, body) pattern =
|
||||
case pattern of
|
||||
PVar x -> return (args ++ [x], body)
|
||||
P.Var x -> return (args ++ [x], body)
|
||||
_ -> 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
|
||||
|
||||
collect patterns lexpr@(L _ expr) =
|
||||
collect patterns lexpr@(A _ expr) =
|
||||
case expr of
|
||||
Lambda p e -> collect (p:patterns) e
|
||||
_ -> (patterns, lexpr)
|
||||
|
@ -127,7 +129,7 @@ expression (L span expr) =
|
|||
(func, args) = getArgs e1 [e2]
|
||||
getArgs func args =
|
||||
case func of
|
||||
(L _ (App f arg)) -> getArgs f (arg : args)
|
||||
(A _ (App f arg)) -> getArgs f (arg : args)
|
||||
_ -> (func, args)
|
||||
|
||||
Let defs e ->
|
||||
|
@ -139,9 +141,9 @@ expression (L span expr) =
|
|||
MultiIf branches ->
|
||||
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
|
||||
return $ case last branches of
|
||||
(L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
|
||||
(L _ (Literal (Boolean True)), _) -> safeIfs branches'
|
||||
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
|
||||
(A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
|
||||
(A _ (Literal (Boolean True)), _) -> safeIfs branches'
|
||||
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
|
||||
where
|
||||
safeIfs branches = ifs (init branches) (snd (last branches))
|
||||
ifs branches finally = foldr iff finally branches
|
||||
|
@ -151,10 +153,12 @@ expression (L span expr) =
|
|||
do (tempVar,initialMatch) <- Case.toMatch cases
|
||||
(revisedMatch, stmt) <-
|
||||
case e of
|
||||
L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
|
||||
_ -> do e' <- expression e
|
||||
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
|
||||
match' <- match span revisedMatch
|
||||
A _ (Var (V.Raw x)) ->
|
||||
return (Case.matchSubst [(tempVar,x)] initialMatch, [])
|
||||
_ ->
|
||||
do e' <- expression e
|
||||
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
|
||||
match' <- match region revisedMatch
|
||||
return (function [] (stmt ++ match') `call` [])
|
||||
|
||||
ExplicitList es ->
|
||||
|
@ -184,28 +188,28 @@ expression (L span expr) =
|
|||
[ string name, Port.outgoing tipe, value' ]
|
||||
|
||||
definition :: Def -> State Int [Statement ()]
|
||||
definition (Definition pattern expr@(L span _) _) = do
|
||||
definition (Definition pattern expr@(A region _) _) = do
|
||||
expr' <- expression expr
|
||||
let assign x = varDecl x expr'
|
||||
case pattern of
|
||||
PVar x
|
||||
P.Var x
|
||||
| Help.isOp x ->
|
||||
let op = LBracket () (ref "_op") (string x) in
|
||||
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
|
||||
| otherwise ->
|
||||
return [ VarDeclStmt () [ assign x ] ]
|
||||
|
||||
PRecord fields ->
|
||||
P.Record fields ->
|
||||
let setField f = varDecl f (dotSep ["$",f]) in
|
||||
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..])) ]
|
||||
where
|
||||
vars = getVars patterns
|
||||
getVars patterns =
|
||||
case patterns of
|
||||
PVar x : rest -> (x:) `fmap` getVars rest
|
||||
P.Var x : rest -> (x:) `fmap` getVars rest
|
||||
[] -> Just []
|
||||
_ -> Nothing
|
||||
|
||||
|
@ -216,41 +220,45 @@ definition (Definition pattern expr@(L span _) _) = do
|
|||
|
||||
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
|
||||
if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
|
||||
exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
|
||||
exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
|
||||
|
||||
_ ->
|
||||
do defs' <- concat <$> mapM toDef vars
|
||||
return (VarDeclStmt () [assign "$"] : defs')
|
||||
where
|
||||
vars = Set.toList $ Pattern.boundVars pattern
|
||||
mkVar = L span . Var
|
||||
toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
|
||||
in definition $ Definition (PVar y) expr Nothing
|
||||
vars = P.boundVarList pattern
|
||||
mkVar = A region . rawVar
|
||||
toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
|
||||
in definition $ Definition (P.Var y) expr Nothing
|
||||
|
||||
match :: SrcSpan -> Case.Match -> State Int [Statement ()]
|
||||
match span mtch =
|
||||
match :: Region -> Case.Match -> State Int [Statement ()]
|
||||
match region mtch =
|
||||
case mtch of
|
||||
Case.Match name clauses mtch' ->
|
||||
do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
|
||||
mtch'' <- match span mtch'
|
||||
do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
|
||||
mtch'' <- match region mtch'
|
||||
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
|
||||
where
|
||||
isLiteral p = case p of
|
||||
Case.Clause (Right _) _ _ -> True
|
||||
_ -> 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
|
||||
| or isChars = InfixExpr () OpAdd e (string "")
|
||||
| otherwise = e
|
||||
|
||||
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.Other e ->
|
||||
do e' <- expression e
|
||||
return [ ret e' ]
|
||||
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
|
||||
Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
|
||||
where
|
||||
dropEnd acc [] = acc
|
||||
dropEnd acc (m:ms) =
|
||||
|
@ -258,9 +266,9 @@ match span mtch =
|
|||
Case.Other _ -> acc ++ [m]
|
||||
_ -> dropEnd (acc ++ [m]) ms
|
||||
|
||||
clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
|
||||
clause span variable (Case.Clause value vars mtch) =
|
||||
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
|
||||
clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
|
||||
clause region variable (Case.Clause value vars mtch) =
|
||||
(,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
|
||||
where
|
||||
vars' = map (\n -> variable ++ "._" ++ show n) [0..]
|
||||
(isChar, pattern) =
|
||||
|
@ -273,8 +281,8 @@ clause span variable (Case.Clause value vars mtch) =
|
|||
[] -> name
|
||||
is -> drop (last is + 1) name
|
||||
|
||||
flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
|
||||
flattenLets defs lexpr@(L _ expr) =
|
||||
flattenLets :: [Def] -> Expr -> ([Def], Expr)
|
||||
flattenLets defs lexpr@(A _ expr) =
|
||||
case expr of
|
||||
Let ds body -> flattenLets (defs ++ ds) body
|
||||
_ -> (defs, lexpr)
|
||||
|
@ -288,7 +296,8 @@ generate unsafeModule =
|
|||
thisModule = dotSep ("_elm" : names modul ++ ["values"])
|
||||
programStmts =
|
||||
concat
|
||||
[ setup (Just "_elm") (names modul ++ ["values"])
|
||||
[ [ ExprStmt () $ string "use strict" ]
|
||||
, setup (Just "_elm") (names modul ++ ["values"])
|
||||
, [ IfSingleStmt () thisModule (ret thisModule) ]
|
||||
, [ internalImports (List.intercalate "." (names modul)) ]
|
||||
, concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
|
||||
|
@ -301,7 +310,7 @@ generate unsafeModule =
|
|||
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
|
||||
where
|
||||
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 =
|
||||
case path of
|
||||
|
@ -311,7 +320,7 @@ generate unsafeModule =
|
|||
|
||||
jsImport modul = setup Nothing path ++ [ include ]
|
||||
where
|
||||
path = split modul
|
||||
path = Help.splitDots modul
|
||||
include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
|
||||
|
||||
setup namespace path = map create paths
|
||||
|
@ -321,8 +330,8 @@ generate unsafeModule =
|
|||
Nothing -> tail . init $ List.inits path
|
||||
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
|
||||
|
||||
binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
|
||||
binop span op e1 e2 =
|
||||
binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
|
||||
binop region op e1 e2 =
|
||||
case op of
|
||||
"Basics.." ->
|
||||
do es <- mapM expression (e1 : collect [] e2)
|
||||
|
@ -335,7 +344,7 @@ binop span op e1 e2 =
|
|||
do e1' <- expression e1
|
||||
e2' <- expression e2
|
||||
return $ obj "_L.append" `call` [e1', e2']
|
||||
"::" -> expression (L span (Data "::" [e1,e2]))
|
||||
"::" -> expression (A region (Data "::" [e1,e2]))
|
||||
_ ->
|
||||
do e1' <- expression e1
|
||||
e2' <- expression e2
|
||||
|
@ -345,13 +354,13 @@ binop span op e1 e2 =
|
|||
where
|
||||
collect es e =
|
||||
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]
|
||||
|
||||
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
|
||||
| otherwise = dotSep parts
|
||||
where
|
||||
parts = split op
|
||||
parts = Help.splitDots op
|
||||
operator = last parts
|
||||
|
||||
opDict = Map.fromList (infixOps ++ specialOps)
|
||||
|
|
|
@ -32,7 +32,7 @@ incoming tipe =
|
|||
|
||||
inc :: Type -> Expression () -> Expression ()
|
||||
inc tipe x =
|
||||
case tipe of
|
||||
case tipe of
|
||||
Lambda _ _ -> error "functions should not be allowed through input ports"
|
||||
Var _ -> error "type variables should not be allowed through input ports"
|
||||
Data ctor []
|
||||
|
@ -58,22 +58,26 @@ inc tipe x =
|
|||
where
|
||||
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
|
||||
tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values
|
||||
tuple = ObjectLit () $ (prop "ctor", string ctor) : values
|
||||
values = zipWith convert [0..] ts
|
||||
convert n t = ( PropId () $ var ('_':show n)
|
||||
convert n t = ( prop ('_':show 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
|
||||
object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys
|
||||
object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
|
||||
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 =
|
||||
case tipe of
|
||||
|
@ -109,19 +113,21 @@ out tipe x =
|
|||
| ctor == "Maybe.Maybe" ->
|
||||
CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
|
||||
(NullLit ())
|
||||
(DotRef () x (var "_0"))
|
||||
(out t (DotRef () x (var "_0")))
|
||||
|
||||
| ctor == "_List" ->
|
||||
DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t
|
||||
|
||||
Data ctor ts | Help.isTuple ctor ->
|
||||
ArrayLit () $ zipWith convert [0..] ts
|
||||
where
|
||||
convert n t = out t $ DotRef () x $ var ('_':show n)
|
||||
Data ctor ts
|
||||
| Help.isTuple ctor ->
|
||||
let 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 ->
|
||||
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 Control.Exception as E
|
||||
import qualified Paths_Elm as Path
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import SourceSyntax.Module
|
||||
import qualified Build.Interface as Interface
|
||||
import Build.Utils (getDataFile)
|
||||
|
||||
add :: Bool -> Module def -> Module def
|
||||
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 _ -> []
|
||||
|
||||
prelude :: [(String, ImportMethod)]
|
||||
prelude = string : text ++ map (\n -> (n, Hiding [])) modules
|
||||
prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules
|
||||
where
|
||||
text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]
|
||||
string = ("String", As "String")
|
||||
modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"
|
||||
, "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]
|
||||
string = map ((,) "String") [ As "String", Importing ["show"] ]
|
||||
modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"
|
||||
, "Graphics.Element", "Graphics.Collage", "Native.Ports" ]
|
||||
|
||||
interfaces :: Bool -> IO Interfaces
|
||||
interfaces noPrelude =
|
||||
if noPrelude
|
||||
then return $ Map.empty
|
||||
else safeReadDocs =<< Path.getDataFileName "interfaces.data"
|
||||
then return Map.empty
|
||||
else safeReadDocs =<< getDataFile "interfaces.data"
|
||||
|
||||
safeReadDocs :: FilePath -> IO Interfaces
|
||||
safeReadDocs name =
|
||||
|
|
|
@ -1,10 +1,11 @@
|
|||
{-# OPTIONS_GHC -W #-}
|
||||
module Parse.Binop (binops, OpTable) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import SourceSyntax.Location (merge)
|
||||
import SourceSyntax.Annotation (merge)
|
||||
import qualified SourceSyntax.Expression as E
|
||||
import SourceSyntax.Declaration (Assoc(..))
|
||||
import Text.Parsec
|
||||
|
@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
|
|||
opAssoc :: OpTable -> String -> Assoc
|
||||
opAssoc table op = snd $ Map.findWithDefault (9,L) op table
|
||||
|
||||
hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
|
||||
hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool
|
||||
hasLevel table n (op,_) = opLevel table op == n
|
||||
|
||||
binops :: IParser E.LParseExpr
|
||||
-> IParser E.LParseExpr
|
||||
binops :: IParser E.ParseExpr
|
||||
-> IParser E.ParseExpr
|
||||
-> IParser String
|
||||
-> IParser E.LParseExpr
|
||||
-> IParser E.ParseExpr
|
||||
binops term last anyOp =
|
||||
do e <- term
|
||||
table <- getState
|
||||
|
@ -38,9 +39,9 @@ binops term last anyOp =
|
|||
|
||||
split :: OpTable
|
||||
-> Int
|
||||
-> E.LParseExpr
|
||||
-> [(String, E.LParseExpr)]
|
||||
-> IParser E.LParseExpr
|
||||
-> E.ParseExpr
|
||||
-> [(String, E.ParseExpr)]
|
||||
-> IParser E.ParseExpr
|
||||
split _ _ e [] = return e
|
||||
split table n e eops = do
|
||||
assoc <- getAssoc table n eops
|
||||
|
@ -49,26 +50,26 @@ split table n e eops = do
|
|||
case assoc of R -> joinR es ops
|
||||
_ -> joinL es ops
|
||||
|
||||
splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
|
||||
-> [IParser E.LParseExpr]
|
||||
splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
|
||||
-> [IParser E.ParseExpr]
|
||||
splitLevel table n e eops =
|
||||
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
|
||||
(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 (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
|
||||
joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
|
||||
|
||||
joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
|
||||
joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
|
||||
joinR [e] [] = return e
|
||||
joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
|
||||
return (merge a e (E.Binop op a e))
|
||||
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
|
||||
| all (==L) assocs = return L
|
||||
| all (==R) assocs = return R
|
||||
|
@ -79,5 +80,5 @@ getAssoc table n eops
|
|||
assocs = map (opAssoc table . fst) levelOps
|
||||
msg problem =
|
||||
concat [ "Conflicting " ++ problem ++ " for binary operators ("
|
||||
, intercalate ", " (map fst eops), "). "
|
||||
, List.intercalate ", " (map fst eops), "). "
|
||||
, "Consider adding parentheses to disambiguate." ]
|
||||
|
|
|
@ -5,45 +5,45 @@ import Data.List (foldl')
|
|||
import Text.Parsec hiding (newline,spaces)
|
||||
import Text.Parsec.Indent
|
||||
|
||||
import Parse.Binop
|
||||
import Parse.Helpers
|
||||
import Parse.Literal
|
||||
import qualified Parse.Pattern as Pattern
|
||||
import qualified Parse.Type as Type
|
||||
import Parse.Binop
|
||||
import Parse.Literal
|
||||
|
||||
import SourceSyntax.Location as Location
|
||||
import SourceSyntax.Pattern hiding (tuple,list)
|
||||
import qualified SourceSyntax.Literal as Literal
|
||||
import SourceSyntax.Annotation as Annotation
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import qualified SourceSyntax.Literal as L
|
||||
import SourceSyntax.Expression
|
||||
|
||||
|
||||
-------- Basic Terms --------
|
||||
|
||||
varTerm :: IParser ParseExpr
|
||||
varTerm :: IParser ParseExpr'
|
||||
varTerm = toVar <$> var <?> "variable"
|
||||
|
||||
toVar :: String -> ParseExpr
|
||||
toVar v = case v of "True" -> Literal (Literal.Boolean True)
|
||||
"False" -> Literal (Literal.Boolean False)
|
||||
_ -> Var v
|
||||
toVar :: String -> ParseExpr'
|
||||
toVar v = case v of "True" -> Literal (L.Boolean True)
|
||||
"False" -> Literal (L.Boolean False)
|
||||
_ -> rawVar v
|
||||
|
||||
accessor :: IParser ParseExpr
|
||||
accessor :: IParser ParseExpr'
|
||||
accessor = do
|
||||
(start, lbl, end) <- located (try (string "." >> rLabel))
|
||||
let loc e = Location.at start end e
|
||||
return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
|
||||
let loc e = Annotation.at start end e
|
||||
return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
|
||||
|
||||
negative :: IParser ParseExpr
|
||||
negative :: IParser ParseExpr'
|
||||
negative = do
|
||||
(start, nTerm, end) <-
|
||||
located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
|
||||
let loc e = Location.at start end e
|
||||
return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
|
||||
let loc e = Annotation.at start end e
|
||||
return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
|
||||
|
||||
|
||||
-------- Complex Terms --------
|
||||
|
||||
listTerm :: IParser ParseExpr
|
||||
listTerm :: IParser ParseExpr'
|
||||
listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
|
||||
where
|
||||
range = do
|
||||
|
@ -60,92 +60,93 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
|
|||
span uid index =
|
||||
"<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 "{{")
|
||||
e <- padded expr
|
||||
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)
|
||||
where
|
||||
opFn = do
|
||||
(start, op, end) <- located anyOp
|
||||
let loc = Location.at start end
|
||||
return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
|
||||
Binop op (loc $ Var "x") (loc $ Var "y")
|
||||
let loc = Annotation.at start end
|
||||
return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
|
||||
Binop op (loc $ rawVar "x") (loc $ rawVar "y")
|
||||
|
||||
tupleFn = do
|
||||
let comma = char ',' <?> "comma ','"
|
||||
(start, commas, end) <- located (comma >> many (whitespace >> comma))
|
||||
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)
|
||||
(loc . tuple $ map (loc . Var) vars) (map PVar vars)
|
||||
(loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
|
||||
|
||||
parened = do
|
||||
(start, es, end) <- located (commaSep expr)
|
||||
return $ case es of
|
||||
[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 ]
|
||||
where field = do
|
||||
label <- rLabel
|
||||
patterns <- spacePrefix Pattern.term
|
||||
padded equals
|
||||
body <- expr
|
||||
return (label, makeFunction patterns body)
|
||||
where
|
||||
field = do
|
||||
label <- rLabel
|
||||
patterns <- spacePrefix Pattern.term
|
||||
padded equals
|
||||
body <- expr
|
||||
return (label, makeFunction patterns body)
|
||||
|
||||
record = Record <$> commaSep field
|
||||
record = Record <$> commaSep field
|
||||
|
||||
change = do
|
||||
lbl <- rLabel
|
||||
padded (string "<-")
|
||||
(,) lbl <$> expr
|
||||
change = do
|
||||
lbl <- rLabel
|
||||
padded (string "<-")
|
||||
(,) lbl <$> expr
|
||||
|
||||
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
|
||||
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
|
||||
|
||||
insert r = addLocation $ do
|
||||
string "|" >> whitespace
|
||||
Insert r <$> rLabel <*> (padded equals >> expr)
|
||||
insert r = addLocation $ do
|
||||
string "|" >> whitespace
|
||||
Insert r <$> rLabel <*> (padded equals >> expr)
|
||||
|
||||
modify r = addLocation
|
||||
(string "|" >> whitespace >> Modify r <$> commaSep1 change)
|
||||
modify r =
|
||||
addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
|
||||
|
||||
misc = try $ do
|
||||
record <- addLocation (Var <$> rLabel)
|
||||
opt <- padded (optionMaybe (remove record))
|
||||
case opt of
|
||||
Just e -> try (insert e) <|> return e
|
||||
Nothing -> try (insert record) <|> try (modify record)
|
||||
misc = try $ do
|
||||
record <- addLocation (rawVar <$> rLabel)
|
||||
opt <- padded (optionMaybe (remove record))
|
||||
case opt of
|
||||
Just e -> try (insert e) <|> return e
|
||||
Nothing -> try (insert record) <|> try (modify record)
|
||||
|
||||
|
||||
term :: IParser LParseExpr
|
||||
term :: IParser ParseExpr
|
||||
term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
|
||||
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
|
||||
<?> "basic term (4, x, 'c', etc.)"
|
||||
|
||||
-------- Applications --------
|
||||
|
||||
appExpr :: IParser LParseExpr
|
||||
appExpr :: IParser ParseExpr
|
||||
appExpr = do
|
||||
t <- term
|
||||
ts <- constrainedSpacePrefix term $ \str ->
|
||||
if null str then notFollowedBy (char '-') else return ()
|
||||
return $ case ts of
|
||||
[] -> 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 --------
|
||||
|
||||
binaryExpr :: IParser LParseExpr
|
||||
binaryExpr :: IParser ParseExpr
|
||||
binaryExpr = binops appExpr lastExpr anyOp
|
||||
where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
|
||||
<|> lambdaExpr
|
||||
|
||||
ifExpr :: IParser ParseExpr
|
||||
ifExpr :: IParser ParseExpr'
|
||||
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
||||
where
|
||||
normal = do
|
||||
|
@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
|||
whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
|
||||
elseBranch <- expr
|
||||
return $ MultiIf [(bool, thenBranch),
|
||||
(Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
|
||||
(Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
|
||||
multiIf = MultiIf <$> spaceSep1 iff
|
||||
where iff = do string "|" ; whitespace
|
||||
b <- expr ; padded arrow
|
||||
(,) b <$> expr
|
||||
|
||||
lambdaExpr :: IParser LParseExpr
|
||||
lambdaExpr :: IParser ParseExpr
|
||||
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
||||
whitespace
|
||||
args <- spaceSep1 Pattern.term
|
||||
|
@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
|||
defSet :: IParser [ParseDef]
|
||||
defSet = block (do d <- def ; whitespace ; return d)
|
||||
|
||||
letExpr :: IParser ParseExpr
|
||||
letExpr :: IParser ParseExpr'
|
||||
letExpr = do
|
||||
reserved "let" ; whitespace
|
||||
defs <- defSet
|
||||
padded (reserved "in")
|
||||
Let defs <$> expr
|
||||
|
||||
caseExpr :: IParser ParseExpr
|
||||
caseExpr :: IParser ParseExpr'
|
||||
caseExpr = do
|
||||
reserved "case"; e <- padded expr; reserved "of"; whitespace
|
||||
Case e <$> (with <|> without)
|
||||
|
@ -189,35 +190,35 @@ caseExpr = do
|
|||
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
|
||||
without = block (do c <- case_ ; whitespace ; return c)
|
||||
|
||||
expr :: IParser LParseExpr
|
||||
expr :: IParser ParseExpr
|
||||
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
|
||||
<|> lambdaExpr
|
||||
<|> binaryExpr
|
||||
<?> "an expression"
|
||||
|
||||
defStart :: IParser [Pattern]
|
||||
defStart :: IParser [P.Pattern]
|
||||
defStart =
|
||||
choice [ do p1 <- try Pattern.term
|
||||
infics p1 <|> func p1
|
||||
, func =<< (PVar <$> parens symOp)
|
||||
, func =<< (P.Var <$> parens symOp)
|
||||
, (:[]) <$> Pattern.expr
|
||||
] <?> "the definition of a variable (x = ...)"
|
||||
where
|
||||
func pattern =
|
||||
case pattern of
|
||||
PVar _ -> (pattern:) <$> spacePrefix Pattern.term
|
||||
P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
|
||||
_ -> do try (lookAhead (whitespace >> string "="))
|
||||
return [pattern]
|
||||
|
||||
infics p1 = do
|
||||
o:p <- try (whitespace >> anyOp)
|
||||
p2 <- (whitespace >> Pattern.term)
|
||||
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
|
||||
else [ PVar (o:p), p1, p2 ]
|
||||
return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
|
||||
else [ P.Var (o:p), p1, p2 ]
|
||||
|
||||
makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
|
||||
makeFunction args body@(L s _) =
|
||||
foldr (\arg body' -> L s $ Lambda arg body') body args
|
||||
makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
|
||||
makeFunction args body@(A ann _) =
|
||||
foldr (\arg body' -> A ann $ Lambda arg body') body args
|
||||
|
||||
definition :: IParser ParseDef
|
||||
definition = withPos $ do
|
||||
|
|
|
@ -12,11 +12,12 @@ import Text.Parsec hiding (newline,spaces,State)
|
|||
import Text.Parsec.Indent
|
||||
import qualified Text.Parsec.Token as T
|
||||
|
||||
import SourceSyntax.Helpers as Help
|
||||
import SourceSyntax.Location as Location
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.PrettyPrint
|
||||
import SourceSyntax.Annotation as Annotation
|
||||
import SourceSyntax.Declaration (Assoc)
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Helpers as Help
|
||||
import SourceSyntax.PrettyPrint
|
||||
import SourceSyntax.Variable as Variable
|
||||
|
||||
reserveds = [ "if", "then", "else"
|
||||
, "case", "of"
|
||||
|
@ -168,7 +169,8 @@ betwixt a b c = do char a ; out <- c
|
|||
char b <?> "closing '" ++ [b] ++ "'" ; return out
|
||||
|
||||
surround a z name p = do
|
||||
char a ; v <- padded p
|
||||
char a
|
||||
v <- padded p
|
||||
char z <?> unwords ["closing", name, show z]
|
||||
return v
|
||||
|
||||
|
@ -181,10 +183,10 @@ parens = surround '(' ')' "paren"
|
|||
brackets :: IParser a -> IParser a
|
||||
brackets = surround '{' '}' "bracket"
|
||||
|
||||
addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
|
||||
addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
|
||||
addLocation expr = do
|
||||
(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 p = do
|
||||
|
@ -193,10 +195,10 @@ located p = do
|
|||
end <- getPosition
|
||||
return (start, e, end)
|
||||
|
||||
accessible :: IParser LParseExpr -> IParser LParseExpr
|
||||
accessible :: IParser ParseExpr -> IParser ParseExpr
|
||||
accessible expr = do
|
||||
start <- getPosition
|
||||
ce@(L _ e) <- expr
|
||||
ce@(A _ e) <- expr
|
||||
let rest f = do
|
||||
let dot = char '.' >> notFollowedBy (char '.')
|
||||
access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
|
||||
|
@ -205,10 +207,12 @@ accessible expr = do
|
|||
Just _ -> accessible $ do
|
||||
v <- var <?> "field access (e.g. List.map)"
|
||||
end <- getPosition
|
||||
return (Location.at start end (f v))
|
||||
case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
|
||||
| otherwise -> rest (Access ce)
|
||||
_ -> rest (Access ce)
|
||||
return (Annotation.at start end (f v))
|
||||
case e of
|
||||
Var (Variable.Raw (c:cs))
|
||||
| isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
|
||||
| otherwise -> rest (Access ce)
|
||||
_ -> rest (Access ce)
|
||||
|
||||
|
||||
spaces :: IParser String
|
||||
|
@ -268,7 +272,7 @@ ignoreUntil end = go
|
|||
ignore p = const () <$> p
|
||||
filler = choice [ try (ignore chr) <|> ignore str
|
||||
, ignore multiComment
|
||||
, ignore (markdown (\_ _ -> mzero))
|
||||
, ignore (markdown (\_ -> mzero))
|
||||
, ignore anyChar
|
||||
]
|
||||
go = choice [ Just <$> end
|
||||
|
@ -301,15 +305,15 @@ anyUntilPos pos = go
|
|||
True -> return []
|
||||
False -> (:) <$> anyChar <*> go
|
||||
|
||||
markdown :: (String -> [a] -> IParser (String, [a])) -> IParser (String, [a])
|
||||
markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []
|
||||
markdown :: ([a] -> IParser (String, [a])) -> IParser (String, [a])
|
||||
markdown interpolation = try (string "[markdown|") >> closeMarkdown (++ "") []
|
||||
where
|
||||
closeMarkdown md stuff =
|
||||
choice [ do try (string "|]")
|
||||
return (md, stuff)
|
||||
, uncurry closeMarkdown =<< interpolation md stuff
|
||||
return (md "", stuff)
|
||||
, (\(m,s) -> closeMarkdown (md . (m ++)) s) =<< interpolation stuff
|
||||
, do c <- anyChar
|
||||
closeMarkdown (md ++ [c]) stuff
|
||||
closeMarkdown (md . ([c]++)) stuff
|
||||
]
|
||||
|
||||
--str :: IParser String
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
|
||||
{-# OPTIONS_GHC -W #-}
|
||||
module Parse.Literal (literal) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
|
@ -7,16 +7,34 @@ import Parse.Helpers
|
|||
import SourceSyntax.Literal
|
||||
|
||||
literal :: IParser Literal
|
||||
literal = num <|> (Str <$> str) <|> (Chr <$> chr)
|
||||
literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"
|
||||
|
||||
num :: IParser Literal
|
||||
num = fmap toLit (preNum <?> "number")
|
||||
where toLit n | '.' `elem` n = FloatNum (read n)
|
||||
| otherwise = IntNum (read n)
|
||||
preNum = concat <$> sequence [ option "" minus, many1 digit, option "" postNum ]
|
||||
postNum = do try $ lookAhead (string "." >> digit)
|
||||
string "."
|
||||
('.':) <$> many1 digit
|
||||
minus = try $ do string "-"
|
||||
lookAhead digit
|
||||
return "-"
|
||||
num = toLit <$> (number <?> "number")
|
||||
where
|
||||
toLit n
|
||||
| any (`elem` ".eE") n = FloatNum (read n)
|
||||
| otherwise = IntNum (read n)
|
||||
|
||||
number = concat <$> sequence
|
||||
[ option "" minus
|
||||
, many1 digit
|
||||
, option "" decimals
|
||||
, option "" exponent ]
|
||||
|
||||
minus = try $ do
|
||||
string "-"
|
||||
lookAhead digit
|
||||
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)
|
||||
|
||||
varList :: IParser [String]
|
||||
varList = parens $ commaSep1 (var <|> parens symOp)
|
||||
varList = commaSep1 (var <|> parens symOp)
|
||||
|
||||
getModuleName :: String -> Maybe String
|
||||
getModuleName source =
|
||||
|
@ -27,7 +27,7 @@ moduleDef = do
|
|||
whitespace
|
||||
names <- dotSep1 capVar <?> "name of module"
|
||||
whitespace
|
||||
exports <- option [] varList
|
||||
exports <- option [] (parens varList)
|
||||
whitespace <?> "reserved word 'where'"
|
||||
reserved "where"
|
||||
return (names, exports)
|
||||
|
@ -38,17 +38,22 @@ imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
|
|||
import' :: IParser (String, ImportMethod)
|
||||
import' =
|
||||
do reserved "import"
|
||||
whitespace
|
||||
open <- optionMaybe (reserved "open")
|
||||
whitespace
|
||||
name <- intercalate "." <$> dotSep1 capVar
|
||||
case open of
|
||||
Just _ -> return (name, Hiding [])
|
||||
Nothing -> let how = try (whitespace >> (as' <|> importing'))
|
||||
in (,) name <$> option (As name) how
|
||||
(,) name <$> option (As name) method
|
||||
where
|
||||
method :: IParser ImportMethod
|
||||
method = try $ do whitespace
|
||||
as' <|> importing'
|
||||
|
||||
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' = 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 Data.Char (isUpper)
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.List as List
|
||||
import Text.Parsec hiding (newline,spaces,State)
|
||||
|
||||
import Parse.Helpers
|
||||
import Parse.Literal
|
||||
import SourceSyntax.Literal
|
||||
import SourceSyntax.Pattern hiding (tuple, list)
|
||||
import qualified SourceSyntax.Pattern as Pattern
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
|
||||
basic :: IParser Pattern
|
||||
basic :: IParser P.Pattern
|
||||
basic = choice
|
||||
[ char '_' >> return PAnything
|
||||
[ char '_' >> return P.Anything
|
||||
, do v <- var
|
||||
return $ case v of
|
||||
"True" -> PLiteral (Boolean True)
|
||||
"False" -> PLiteral (Boolean False)
|
||||
c:_ | isUpper c -> PData v []
|
||||
_ -> PVar v
|
||||
, PLiteral <$> literal
|
||||
"True" -> P.Literal (Boolean True)
|
||||
"False" -> P.Literal (Boolean False)
|
||||
c:_ | isUpper c -> P.Data v []
|
||||
_ -> P.Var v
|
||||
, P.Literal <$> literal
|
||||
]
|
||||
|
||||
asPattern :: Pattern -> IParser Pattern
|
||||
asPattern :: P.Pattern -> IParser P.Pattern
|
||||
asPattern pattern = do
|
||||
var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
|
||||
return $ case var of
|
||||
Just v -> PAlias v pattern
|
||||
Just v -> P.Alias v pattern
|
||||
Nothing -> pattern
|
||||
|
||||
record :: IParser Pattern
|
||||
record = PRecord <$> brackets (commaSep1 lowVar)
|
||||
record :: IParser P.Pattern
|
||||
record = P.Record <$> brackets (commaSep1 lowVar)
|
||||
|
||||
tuple :: IParser Pattern
|
||||
tuple = do ps <- parens (commaSep expr)
|
||||
return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
|
||||
tuple :: IParser P.Pattern
|
||||
tuple = do
|
||||
ps <- parens (commaSep expr)
|
||||
return $ case ps of
|
||||
[p] -> p
|
||||
_ -> P.tuple ps
|
||||
|
||||
list :: IParser Pattern
|
||||
list = Pattern.list <$> braces (commaSep expr)
|
||||
list :: IParser P.Pattern
|
||||
list = P.list <$> braces (commaSep expr)
|
||||
|
||||
term :: IParser Pattern
|
||||
term :: IParser P.Pattern
|
||||
term =
|
||||
(choice [ record, tuple, list, basic ]) <?> "pattern"
|
||||
|
||||
patternConstructor :: IParser Pattern
|
||||
patternConstructor :: IParser P.Pattern
|
||||
patternConstructor = do
|
||||
v <- intercalate "." <$> dotSep1 capVar
|
||||
v <- List.intercalate "." <$> dotSep1 capVar
|
||||
case v of
|
||||
"True" -> return $ PLiteral (Boolean True)
|
||||
"False" -> return $ PLiteral (Boolean False)
|
||||
_ -> PData v <$> spacePrefix term
|
||||
"True" -> return $ P.Literal (Boolean True)
|
||||
"False" -> return $ P.Literal (Boolean False)
|
||||
_ -> P.Data v <$> spacePrefix term
|
||||
|
||||
expr :: IParser Pattern
|
||||
expr :: IParser P.Pattern
|
||||
expr = do
|
||||
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
|
||||
= PPAnnotation String T.Type
|
||||
| PPDef String Expr.LParseExpr
|
||||
| PPDef String Expr.ParseExpr
|
||||
deriving (Show)
|
||||
|
||||
data Port
|
||||
= Out String Expr.LExpr T.Type
|
||||
= Out String Expr.Expr T.Type
|
||||
| In String T.Type
|
||||
deriving (Show)
|
||||
|
||||
|
|
|
@ -11,49 +11,54 @@ module SourceSyntax.Expression where
|
|||
import SourceSyntax.PrettyPrint
|
||||
import Text.PrettyPrint as P
|
||||
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.Type as SrcType
|
||||
import qualified SourceSyntax.Literal as Literal
|
||||
import qualified SourceSyntax.Variable as Variable
|
||||
|
||||
---- GENERAL AST ----
|
||||
|
||||
{-| This is a located expression, meaning it is tagged with info about where it
|
||||
came from in the source code. Expr' is defined in terms of LExpr' so that the
|
||||
location information does not need to be an extra field on every constructor.
|
||||
-}
|
||||
type LExpr' def = Location.Located (Expr' def)
|
||||
|
||||
{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
|
||||
"type holes" that allow us to enrich the AST with additional information as we
|
||||
move through the compilation process. The type holes let us show these
|
||||
structural changes in the types. The only type hole right now is:
|
||||
move through the compilation process. The type holes are used to represent:
|
||||
|
||||
def: Parsing allows two kinds of definitions (type annotations or definitions),
|
||||
but later checks will see that they are well formed and combine them.
|
||||
ann: Annotations for arbitrary expressions. Allows you to add information
|
||||
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
|
||||
| Var String
|
||||
| Range (LExpr' def) (LExpr' def)
|
||||
| ExplicitList [LExpr' def]
|
||||
| Binop String (LExpr' def) (LExpr' def)
|
||||
| Lambda Pattern.Pattern (LExpr' def)
|
||||
| App (LExpr' def) (LExpr' def)
|
||||
| MultiIf [(LExpr' def,LExpr' def)]
|
||||
| Let [def] (LExpr' def)
|
||||
| Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
|
||||
| Data String [LExpr' def]
|
||||
| Access (LExpr' def) String
|
||||
| Remove (LExpr' def) String
|
||||
| Insert (LExpr' def) String (LExpr' def)
|
||||
| Modify (LExpr' def) [(String, LExpr' def)]
|
||||
| Record [(String, LExpr' def)]
|
||||
| Markdown String String [LExpr' def]
|
||||
| Var var
|
||||
| Range (GeneralExpr ann def var) (GeneralExpr ann def var)
|
||||
| ExplicitList [GeneralExpr ann def var]
|
||||
| Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
|
||||
| Lambda Pattern.Pattern (GeneralExpr ann def var)
|
||||
| App (GeneralExpr ann def var) (GeneralExpr ann def var)
|
||||
| MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
|
||||
| Let [def] (GeneralExpr ann def var)
|
||||
| Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
|
||||
| Data String [GeneralExpr ann def var]
|
||||
| Access (GeneralExpr ann def var) String
|
||||
| Remove (GeneralExpr ann def var) String
|
||||
| Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
|
||||
| Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
|
||||
| Record [(String, GeneralExpr ann def var)]
|
||||
| Markdown String String [GeneralExpr ann def var]
|
||||
-- for type checking and code gen only
|
||||
| PortIn String SrcType.Type
|
||||
| PortOut String SrcType.Type (LExpr' def)
|
||||
| PortOut String SrcType.Type (GeneralExpr ann def var)
|
||||
deriving (Show)
|
||||
|
||||
|
||||
---- SPECIALIZED ASTs ----
|
||||
|
@ -62,81 +67,100 @@ data Expr' def
|
|||
annotations and definitions, which is how they appear in source code and how
|
||||
they are parsed.
|
||||
-}
|
||||
type ParseExpr = Expr' ParseDef
|
||||
type LParseExpr = LExpr' ParseDef
|
||||
type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
|
||||
type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
|
||||
|
||||
data ParseDef
|
||||
= Def Pattern.Pattern LParseExpr
|
||||
= Def Pattern.Pattern ParseExpr
|
||||
| TypeAnnotation String SrcType.Type
|
||||
deriving (Show)
|
||||
deriving (Show)
|
||||
|
||||
{-| "Normal" expressions. When the compiler checks that type annotations and
|
||||
ports are all paired with definitions in the appropriate order, it collapses
|
||||
them into a Def that is easier to work with in later phases of compilation.
|
||||
-}
|
||||
type LExpr = LExpr' Def
|
||||
type Expr = Expr' Def
|
||||
type Expr = GeneralExpr Annotation.Region Def Variable.Raw
|
||||
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)
|
||||
|
||||
|
||||
|
||||
---- 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
|
||||
|
||||
delist :: LExpr' def -> [LExpr' def]
|
||||
delist (Location.L _ (Data "::" [h,t])) = h : delist t
|
||||
delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
|
||||
delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
|
||||
delist _ = []
|
||||
|
||||
saveEnvName :: String
|
||||
saveEnvName = "_save_the_environment!!!"
|
||||
|
||||
dummyLet :: Pretty def => [def] -> LExpr' def
|
||||
dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
|
||||
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
|
||||
show = render . pretty
|
||||
|
||||
instance Pretty def => Pretty (Expr' def) where
|
||||
instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
|
||||
pretty expr =
|
||||
case expr of
|
||||
Literal lit -> pretty lit
|
||||
Var x -> variable x
|
||||
|
||||
Var x -> pretty x
|
||||
|
||||
Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
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)
|
||||
|
||||
App _ _ -> P.hang func 2 (P.sep args)
|
||||
where func:args = map prettyParens (collectApps (Location.none expr))
|
||||
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
|
||||
where
|
||||
func:args = map prettyParens (collectApps (Annotation.A undefined expr))
|
||||
|
||||
MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
|
||||
where
|
||||
iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
|
||||
|
||||
Let defs e ->
|
||||
P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
|
||||
, P.text "in" <+> pretty e ]
|
||||
|
||||
Case e pats ->
|
||||
P.hang pexpr 2 (P.vcat (map pretty' pats))
|
||||
where
|
||||
pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
|
||||
pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
|
||||
|
||||
Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
|
||||
Data "[]" [] -> P.text "[]"
|
||||
Data name es
|
||||
| Help.isTuple name -> P.parens (commaCat (map pretty es))
|
||||
| otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
|
||||
|
||||
Access e x -> prettyParens e <> P.text "." <> variable x
|
||||
|
||||
Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
|
||||
Insert (Location.L _ (Remove e y)) x v ->
|
||||
P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.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 ->
|
||||
P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
|
||||
|
||||
|
@ -175,21 +199,23 @@ instance Pretty Def where
|
|||
Nothing -> P.empty
|
||||
Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
|
||||
|
||||
collectApps :: LExpr' def -> [LExpr' def]
|
||||
collectApps lexpr@(Location.L _ expr) =
|
||||
collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
|
||||
collectApps annExpr@(Annotation.A _ expr) =
|
||||
case expr of
|
||||
App a b -> collectApps a ++ [b]
|
||||
_ -> [lexpr]
|
||||
_ -> [annExpr]
|
||||
|
||||
collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
|
||||
collectLambdas lexpr@(Location.L _ expr) =
|
||||
collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
|
||||
collectLambdas lexpr@(Annotation.A _ expr) =
|
||||
case expr of
|
||||
Lambda pattern body -> (pattern : ps, body')
|
||||
where (ps, body') = collectLambdas body
|
||||
Lambda pattern body ->
|
||||
let (ps, body') = collectLambdas body
|
||||
in (pattern : ps, body')
|
||||
|
||||
_ -> ([], lexpr)
|
||||
|
||||
prettyParens :: (Pretty def) => LExpr' def -> Doc
|
||||
prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
|
||||
prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
|
||||
prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
|
||||
where
|
||||
needed =
|
||||
case expr of
|
||||
|
|
|
@ -3,6 +3,15 @@ module SourceSyntax.Helpers where
|
|||
|
||||
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 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
|
||||
|
||||
import Data.Binary
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Text.PrettyPrint as P
|
||||
|
||||
import SourceSyntax.Expression (LExpr)
|
||||
import SourceSyntax.Expression (Expr)
|
||||
import SourceSyntax.Declaration
|
||||
import SourceSyntax.PrettyPrint
|
||||
import SourceSyntax.Type
|
||||
|
||||
import qualified Elm.Internal.Version as Version
|
||||
|
@ -21,6 +24,33 @@ type Imports = [(String, ImportMethod)]
|
|||
data ImportMethod = As String | Importing [String] | Hiding [String]
|
||||
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
|
||||
put method =
|
||||
let put' n info = putWord8 n >> put info in
|
||||
|
@ -42,7 +72,7 @@ data MetadataModule =
|
|||
, path :: FilePath
|
||||
, exports :: [String]
|
||||
, imports :: [(String, ImportMethod)]
|
||||
, program :: LExpr
|
||||
, program :: Expr
|
||||
, types :: Map.Map String Type
|
||||
, fixities :: [(Assoc, Int, String)]
|
||||
, aliases :: [Alias]
|
||||
|
|
|
@ -7,50 +7,54 @@ import Text.PrettyPrint as PP
|
|||
import qualified Data.Set as Set
|
||||
import SourceSyntax.Literal as Literal
|
||||
|
||||
data Pattern = PData String [Pattern]
|
||||
| PRecord [String]
|
||||
| PAlias String Pattern
|
||||
| PVar String
|
||||
| PAnything
|
||||
| PLiteral Literal.Literal
|
||||
deriving (Eq, Ord, Show)
|
||||
data Pattern
|
||||
= Data String [Pattern]
|
||||
| Record [String]
|
||||
| Alias String Pattern
|
||||
| Var String
|
||||
| Anything
|
||||
| Literal Literal.Literal
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
cons :: Pattern -> Pattern -> Pattern
|
||||
cons h t = PData "::" [h,t]
|
||||
cons h t = Data "::" [h,t]
|
||||
|
||||
nil :: Pattern
|
||||
nil = PData "[]" []
|
||||
nil = Data "[]" []
|
||||
|
||||
list :: [Pattern] -> Pattern
|
||||
list = foldr cons nil
|
||||
|
||||
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 =
|
||||
case pattern of
|
||||
PVar x -> Set.singleton x
|
||||
PAlias x p -> Set.insert x (boundVars p)
|
||||
PData _ ps -> Set.unions (map boundVars ps)
|
||||
PRecord fields -> Set.fromList fields
|
||||
PAnything -> Set.empty
|
||||
PLiteral _ -> Set.empty
|
||||
Var x -> Set.singleton x
|
||||
Alias x p -> Set.insert x (boundVars p)
|
||||
Data _ ps -> Set.unions (map boundVars ps)
|
||||
Record fields -> Set.fromList fields
|
||||
Anything -> Set.empty
|
||||
Literal _ -> Set.empty
|
||||
|
||||
|
||||
instance Pretty Pattern where
|
||||
pretty pattern =
|
||||
case pattern of
|
||||
PVar x -> variable x
|
||||
PLiteral lit -> pretty lit
|
||||
PRecord fs -> PP.braces (commaCat $ map variable fs)
|
||||
PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
|
||||
PAnything -> PP.text "_"
|
||||
PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
|
||||
Var x -> variable x
|
||||
Literal lit -> pretty lit
|
||||
Record fs -> PP.braces (commaCat $ map variable fs)
|
||||
Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
|
||||
Anything -> PP.text "_"
|
||||
Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
|
||||
where isCons = case hd of
|
||||
PData "::" _ -> True
|
||||
Data "::" _ -> True
|
||||
_ -> False
|
||||
PData name ps ->
|
||||
Data name ps ->
|
||||
if Help.isTuple name then
|
||||
PP.parens . commaCat $ map pretty ps
|
||||
else hsep (PP.text name : map prettyParens ps)
|
||||
|
@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
|
|||
where
|
||||
needsThem =
|
||||
case pattern of
|
||||
PData name (_:_) | not (Help.isTuple name) -> True
|
||||
PAlias _ _ -> True
|
||||
Data name (_:_) | not (Help.isTuple name) -> True
|
||||
Alias _ _ -> True
|
||||
_ -> False
|
||||
|
|
|
@ -10,11 +10,16 @@ class Pretty a where
|
|||
instance Pretty () where
|
||||
pretty () = empty
|
||||
|
||||
renderPretty :: (Pretty a) => a -> String
|
||||
renderPretty e = render (pretty e)
|
||||
|
||||
commaCat docs = cat (punctuate comma docs)
|
||||
commaSep docs = sep (punctuate comma docs)
|
||||
|
||||
parensIf :: Bool -> Doc -> Doc
|
||||
parensIf bool doc = if bool then parens doc else doc
|
||||
|
||||
variable :: String -> Doc
|
||||
variable x =
|
||||
if Help.isOp x then parens (text x)
|
||||
else text (reprime x)
|
||||
|
|
|
@ -1,18 +1,18 @@
|
|||
{-# OPTIONS_GHC -W #-}
|
||||
module SourceSyntax.Type where
|
||||
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Data.Binary
|
||||
import qualified Data.Map as Map
|
||||
import qualified SourceSyntax.Helpers as Help
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import SourceSyntax.PrettyPrint
|
||||
import qualified SourceSyntax.Helpers as Help
|
||||
import Text.PrettyPrint as P
|
||||
|
||||
data Type = Lambda Type Type
|
||||
| Var String
|
||||
| Data String [Type]
|
||||
| Record [(String,Type)] (Maybe String)
|
||||
deriving (Eq)
|
||||
deriving (Eq,Show)
|
||||
|
||||
fieldMap :: [(String,a)] -> Map.Map String [a]
|
||||
fieldMap fields =
|
||||
|
@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
|
|||
tupleOf :: [Type] -> Type
|
||||
tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
|
||||
|
||||
instance Show Type where
|
||||
show = render . pretty
|
||||
|
||||
instance Pretty Type where
|
||||
pretty tipe =
|
||||
case tipe of
|
||||
|
|
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
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Applicative (Applicative,(<$>),(<*>))
|
||||
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.Set as Set
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Either as Either
|
||||
import SourceSyntax.Module
|
||||
import qualified Data.Traversable as T
|
||||
import SourceSyntax.Annotation as A
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Location as Loc
|
||||
import SourceSyntax.Module
|
||||
import SourceSyntax.PrettyPrint (pretty)
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import qualified SourceSyntax.Type as Type
|
||||
import qualified SourceSyntax.Variable as Var
|
||||
import Text.PrettyPrint as P
|
||||
|
||||
interface :: String -> ModuleInterface -> ModuleInterface
|
||||
|
@ -55,7 +57,9 @@ metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule
|
|||
metadataModule ifaces modul =
|
||||
do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of
|
||||
[] -> Right ()
|
||||
missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
|
||||
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)
|
||||
aliases' <- mapM (three3 renameType') (aliases 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 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 variable env v =
|
||||
|
@ -108,14 +111,18 @@ replace variable env v =
|
|||
msg = if null matches then "" else
|
||||
"\nClose matches include: " ++ List.intercalate ", " matches
|
||||
|
||||
rename :: Env -> LExpr -> Either [Doc] LExpr
|
||||
rename env (L s expr) =
|
||||
-- TODO: Var.Raw -> Var.Canonical
|
||||
rename :: Env -> Expr -> Either [Doc] Expr
|
||||
rename env (A ann expr) =
|
||||
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
|
||||
renameType' env = renameType (format . replace "variable" env)
|
||||
renameType' environ = renameType (format . replace "variable" environ)
|
||||
in
|
||||
L s <$>
|
||||
A ann <$>
|
||||
case expr of
|
||||
Literal _ -> return expr
|
||||
|
||||
|
@ -153,7 +160,8 @@ rename env (L s expr) =
|
|||
<*> rename env' body
|
||||
<*> 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
|
||||
|
||||
|
@ -174,10 +182,10 @@ rename env (L s expr) =
|
|||
renamePattern :: Env -> P.Pattern -> Either String P.Pattern
|
||||
renamePattern env pattern =
|
||||
case pattern of
|
||||
P.PVar _ -> return pattern
|
||||
P.PLiteral _ -> return pattern
|
||||
P.PRecord _ -> return pattern
|
||||
P.PAnything -> return pattern
|
||||
P.PAlias x p -> P.PAlias x <$> renamePattern env p
|
||||
P.PData name ps -> P.PData <$> replace "pattern" env name
|
||||
<*> mapM (renamePattern env) ps
|
||||
P.Var _ -> return pattern
|
||||
P.Literal _ -> return pattern
|
||||
P.Record _ -> return pattern
|
||||
P.Anything -> return pattern
|
||||
P.Alias x p -> P.Alias x <$> renamePattern env p
|
||||
P.Data name ps -> P.Data <$> replace "pattern" env name
|
||||
<*> mapM (renamePattern env) ps
|
||||
|
|
|
@ -32,7 +32,7 @@ dupErr err x =
|
|||
|
||||
duplicates :: [D.Declaration] -> [String]
|
||||
duplicates decls =
|
||||
map msg (dups (portNames ++ concatMap getNames defPatterns)) ++
|
||||
map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++
|
||||
case mapM exprDups (portExprs ++ defExprs) of
|
||||
Left name -> [msg name]
|
||||
Right _ -> []
|
||||
|
@ -50,14 +50,13 @@ duplicates decls =
|
|||
D.Out name expr _ -> (name, [expr])
|
||||
D.In name _ -> (name, [])
|
||||
|
||||
getNames = Set.toList . Pattern.boundVars
|
||||
|
||||
exprDups :: E.LExpr -> Either String E.LExpr
|
||||
exprDups :: E.Expr -> Either String E.Expr
|
||||
exprDups expr = Expr.crawlLet defsDups expr
|
||||
|
||||
defsDups :: [E.Def] -> Either String [E.Def]
|
||||
defsDups defs =
|
||||
case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of
|
||||
let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in
|
||||
case dups $ concatMap varsIn defs of
|
||||
[] -> Right defs
|
||||
name:_ -> Left name
|
||||
|
||||
|
|
|
@ -42,7 +42,7 @@ combineAnnotations = go
|
|||
|
||||
TypeAnnotation name tipe ->
|
||||
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
|
||||
let def' = E.Definition pat expr' (Just tipe)
|
||||
(:) (D.Definition def') <$> go rest
|
||||
|
|
|
@ -16,7 +16,7 @@ combineAnnotations = go
|
|||
|
||||
go defs =
|
||||
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
|
||||
let def = Definition pat expr' (Just tipe)
|
||||
(:) def <$> go rest
|
||||
|
|
|
@ -2,17 +2,19 @@
|
|||
module Transform.Expression (crawlLet, checkPorts) where
|
||||
|
||||
import Control.Applicative ((<$>),(<*>))
|
||||
import SourceSyntax.Annotation ( Annotated(A) )
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Location
|
||||
import qualified SourceSyntax.Type as ST
|
||||
import SourceSyntax.Type (Type)
|
||||
|
||||
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 ())
|
||||
|
||||
checkPorts :: (String -> ST.Type -> Either a ())
|
||||
-> (String -> ST.Type -> Either a ())
|
||||
-> LExpr
|
||||
-> Either a LExpr
|
||||
checkPorts :: (String -> Type -> Either a ())
|
||||
-> (String -> Type -> Either a ())
|
||||
-> Expr
|
||||
-> Either a Expr
|
||||
checkPorts inCheck outCheck expr =
|
||||
crawl inCheck outCheck (mapM checkDef) expr
|
||||
where
|
||||
|
@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =
|
|||
do _ <- checkPorts inCheck outCheck body
|
||||
return def
|
||||
|
||||
crawl :: (String -> ST.Type -> Either a ())
|
||||
-> (String -> ST.Type -> Either a ())
|
||||
crawl :: (String -> Type -> Either a ())
|
||||
-> (String -> Type -> Either a ())
|
||||
-> ([def] -> Either a [def'])
|
||||
-> LExpr' def
|
||||
-> Either a (LExpr' def')
|
||||
-> GeneralExpr ann def var
|
||||
-> Either a (GeneralExpr ann def' var)
|
||||
crawl portInCheck portOutCheck defsTransform = go
|
||||
where
|
||||
go (L srcSpan expr) =
|
||||
L srcSpan <$>
|
||||
go (A srcSpan expr) =
|
||||
A srcSpan <$>
|
||||
case expr of
|
||||
Var x -> return (Var x)
|
||||
Lambda p e -> Lambda p <$> go e
|
||||
|
|
|
@ -2,38 +2,43 @@
|
|||
module Transform.SafeNames (metadataModule) where
|
||||
|
||||
import Control.Arrow (first, (***))
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Location
|
||||
import SourceSyntax.Module
|
||||
import SourceSyntax.Pattern
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Set as Set
|
||||
|
||||
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 = dereserve . deprime
|
||||
var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
|
||||
where
|
||||
deprime = map (\c -> if c == '\'' then '$' else c)
|
||||
dereserve x = case Set.member x PHelp.jsReserveds of
|
||||
False -> x
|
||||
True -> "$" ++ x
|
||||
|
||||
pattern :: Pattern -> Pattern
|
||||
pattern :: P.Pattern -> P.Pattern
|
||||
pattern pat =
|
||||
case pat of
|
||||
PVar x -> PVar (var x)
|
||||
PLiteral _ -> pat
|
||||
PRecord fs -> PRecord (map var fs)
|
||||
PAnything -> pat
|
||||
PAlias x p -> PAlias (var x) (pattern p)
|
||||
PData name ps -> PData name (map pattern ps)
|
||||
P.Var x -> P.Var (var x)
|
||||
P.Literal _ -> pat
|
||||
P.Record fs -> P.Record (map var fs)
|
||||
P.Anything -> pat
|
||||
P.Alias x p -> P.Alias (var x) (pattern p)
|
||||
P.Data name ps -> P.Data name (map pattern ps)
|
||||
|
||||
expression :: LExpr -> LExpr
|
||||
expression (L loc expr) =
|
||||
-- TODO: should be "normal expression" -> "expression for JS generation"
|
||||
expression :: Expr -> Expr
|
||||
expression (A ann expr) =
|
||||
let f = expression in
|
||||
L loc $
|
||||
A ann $
|
||||
case expr of
|
||||
Literal _ -> expr
|
||||
Var x -> Var (var x)
|
||||
Var (Variable.Raw x) -> rawVar (var x)
|
||||
Range e1 e2 -> Range (f e1) (f e2)
|
||||
ExplicitList es -> ExplicitList (map f es)
|
||||
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.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.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
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 pattern =
|
||||
case pattern of
|
||||
P.PVar _ -> []
|
||||
P.PAlias _ p -> ctors p
|
||||
P.PData ctor ps -> ctor : concatMap ctors ps
|
||||
P.PRecord _ -> []
|
||||
P.PAnything -> []
|
||||
P.PLiteral _ -> []
|
||||
P.Var _ -> []
|
||||
P.Alias _ p -> ctors p
|
||||
P.Data ctor ps -> ctor : concatMap ctors ps
|
||||
P.Record _ -> []
|
||||
P.Anything -> []
|
||||
P.Literal _ -> []
|
||||
|
||||
free :: String -> State (Set.Set String) ()
|
||||
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 boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
|
||||
|
||||
sortDefs :: LExpr -> LExpr
|
||||
sortDefs :: Expr -> Expr
|
||||
sortDefs expr = evalState (reorder expr) Set.empty
|
||||
|
||||
reorder :: LExpr -> State (Set.Set String) LExpr
|
||||
reorder (L s expr) =
|
||||
L s <$>
|
||||
reorder :: Expr -> State (Set.Set String) Expr
|
||||
reorder (A ann expr) =
|
||||
A ann <$>
|
||||
case expr of
|
||||
-- Be careful adding and restricting freeVars
|
||||
Var x -> free x >> return expr
|
||||
Var (V.Raw x) -> free x >> return expr
|
||||
|
||||
Lambda p e ->
|
||||
uncurry Lambda <$> bindingReorder (p,e)
|
||||
|
@ -103,11 +104,11 @@ reorder (L s expr) =
|
|||
bound (P.boundVars 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'
|
||||
|
||||
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) =
|
||||
do expr' <- reorder expr
|
||||
bound (P.boundVars pattern)
|
||||
|
|
|
@ -2,14 +2,16 @@
|
|||
module Transform.Substitute (subst) where
|
||||
|
||||
import Control.Arrow (second, (***))
|
||||
import SourceSyntax.Expression
|
||||
import SourceSyntax.Location
|
||||
import qualified SourceSyntax.Pattern as Pattern
|
||||
import qualified Data.Set as Set
|
||||
|
||||
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 =
|
||||
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
|
||||
Range e1 e2 -> Range (f e1) (f e2)
|
||||
ExplicitList es -> ExplicitList (map f es)
|
||||
|
@ -28,7 +30,7 @@ subst old new expr =
|
|||
anyShadow =
|
||||
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
|
||||
Data name es -> Data name (map f es)
|
||||
Access e x -> Access (f e) x
|
||||
|
@ -39,4 +41,4 @@ subst old new expr =
|
|||
Literal _ -> expr
|
||||
Markdown uid md es -> Markdown uid md (map f es)
|
||||
PortIn name st -> PortIn name st
|
||||
PortOut name st signal -> PortOut name st (f signal)
|
||||
PortOut name st signal -> PortOut name st (f signal)
|
||||
|
|
|
@ -1,62 +1,62 @@
|
|||
{-# OPTIONS_GHC -Wall #-}
|
||||
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.Location as L
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import qualified SourceSyntax.Type as T
|
||||
|
||||
toExpr :: [Declaration] -> [E.Def]
|
||||
toExpr :: [D.Declaration] -> [E.Def]
|
||||
toExpr = concatMap toDefs
|
||||
|
||||
toDefs :: Declaration -> [E.Def]
|
||||
toDefs :: D.Declaration -> [E.Def]
|
||||
toDefs decl =
|
||||
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
|
||||
toDefs' (ctor, tipes) =
|
||||
let vars = take (length tipes) arguments
|
||||
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) ]
|
||||
|
||||
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) ]
|
||||
where
|
||||
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
|
||||
|
||||
efields = zip (map fst fields) (map var vars)
|
||||
record = case ext of
|
||||
Nothing -> L.none $ E.Record efields
|
||||
Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
|
||||
Nothing -> A.none $ E.Record 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,
|
||||
-- but they do not require any basic constraints.
|
||||
TypeAlias _ _ _ -> []
|
||||
D.TypeAlias _ _ _ -> []
|
||||
|
||||
Port port ->
|
||||
D.Port port ->
|
||||
case port of
|
||||
Out name expr@(L.L s _) tipe ->
|
||||
[ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
|
||||
In name tipe ->
|
||||
[ definition name (L.none $ E.PortIn name tipe) tipe ]
|
||||
D.Out name expr@(A.A s _) tipe ->
|
||||
[ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
|
||||
D.In name tipe ->
|
||||
[ definition name (A.none $ E.PortIn name tipe) tipe ]
|
||||
|
||||
-- no constraints are needed for fixity declarations
|
||||
Fixity _ _ _ -> []
|
||||
D.Fixity _ _ _ -> []
|
||||
|
||||
|
||||
arguments :: [String]
|
||||
arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
|
||||
|
||||
buildFunction :: E.LExpr -> [String] -> E.LExpr
|
||||
buildFunction body@(L.L s _) vars =
|
||||
foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
|
||||
buildFunction :: E.Expr -> [String] -> E.Expr
|
||||
buildFunction body@(A.A s _) 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 name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
|
||||
definition :: String -> E.Expr -> T.Type -> E.Def
|
||||
definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)
|
||||
|
|
|
@ -1,44 +1,45 @@
|
|||
{-# OPTIONS_GHC -W #-}
|
||||
module Type.Constrain.Expression where
|
||||
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Control.Applicative ((<$>))
|
||||
import qualified Control.Monad as Monad
|
||||
import Control.Monad.Error
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Text.PrettyPrint as PP
|
||||
|
||||
import SourceSyntax.Location as Loc
|
||||
import SourceSyntax.Pattern (Pattern(PVar), boundVars)
|
||||
import SourceSyntax.Annotation as Ann
|
||||
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.Fragment
|
||||
import qualified Type.Environment as Env
|
||||
import qualified Type.Constrain.Literal as Literal
|
||||
import qualified Type.Constrain.Pattern as Pattern
|
||||
|
||||
constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
|
||||
constrain env (L span expr) tipe =
|
||||
constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
|
||||
constrain env (A region expr) tipe =
|
||||
let list t = Env.get env Env.types "_List" <| t
|
||||
and = L span . CAnd
|
||||
true = L span CTrue
|
||||
t1 === t2 = L span (CEqual t1 t2)
|
||||
x <? t = L span (CInstance x t)
|
||||
clet schemes c = L span (CLet schemes c)
|
||||
and = A region . CAnd
|
||||
true = A region CTrue
|
||||
t1 === t2 = A region (CEqual t1 t2)
|
||||
x <? t = A region (CInstance x t)
|
||||
clet schemes c = A region (CLet schemes c)
|
||||
in
|
||||
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)
|
||||
| otherwise -> return (name <? tipe)
|
||||
Var (V.Raw name)
|
||||
| name == saveEnvName -> return (A region CSaveEnv)
|
||||
| otherwise -> return (name <? tipe)
|
||||
|
||||
Range lo hi ->
|
||||
exists $ \x -> do
|
||||
clo <- constrain env lo x
|
||||
chi <- constrain env hi x
|
||||
return $ and [clo, chi, list x === tipe]
|
||||
existsNumber $ \n -> do
|
||||
clo <- constrain env lo n
|
||||
chi <- constrain env hi n
|
||||
return $ and [clo, chi, list n === tipe]
|
||||
|
||||
ExplicitList exprs ->
|
||||
exists $ \x -> do
|
||||
|
@ -55,7 +56,7 @@ constrain env (L span expr) tipe =
|
|||
Lambda p e ->
|
||||
exists $ \t1 ->
|
||||
exists $ \t2 -> do
|
||||
fragment <- try span $ Pattern.constrain env p t1
|
||||
fragment <- try region $ Pattern.constrain env p t1
|
||||
c2 <- constrain env e t2
|
||||
let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
|
||||
(typeConstraint fragment /\ c2 ))
|
||||
|
@ -79,7 +80,7 @@ constrain env (L span expr) tipe =
|
|||
exists $ \t -> do
|
||||
ce <- constrain env exp t
|
||||
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
|
||||
and . (:) ce <$> mapM branch branches
|
||||
|
||||
|
@ -112,11 +113,11 @@ constrain env (L span expr) tipe =
|
|||
Modify e fields ->
|
||||
exists $ \t -> do
|
||||
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)
|
||||
|
||||
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
|
||||
|
||||
cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
|
||||
|
@ -126,7 +127,7 @@ constrain env (L span expr) tipe =
|
|||
Record fields ->
|
||||
do vars <- forM fields $ \_ -> liftIO (var Flexible)
|
||||
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)
|
||||
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.
|
||||
-- Currently, qs is always [].
|
||||
case (pattern, maybeTipe) of
|
||||
(PVar name, Just tipe) -> do
|
||||
(P.Var name, Just tipe) -> do
|
||||
flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
|
||||
let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
|
||||
env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
|
||||
(vars, typ) <- Env.instantiateType env tipe Map.empty
|
||||
let scheme = Scheme { rigidQuantifiers = [],
|
||||
flexibleQuantifiers = flexiVars ++ vars,
|
||||
constraint = Loc.noneNoDocs CTrue,
|
||||
constraint = Ann.noneNoDocs CTrue,
|
||||
header = Map.singleton name typ }
|
||||
c <- constrain env' expr typ
|
||||
return ( scheme : schemes
|
||||
|
@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
|
|||
, c2
|
||||
, fl rigidVars c /\ c1 )
|
||||
|
||||
(PVar name, Nothing) -> do
|
||||
(P.Var name, Nothing) -> do
|
||||
v <- liftIO $ var Flexible
|
||||
let tipe = VarN v
|
||||
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)
|
||||
|
||||
expandPattern :: Def -> [Def]
|
||||
expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
|
||||
expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
|
||||
case pattern of
|
||||
PVar _ -> [def]
|
||||
_ -> Definition (PVar x) lexpr maybeType : map toDef vars
|
||||
P.Var _ -> [def]
|
||||
_ -> Definition (P.Var x) lexpr maybeType : map toDef vars
|
||||
where
|
||||
vars = Set.toList $ boundVars pattern
|
||||
vars = P.boundVarList pattern
|
||||
x = "$" ++ concat vars
|
||||
mkVar = L s . Var
|
||||
toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
|
||||
mkVar = A r . rawVar
|
||||
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 span computation = do
|
||||
try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
|
||||
try region computation = do
|
||||
result <- liftIO $ runErrorT computation
|
||||
case result of
|
||||
Left err -> throwError [err span]
|
||||
Left err -> throwError [err region]
|
||||
Right value -> return value
|
||||
|
|
|
@ -1,14 +1,15 @@
|
|||
{-# OPTIONS_GHC -W #-}
|
||||
module Type.Constrain.Literal where
|
||||
|
||||
import SourceSyntax.Annotation
|
||||
import SourceSyntax.Literal
|
||||
import SourceSyntax.Location
|
||||
import Type.Type
|
||||
import Type.Environment as Env
|
||||
|
||||
constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
|
||||
constrain env span literal tipe =
|
||||
constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
|
||||
constrain env region literal tipe =
|
||||
do tipe' <- litType
|
||||
return . L span $ CEqual tipe tipe'
|
||||
return . A region $ CEqual tipe tipe'
|
||||
where
|
||||
prim name = return (Env.get env Env.types name)
|
||||
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
{-# OPTIONS_GHC -W #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Type.Constrain.Pattern where
|
||||
|
||||
|
@ -8,31 +9,29 @@ import Control.Monad.Error
|
|||
import qualified Data.Map as Map
|
||||
import qualified Text.PrettyPrint as PP
|
||||
|
||||
import SourceSyntax.Pattern
|
||||
import SourceSyntax.Location
|
||||
import SourceSyntax.PrettyPrint
|
||||
import Text.PrettyPrint (render)
|
||||
import qualified SourceSyntax.Location as Loc
|
||||
import qualified SourceSyntax.Annotation as A
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import SourceSyntax.PrettyPrint (pretty)
|
||||
import Type.Type
|
||||
import Type.Fragment
|
||||
import Type.Environment as Env
|
||||
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 =
|
||||
let span = Loc.NoSpan (render $ pretty pattern)
|
||||
t1 === t2 = Loc.L span (CEqual t1 t2)
|
||||
x <? t = Loc.L span (CInstance x t)
|
||||
let region = A.None (pretty pattern)
|
||||
t1 === t2 = A.A region (CEqual t1 t2)
|
||||
x <? t = A.A region (CInstance x t)
|
||||
in
|
||||
case pattern of
|
||||
PAnything -> return emptyFragment
|
||||
P.Anything -> return emptyFragment
|
||||
|
||||
PLiteral lit -> do
|
||||
c <- liftIO $ Literal.constrain env span lit tipe
|
||||
P.Literal lit -> do
|
||||
c <- liftIO $ Literal.constrain env region lit tipe
|
||||
return $ emptyFragment { typeConstraint = c }
|
||||
|
||||
PVar name -> do
|
||||
P.Var name -> do
|
||||
v <- liftIO $ var Flexible
|
||||
return $ Fragment {
|
||||
typeEnv = Map.singleton name (VarN v),
|
||||
|
@ -40,14 +39,14 @@ constrain env pattern tipe =
|
|||
typeConstraint = VarN v === tipe
|
||||
}
|
||||
|
||||
PAlias name p -> do
|
||||
P.Alias name p -> do
|
||||
fragment <- constrain env p tipe
|
||||
return $ fragment {
|
||||
typeEnv = Map.insert name tipe (typeEnv fragment),
|
||||
typeConstraint = name <? tipe /\ typeConstraint fragment
|
||||
}
|
||||
|
||||
PData name patterns -> do
|
||||
P.Data name patterns -> do
|
||||
(kind, cvars, args, result) <- liftIO $ freshDataScheme env name
|
||||
let msg = concat [ "Constructor '", name, "' expects ", show kind
|
||||
, " argument", if kind == 1 then "" else "s"
|
||||
|
@ -63,7 +62,7 @@ constrain env pattern tipe =
|
|||
vars = cvars ++ vars fragment
|
||||
}
|
||||
|
||||
PRecord fields -> do
|
||||
P.Record fields -> do
|
||||
pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
|
||||
let tenv = Map.fromList (map (second VarN) pairs)
|
||||
c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
|
||||
|
@ -73,8 +72,8 @@ constrain env pattern tipe =
|
|||
typeConstraint = c
|
||||
}
|
||||
|
||||
instance Error (SrcSpan -> PP.Doc) where
|
||||
instance Error (A.Region -> PP.Doc) where
|
||||
noMsg _ = PP.empty
|
||||
strMsg str span =
|
||||
PP.vcat [ PP.text $ "Type error " ++ show span
|
||||
, PP.text str ]
|
||||
, PP.text str ]
|
||||
|
|
|
@ -1,32 +1,35 @@
|
|||
{-# 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
|
||||
-- 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.Monad.State
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Traversable as Traverse
|
||||
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.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 ]
|
||||
|
||||
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
|
||||
mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
|
||||
mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
|
||||
mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
|
||||
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 =
|
||||
case Map.lookup "main" env of
|
||||
Nothing -> Right env
|
||||
|
@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
|
|||
acceptable = [ "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)."
|
||||
, 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 " " ]
|
||||
|
||||
data Direction = In | Out
|
||||
|
||||
portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
|
||||
portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
|
||||
portTypes rules expr =
|
||||
const () <$> Expr.checkPorts (check In) (check Out) expr
|
||||
where
|
||||
check = isValid True False False
|
||||
isValid isTopLevel seenFunc seenSignal direction name tipe =
|
||||
case tipe of
|
||||
T.Data ctor ts
|
||||
ST.Data ctor ts
|
||||
| isJs ctor || isElm ctor -> mapM_ valid ts
|
||||
| ctor == "Signal.Signal" -> handleSignal ts
|
||||
| otherwise -> err' True "an unsupported type"
|
||||
|
||||
T.Var _ -> err "free type variables"
|
||||
ST.Var _ -> err "free type variables"
|
||||
|
||||
T.Lambda _ _ ->
|
||||
ST.Lambda _ _ ->
|
||||
case direction of
|
||||
In -> err "functions"
|
||||
Out | seenFunc -> err "higher-order functions"
|
||||
| seenSignal -> err "signals that contain functions"
|
||||
| otherwise ->
|
||||
forM_ (T.collectLambdas tipe)
|
||||
forM_ (ST.collectLambdas tipe)
|
||||
(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
|
||||
|
||||
where
|
||||
|
@ -100,7 +103,7 @@ portTypes rules expr =
|
|||
[ txt [ "Type Error: the value ", dir "coming in" "sent out"
|
||||
, " through port '", name, "' is invalid." ]
|
||||
, txt [ "It contains ", kind, ":\n" ]
|
||||
, (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
|
||||
, (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
|
||||
, txt [ "Acceptable values for ", dir "incoming" "outgoing"
|
||||
, " ports include JavaScript values and" ]
|
||||
, txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
|
||||
|
@ -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)." ]
|
||||
]
|
||||
|
||||
occurs :: (String, Variable) -> StateT TS.SolverState IO ()
|
||||
occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
|
||||
occurs (name, variable) =
|
||||
do vars <- liftIO $ infiniteVars [] variable
|
||||
case vars of
|
||||
[] -> return ()
|
||||
var:_ -> do
|
||||
desc <- liftIO $ UF.descriptor var
|
||||
case structure desc of
|
||||
case TT.structure desc of
|
||||
Nothing ->
|
||||
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
|
||||
Just _ ->
|
||||
do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
|
||||
do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
|
||||
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
|
||||
msg = "Infinite types are not allowed"
|
||||
fallback _ = return $ P.text msg
|
||||
|
||||
infiniteVars :: [Variable] -> Variable -> IO [Variable]
|
||||
infiniteVars seen var =
|
||||
infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
|
||||
infiniteVars seen var =
|
||||
let go = infiniteVars (var:seen) in
|
||||
if var `elem` seen
|
||||
then return [var]
|
||||
else do
|
||||
desc <- UF.descriptor var
|
||||
case structure desc of
|
||||
case TT.structure desc of
|
||||
Nothing -> return []
|
||||
Just struct ->
|
||||
case struct of
|
||||
App1 a b -> (++) <$> go a <*> go b
|
||||
Fun1 a b -> (++) <$> go a <*> go b
|
||||
Var1 a -> go a
|
||||
EmptyRecord1 -> return []
|
||||
Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
|
||||
TT.App1 a b -> (++) <$> go a <*> go b
|
||||
TT.Fun1 a b -> (++) <$> go a <*> go b
|
||||
TT.Var1 a -> go a
|
||||
TT.EmptyRecord1 -> return []
|
||||
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 SourceSyntax.Pattern
|
||||
import SourceSyntax.Location (noneNoDocs)
|
||||
import SourceSyntax.Annotation (noneNoDocs)
|
||||
|
||||
data Fragment = Fragment {
|
||||
typeEnv :: Map.Map String Type,
|
||||
vars :: [Variable],
|
||||
typeConstraint :: TypeConstraint
|
||||
} deriving Show
|
||||
data Fragment = Fragment
|
||||
{ typeEnv :: Map.Map String Type
|
||||
, vars :: [Variable]
|
||||
, typeConstraint :: TypeConstraint
|
||||
} deriving Show
|
||||
|
||||
emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
|
||||
|
||||
joinFragment f1 f2 = Fragment {
|
||||
typeEnv = Map.union (typeEnv f1) (typeEnv f2),
|
||||
vars = vars f1 ++ vars f2,
|
||||
typeConstraint = typeConstraint f1 /\ typeConstraint f2
|
||||
}
|
||||
joinFragment f1 f2 = Fragment
|
||||
{ typeEnv = Map.union (typeEnv f1) (typeEnv f2)
|
||||
, vars = vars f1 ++ vars f2
|
||||
, typeConstraint = typeConstraint f1 /\ typeConstraint f2
|
||||
}
|
||||
|
||||
joinFragments = List.foldl' (flip joinFragment) emptyFragment
|
||||
|
||||
|
||||
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 SourceSyntax.Module as Module
|
||||
import SourceSyntax.Location (noneNoDocs)
|
||||
import SourceSyntax.Annotation (noneNoDocs)
|
||||
import SourceSyntax.Type (Type)
|
||||
import Text.PrettyPrint
|
||||
import qualified Type.State as TS
|
||||
|
|
|
@ -3,15 +3,15 @@ module Type.Solve (solve) where
|
|||
|
||||
import Control.Monad
|
||||
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.Traversable as Traversable
|
||||
import qualified Data.List as List
|
||||
import qualified Data.UnionFind.IO as UF
|
||||
import Type.Type
|
||||
import Type.Unify
|
||||
import qualified Type.ExtraChecks as Check
|
||||
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.
|
||||
|
@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
|
|||
|
||||
|
||||
solve :: TypeConstraint -> StateT TS.SolverState IO ()
|
||||
solve (L span constraint) =
|
||||
solve (A.A region constraint) =
|
||||
case constraint of
|
||||
CTrue -> return ()
|
||||
|
||||
|
@ -105,11 +105,11 @@ solve (L span constraint) =
|
|||
CEqual term1 term2 -> do
|
||||
t1 <- TS.flatten term1
|
||||
t2 <- TS.flatten term2
|
||||
unify span t1 t2
|
||||
unify region t1 t2
|
||||
|
||||
CAnd cs -> mapM_ solve cs
|
||||
|
||||
CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
|
||||
CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
|
||||
oldEnv <- TS.getEnv
|
||||
mapM TS.introduce fqs
|
||||
solve constraint'
|
||||
|
@ -117,7 +117,7 @@ solve (L span constraint) =
|
|||
|
||||
CLet schemes constraint' -> do
|
||||
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
|
||||
solve constraint'
|
||||
mapM Check.occurs $ Map.toList headers
|
||||
|
@ -134,10 +134,10 @@ solve (L span constraint) =
|
|||
error ("Could not find '" ++ name ++ "' when solving type constraints.")
|
||||
|
||||
t <- TS.flatten term
|
||||
unify span freshCopy t
|
||||
unify region freshCopy t
|
||||
|
||||
solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
|
||||
solveScheme span scheme =
|
||||
solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
|
||||
solveScheme region scheme =
|
||||
case scheme of
|
||||
Scheme [] [] constraint header -> do
|
||||
solve constraint
|
||||
|
@ -154,39 +154,39 @@ solveScheme span scheme =
|
|||
header' <- Traversable.traverse TS.flatten header
|
||||
solve constraint
|
||||
|
||||
allDistinct span rigidQuantifiers
|
||||
allDistinct region rigidQuantifiers
|
||||
youngPool <- TS.getPool
|
||||
TS.switchToPool oldPool
|
||||
generalize youngPool
|
||||
mapM (isGeneric span) rigidQuantifiers
|
||||
mapM (isGeneric region) rigidQuantifiers
|
||||
return header'
|
||||
|
||||
|
||||
-- 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
|
||||
-- a more complex term.
|
||||
allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
|
||||
allDistinct span vars = do
|
||||
allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
|
||||
allDistinct region vars = do
|
||||
seen <- TS.uniqueMark
|
||||
let check var = do
|
||||
desc <- liftIO $ UF.descriptor var
|
||||
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."
|
||||
|
||||
Nothing -> do
|
||||
if mark desc == seen
|
||||
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 ()
|
||||
liftIO $ UF.setDescriptor var (desc { mark = seen })
|
||||
mapM_ check vars
|
||||
|
||||
-- Check that a variable has rank == noRank, meaning that it can be generalized.
|
||||
isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
|
||||
isGeneric span var = do
|
||||
isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
|
||||
isGeneric region var = do
|
||||
desc <- liftIO $ UF.descriptor var
|
||||
if rank desc == noRank
|
||||
then return ()
|
||||
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 #-}
|
||||
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.Monad.State
|
||||
import qualified Data.Map as Map
|
||||
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.Location
|
||||
import Text.PrettyPrint as P
|
||||
import qualified Type.Alias as Alias
|
||||
import Type.Type
|
||||
|
||||
-- Pool
|
||||
-- Holds a bunch of variables
|
||||
|
@ -46,7 +47,7 @@ initialState = SS {
|
|||
modifyEnv f = modify $ \state -> state { sEnv = f (sEnv 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 }
|
||||
where
|
||||
makeError rules = do
|
||||
|
@ -54,24 +55,15 @@ addError span hint t1 t2 =
|
|||
t1' <- prettiest <$> toSrcType t1
|
||||
t2' <- prettiest <$> toSrcType t2
|
||||
return . P.vcat $
|
||||
[ P.text $ "Type error" ++ location ++ ":"
|
||||
[ P.text "Type error" <+> pretty region <> P.colon
|
||||
, 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 " 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)
|
||||
|
||||
getPool :: StateT SolverState IO Pool
|
||||
|
|
|
@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))
|
|||
import Control.Monad.State
|
||||
import Control.Monad.Error
|
||||
import Data.Traversable (traverse)
|
||||
import SourceSyntax.Location
|
||||
import SourceSyntax.Annotation
|
||||
import SourceSyntax.Helpers (isTuple)
|
||||
import qualified SourceSyntax.Type as Src
|
||||
|
||||
|
@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
|
|||
infixl 8 /\
|
||||
|
||||
(/\) :: 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
|
||||
(CTrue, _) -> b
|
||||
(_, CTrue) -> a
|
||||
|
@ -128,17 +128,24 @@ structuredVar structure = UF.fresh $ Descriptor {
|
|||
|
||||
-- ex qs constraint == exists qs. constraint
|
||||
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 :: [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 f = do
|
||||
v <- liftIO $ var Flexible
|
||||
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
|
||||
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)
|
||||
|
||||
|
||||
instance PrettyType a => PrettyType (Located a) where
|
||||
pretty when (L _ e) = pretty when e
|
||||
instance PrettyType t => PrettyType (Annotated a t) where
|
||||
pretty when (A _ e) = pretty when e
|
||||
|
||||
|
||||
instance PrettyType a => PrettyType (Term1 a) where
|
||||
|
@ -212,12 +219,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
|
|||
CAnd 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 ]
|
||||
where
|
||||
mergeExists vs (L _ c) =
|
||||
mergeExists vs (A _ c) =
|
||||
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)
|
||||
|
||||
(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
|
||||
|
||||
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' ]
|
||||
where
|
||||
prty = pretty Never
|
||||
|
@ -297,8 +304,8 @@ class Crawl t where
|
|||
-> t
|
||||
-> StateT CrawlState IO t
|
||||
|
||||
instance Crawl a => Crawl (Located a) where
|
||||
crawl nextState (L s e) = L s <$> crawl nextState e
|
||||
instance Crawl e => Crawl (Annotated a e) where
|
||||
crawl nextState (A ann e) = A ann <$> crawl nextState e
|
||||
|
||||
instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
|
||||
crawl nextState constraint =
|
||||
|
|
|
@ -1,27 +1,27 @@
|
|||
{-# OPTIONS_GHC -W #-}
|
||||
module Type.Unify (unify) where
|
||||
|
||||
import Type.Type
|
||||
import qualified Data.UnionFind.IO as UF
|
||||
import Control.Monad.State
|
||||
import qualified Data.Map as Map
|
||||
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 Control.Monad.State
|
||||
import SourceSyntax.Location
|
||||
import Type.Type
|
||||
import Type.PrettyPrint
|
||||
import Text.PrettyPrint (render)
|
||||
|
||||
unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
|
||||
unify span variable1 variable2 = do
|
||||
unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
|
||||
unify region variable1 variable2 = do
|
||||
equivalent <- liftIO $ UF.equivalent variable1 variable2
|
||||
if equivalent then return ()
|
||||
else actuallyUnify span variable1 variable2
|
||||
else actuallyUnify region variable1 variable2
|
||||
|
||||
actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
|
||||
actuallyUnify span variable1 variable2 = do
|
||||
actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
|
||||
actuallyUnify region variable1 variable2 = do
|
||||
desc1 <- liftIO $ UF.descriptor variable1
|
||||
desc2 <- liftIO $ UF.descriptor variable2
|
||||
let unify' = unify span
|
||||
let unify' = unify region
|
||||
|
||||
name' :: Maybe String
|
||||
name' = case (name desc1, name desc2) of
|
||||
|
@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
|
|||
|
||||
unifyNumber svar name
|
||||
| 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."
|
||||
|
||||
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."
|
||||
|
||||
unifyComparable var name
|
||||
|
@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
|
|||
List _ -> flexAndUnify varSuper
|
||||
_ -> comparableError Nothing
|
||||
|
||||
rigidError variable = TS.addError span (Just hint) variable1 variable2
|
||||
rigidError variable = TS.addError region (Just hint) variable1 variable2
|
||||
where
|
||||
var = "'" ++ render (pretty Never variable) ++ "'"
|
||||
hint = "Cannot unify rigid type variable " ++ var ++
|
||||
|
@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
|
|||
|
||||
(Rigid, _, _, _) -> rigidError variable1
|
||||
(_, Rigid, _, _) -> rigidError variable2
|
||||
_ -> TS.addError span Nothing variable1 variable2
|
||||
_ -> TS.addError region Nothing variable1 variable2
|
||||
|
||||
case (structure desc1, structure desc2) of
|
||||
(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 _ = 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
|
||||
@docs toPolar, fromPolar
|
||||
|
||||
# Floating Point Checks
|
||||
@docs isNaN, isInfinite
|
||||
|
||||
# Tuples
|
||||
@docs fst, snd
|
||||
|
||||
|
@ -271,6 +274,30 @@ ceiling = Native.Basics.ceiling
|
|||
toFloat : Int -> Float
|
||||
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
|
||||
|
||||
|
|
|
@ -5,7 +5,7 @@ module Date where
|
|||
issues with internationalization or locale formatting.
|
||||
|
||||
# Conversions
|
||||
@docs read, toTime
|
||||
@docs read, toTime, fromTime
|
||||
|
||||
# Extractions
|
||||
@docs year, month, Month, day, dayOfWeek, Day, hour, minute, second
|
||||
|
@ -36,6 +36,10 @@ read = Native.Date.read
|
|||
toTime : Date -> Time
|
||||
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
|
||||
this returns the integer `1990`. -}
|
||||
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 open Maybe
|
||||
import Basics (..)
|
||||
import Maybe (..)
|
||||
import Native.Error
|
||||
import List
|
||||
import String
|
||||
import Native.Utils
|
||||
|
||||
-- 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 msg c lgot rgot =
|
||||
Native.Error.raise . String.concat <| [
|
||||
Native.Error.raise <| List.concat [
|
||||
"Internal red-black tree invariant violated, expected ",
|
||||
msg,
|
||||
"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`.
|
||||
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 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 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 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 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 es = List.foldr consRight [] es
|
||||
|
||||
{-| Split into two lists, lefts on the left and rights on the right. So we
|
||||
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 es = List.foldr consEither ([],[]) es
|
||||
|
|
|
@ -30,7 +30,7 @@ it as a single unit.
|
|||
|
||||
-}
|
||||
|
||||
import open Basics
|
||||
import Basics (..)
|
||||
import List
|
||||
import Either (Either, Left, Right)
|
||||
import Transform2D (Transform2D, identity)
|
||||
|
|
|
@ -37,12 +37,12 @@ If you need more precision, you can create custom positions.
|
|||
midRightAt, topLeftAt, topRightAt, bottomLeftAt, bottomRightAt
|
||||
-}
|
||||
|
||||
import open Basics
|
||||
import Basics (..)
|
||||
import Native.Utils
|
||||
import JavaScript as JS
|
||||
import JavaScript (JSString)
|
||||
import List as List
|
||||
import open Color
|
||||
import Color (..)
|
||||
import Maybe (Maybe, Just, Nothing)
|
||||
|
||||
type Properties = {
|
||||
|
@ -53,7 +53,8 @@ type Properties = {
|
|||
color : Maybe Color,
|
||||
href : JSString,
|
||||
tag : JSString,
|
||||
hover : ()
|
||||
hover : (),
|
||||
click : ()
|
||||
}
|
||||
|
||||
type Element = { props : Properties, element : ElementPrim }
|
||||
|
@ -128,7 +129,9 @@ link href e = let p = e.props in
|
|||
|
||||
emptyStr = JS.fromString ""
|
||||
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
|
||||
= Image ImageStyle Int Int JSString
|
||||
|
|
|
@ -1,199 +1,178 @@
|
|||
module Graphics.Input where
|
||||
|
||||
{-| This module is for creating standard input widgets such as buttons and
|
||||
text boxes. In general, functions in this library return a signal representing
|
||||
events from the user.
|
||||
text fields. All functions in this library follow a general pattern in which
|
||||
you create an `Input` that many elements can report to:
|
||||
|
||||
The simplest inputs are *one-way inputs*, meaning the user can update
|
||||
them, but the programmer cannot. If you need to update an input from
|
||||
within the program you want the slightly more complex *two-way inputs*.
|
||||
This document will always show the one-way inputs first, *then* the
|
||||
two-way inputs.
|
||||
```haskell
|
||||
clicks : Input ()
|
||||
clicks = input ()
|
||||
|
||||
# Buttons
|
||||
@docs button, customButton, buttons, customButtons
|
||||
clickableYogi : Element
|
||||
clickableYogi = clickable clicks.handle () (image 40 40 "/yogi.jpg")
|
||||
```
|
||||
|
||||
# Fields
|
||||
@docs field, password, email, fields, FieldState, emptyFieldState
|
||||
Whenever the user clicks on the resulting `clickableYogi` element, it sends an
|
||||
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
|
||||
@docs checkbox, checkboxes
|
||||
# Creating Inputs
|
||||
@docs Input, input
|
||||
|
||||
# Drop Downs
|
||||
@docs stringDropDown, dropDown
|
||||
# Basic Input Elements
|
||||
|
||||
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,lift,dropRepeats)
|
||||
import Native.Graphics.Input
|
||||
import List
|
||||
import Signal (Signal)
|
||||
import Graphics.Element (Element)
|
||||
import Maybe (Maybe)
|
||||
import JavaScript (JSString)
|
||||
import Native.Graphics.Input
|
||||
|
||||
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.
|
||||
* 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.
|
||||
This will make more sense as you see more examples.
|
||||
-}
|
||||
buttons : a -> { events : Signal a,
|
||||
button : a -> String -> Element }
|
||||
buttons = Native.Graphics.Input.buttons
|
||||
type Input a = { signal : Signal a, handle : Handle a }
|
||||
|
||||
{-| Create a button with a given label. The result is an `Element` and
|
||||
a signal of units. This signal triggers whenever the button is pressed.
|
||||
data Handle a = Handle
|
||||
|
||||
{-| 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 ())
|
||||
button txt =
|
||||
let pool = buttons ()
|
||||
in (pool.button () txt, pool.events)
|
||||
input : a -> Input a
|
||||
input = Native.Graphics.Input.input
|
||||
|
||||
{-| 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.
|
||||
* The `events` signal represents all of the activity in this group
|
||||
of custom buttons.
|
||||
* The `customButton` function creates a button with three different visual
|
||||
states, one for up, hovering, and down. The resulting button has dimensions
|
||||
large enough to fit all three possible `Elements`.
|
||||
The `a` value is sent to `events` whenever the button is pressed.
|
||||
data Keys = Number Int | Plus | Minus | Clear
|
||||
|
||||
keys : Input Keys
|
||||
keys = input Clear
|
||||
|
||||
calculator : Element
|
||||
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,
|
||||
customButton : a -> Element -> Element -> Element -> Element }
|
||||
customButtons = Native.Graphics.Input.customButtons
|
||||
button : Handle a -> a -> String -> Element
|
||||
button = Native.Graphics.Input.button
|
||||
|
||||
{-| Create a button with custom states for up, hovering, and down
|
||||
(given in that order). The result is an `Element` and a signal of
|
||||
units. This signal triggers whenever the button is pressed.
|
||||
{-| Same as `button` but lets you customize buttons to look however you want.
|
||||
|
||||
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 up hover down =
|
||||
let pool = customButtons ()
|
||||
in (pool.customButton () up hover down, pool.events)
|
||||
customButton : Handle a -> a -> Element -> Element -> Element -> Element
|
||||
customButton = Native.Graphics.Input.customButton
|
||||
|
||||
{-| 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.
|
||||
* The `events` signal represents all of the activity in this group
|
||||
of checkboxes.
|
||||
* The `checkbox` function creates a
|
||||
checkbox with a given state. The `(Bool -> a)` function is used
|
||||
when the checkbox is modified. It 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 checkboxes.
|
||||
check : Input Bool
|
||||
check = input False
|
||||
|
||||
boxes : Bool -> Element
|
||||
boxes checked =
|
||||
let box = container 40 40 middle (checkbox check.handle id checked)
|
||||
in flow right [ box, box, box ]
|
||||
|
||||
main : Signal Element
|
||||
main = boxes <~ check.signal
|
||||
-}
|
||||
checkboxes : a -> { events : Signal a,
|
||||
checkbox : (Bool -> a) -> Bool -> Element }
|
||||
checkboxes = Native.Graphics.Input.checkboxes
|
||||
checkbox : Handle a -> (Bool -> a) -> Bool -> Element
|
||||
checkbox = Native.Graphics.Input.checkbox
|
||||
|
||||
{-| Create a checkbox with a given start state. Unlike `button`, this
|
||||
result is a *signal* of elements. That is because a checkbox has state
|
||||
that updates based on user input. The boolean signal represents the
|
||||
current state of the checkbox.
|
||||
{-| Create a drop-down menu. The following drop-down lets you choose your
|
||||
favorite British sport:
|
||||
|
||||
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)
|
||||
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 : Handle a -> [(String,a)] -> Element
|
||||
dropDown = Native.Graphics.Input.dropDown
|
||||
|
||||
{-| Create a drop-down menu for selecting strings. The resulting
|
||||
signal of strings represents the string that is currently selected.
|
||||
{-| Detect mouse hovers over a specific `Element`. In the following example,
|
||||
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)
|
||||
stringDropDown strs =
|
||||
dropDown (List.map (\s -> (s,s)) strs)
|
||||
hoverable : Handle a -> (Bool -> a) -> Element -> Element
|
||||
hoverable = Native.Graphics.Input.hoverable
|
||||
|
||||
{-| 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
|
||||
-}
|
||||
|
||||
import open Signal
|
||||
import Signal (..)
|
||||
import Native.Http
|
||||
|
||||
{-| 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 Maybe (Maybe)
|
||||
import JavaScript as JS
|
||||
|
|
|
@ -25,7 +25,7 @@ list must have the same type.
|
|||
@docs sort, sortBy, sortWith
|
||||
-}
|
||||
|
||||
import open Basics
|
||||
import Basics (..)
|
||||
import Native.List
|
||||
|
||||
{-| 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
|
||||
|
||||
{-| Apply a function to the contents of a `Maybe`.
|
||||
Return default when given `Nothing`.
|
||||
{-| Provide a default value and a function to extract the contents of a `Maybe`.
|
||||
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 f m = case m of
|
||||
Just v -> f v
|
||||
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 False (\_ -> True)
|
||||
|
||||
{-| Check if constructed with `Nothing`.
|
||||
|
||||
isNothing (Just 42) == False
|
||||
isNothing (Just []) == False
|
||||
isNothing Nothing == True
|
||||
-}
|
||||
isNothing : Maybe a -> Bool
|
||||
isNothing = not . isJust
|
||||
|
||||
cons : Maybe a -> [a] -> [a]
|
||||
cons mx xs = maybe xs (\x -> x :: xs) mx
|
||||
|
||||
{-| Filters out Nothings and extracts the remaining values.
|
||||
|
||||
justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]
|
||||
-}
|
||||
justs : [Maybe a] -> [a]
|
||||
justs = foldr cons []
|
||||
|
|
|
@ -7,7 +7,7 @@ module Mouse where
|
|||
@docs position, x, y
|
||||
|
||||
# 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 = 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. -}
|
||||
clicks : Signal ()
|
||||
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; }
|
||||
function xor(a,b) { return a !== b; }
|
||||
function not(b) { return !b; }
|
||||
function isInfinite(n) { return n === Infinity || n === -Infinity }
|
||||
|
||||
function truncate(n) { return n|0; }
|
||||
|
||||
|
@ -53,6 +54,8 @@ Elm.Native.Basics.make = function(elm) {
|
|||
floor:Math.floor,
|
||||
round:Math.round,
|
||||
toFloat:function(x) { return x; },
|
||||
isNaN:isNaN,
|
||||
isInfinite:isInfinite
|
||||
};
|
||||
|
||||
return elm.Native.Basics.values = basics;
|
||||
|
|
|
@ -13,13 +13,13 @@ Elm.Native.Bitwise.make = function(elm) {
|
|||
function srl(a,offset) { return a >>> offset; }
|
||||
|
||||
return elm.Native.Bitwise.values = {
|
||||
and: A2(and),
|
||||
or : A2(or ),
|
||||
xor: A2(xor),
|
||||
and: F2(and),
|
||||
or : F2(or ),
|
||||
xor: F2(xor),
|
||||
complement: not,
|
||||
shiftLeft : A2(sll),
|
||||
shiftRightArithmatic: A2(sra),
|
||||
shiftRightLogical : A2(srl),
|
||||
shiftLeft : F2(sll),
|
||||
shiftRightArithmatic: F2(sra),
|
||||
shiftRightLogical : F2(srl),
|
||||
};
|
||||
|
||||
};
|
||||
|
|
|
@ -6,6 +6,12 @@ Elm.Native.Color.make = function(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) {
|
||||
var hsv = toHSV(rgb);
|
||||
hsv.hue = (hsv.hue + 180) % 360;
|
||||
|
@ -63,7 +69,8 @@ Elm.Native.Color.make = function(elm) {
|
|||
return elm.Native.Color.values = {
|
||||
hsva:F4(hsva),
|
||||
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(); },
|
||||
second : function(d) { return d.getSeconds(); },
|
||||
toTime : function(d) { return d.getTime(); },
|
||||
fromTime: function(t) { return new window.Date(t); },
|
||||
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,303 +1,407 @@
|
|||
Elm.Native.Graphics.Input = {};
|
||||
Elm.Native.Graphics.Input.make = function(elm) {
|
||||
elm.Native = elm.Native || {};
|
||||
elm.Native.Graphics = elm.Native.Graphics || {};
|
||||
elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
|
||||
if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
|
||||
|
||||
elm.Native = elm.Native || {};
|
||||
elm.Native.Graphics = elm.Native.Graphics || {};
|
||||
elm.Native.Graphics.Input = elm.Native.Graphics.Input || {};
|
||||
if (elm.Native.Graphics.Input.values) return elm.Native.Graphics.Input.values;
|
||||
var Render = ElmRuntime.use(ElmRuntime.Render.Element);
|
||||
var newNode = ElmRuntime.use(ElmRuntime.Render.Utils).newElement;
|
||||
|
||||
var Render = ElmRuntime.use(ElmRuntime.Render.Element);
|
||||
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 newElement = Elm.Graphics.Element.make(elm).newElement;
|
||||
var JS = Elm.Native.JavaScript.make(elm);
|
||||
var Utils = Elm.Native.Utils.make(elm);
|
||||
var Tuple2 = Utils.Tuple2;
|
||||
|
||||
var Signal = Elm.Signal.make(elm);
|
||||
var newElement = Elm.Graphics.Element.make(elm).newElement;
|
||||
var JS = Elm.Native.JavaScript.make(elm);
|
||||
var Utils = Elm.Native.Utils.make(elm);
|
||||
var Tuple2 = Utils.Tuple2;
|
||||
function input(initialValue) {
|
||||
var signal = Signal.constant(initialValue);
|
||||
return { _:{}, signal:signal, handle:signal };
|
||||
}
|
||||
|
||||
function dropDown(values) {
|
||||
var entries = JS.fromList(values);
|
||||
var events = Signal.constant(entries[0]._1);
|
||||
function renderDropDown(signal, values) {
|
||||
return function(_) {
|
||||
var entries = JS.fromList(values);
|
||||
|
||||
var drop = newNode('select');
|
||||
drop.style.border = '0 solid';
|
||||
for (var i = 0; i < entries.length; ++i) {
|
||||
var option = newNode('option');
|
||||
var name = JS.fromString(entries[i]._0);
|
||||
option.value = name;
|
||||
option.innerHTML = name;
|
||||
drop.appendChild(option);
|
||||
}
|
||||
drop.addEventListener('change', function() {
|
||||
elm.notify(events.id, entries[drop.selectedIndex]._1);
|
||||
});
|
||||
var drop = newNode('select');
|
||||
drop.style.border = '0 solid';
|
||||
drop.style.pointerEvents = 'auto';
|
||||
for (var i = 0; i < entries.length; ++i) {
|
||||
var option = newNode('option');
|
||||
var name = JS.fromString(entries[i]._0);
|
||||
option.value = name;
|
||||
option.innerHTML = name;
|
||||
drop.appendChild(option);
|
||||
}
|
||||
drop.addEventListener('change', function() {
|
||||
elm.notify(signal.id, entries[drop.selectedIndex]._1);
|
||||
});
|
||||
|
||||
var t = drop.cloneNode(true);
|
||||
t.style.visibility = "hidden";
|
||||
var t = drop.cloneNode(true);
|
||||
t.style.visibility = "hidden";
|
||||
|
||||
elm.node.appendChild(t);
|
||||
var style = window.getComputedStyle(t, null);
|
||||
var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
|
||||
var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
|
||||
elm.node.removeChild(t);
|
||||
|
||||
var element = A3(newElement, w, h, {
|
||||
ctor: 'Custom',
|
||||
type: 'DropDown',
|
||||
render: function render(model) { return drop; },
|
||||
update: function update(node, oldModel, newModel) {},
|
||||
model: {}
|
||||
});
|
||||
elm.node.appendChild(t);
|
||||
var style = window.getComputedStyle(t, null);
|
||||
var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);
|
||||
var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);
|
||||
elm.node.removeChild(t);
|
||||
return drop;
|
||||
};
|
||||
}
|
||||
|
||||
return Tuple2(Signal.constant(element), events);
|
||||
}
|
||||
function updateDropDown(node, oldModel, newModel) {
|
||||
}
|
||||
|
||||
function buttons(defaultValue) {
|
||||
var events = Signal.constant(defaultValue);
|
||||
function dropDown(signal, values) {
|
||||
return A3(newElement, 100, 24, {
|
||||
ctor: 'Custom',
|
||||
type: 'DropDown',
|
||||
render: renderDropDown(signal,values),
|
||||
update: updateDropDown,
|
||||
model: {}
|
||||
});
|
||||
}
|
||||
|
||||
function render(model) {
|
||||
var b = newNode('button');
|
||||
b.style.display = 'block';
|
||||
b.elmEvent = model.event;
|
||||
function click() { elm.notify(events.id, b.elmEvent); }
|
||||
b.addEventListener('click', click);
|
||||
b.innerHTML = model.text;
|
||||
return b;
|
||||
}
|
||||
function renderButton(model) {
|
||||
var node = newNode('button');
|
||||
node.style.display = 'block';
|
||||
node.style.pointerEvents = 'auto';
|
||||
node.elm_signal = model.signal;
|
||||
node.elm_value = model.value;
|
||||
function click() {
|
||||
elm.notify(node.elm_signal.id, node.elm_value);
|
||||
}
|
||||
node.addEventListener('click', click);
|
||||
node.innerHTML = model.text;
|
||||
return node;
|
||||
}
|
||||
|
||||
function update(node, oldModel, newModel) {
|
||||
node.elmEvent = newModel.event;
|
||||
var txt = newModel.text;
|
||||
if (oldModel.text !== txt) node.innerHTML = txt;
|
||||
}
|
||||
function updateButton(node, oldModel, newModel) {
|
||||
node.elm_signal = newModel.signal;
|
||||
node.elm_value = newModel.value;
|
||||
var txt = newModel.text;
|
||||
if (oldModel.text !== txt) node.innerHTML = txt;
|
||||
}
|
||||
|
||||
function button(evnt, txt) {
|
||||
return A3(newElement, 100, 40, {
|
||||
ctor: 'Custom',
|
||||
type: 'Button',
|
||||
render: render,
|
||||
update: update,
|
||||
model: { event:evnt, text:JS.fromString(txt) }
|
||||
});
|
||||
}
|
||||
function button(signal, value, text) {
|
||||
return A3(newElement, 100, 40, {
|
||||
ctor: 'Custom',
|
||||
type: 'Button',
|
||||
render: renderButton,
|
||||
update: updateButton,
|
||||
model: { signal:signal, value:value, text:JS.fromString(text) }
|
||||
});
|
||||
}
|
||||
|
||||
return { _:{}, button:F2(button), events:events };
|
||||
}
|
||||
function renderCustomButton(model) {
|
||||
var btn = newNode('div');
|
||||
btn.style.pointerEvents = 'auto';
|
||||
btn.elm_signal = model.signal;
|
||||
btn.elm_value = model.value;
|
||||
|
||||
function customButtons(defaultValue) {
|
||||
var events = Signal.constant(defaultValue);
|
||||
btn.elm_up = Render.render(model.up);
|
||||
btn.elm_hover = Render.render(model.hover);
|
||||
btn.elm_down = Render.render(model.down);
|
||||
|
||||
function render(model) {
|
||||
var btn = newNode('div');
|
||||
btn.elmEvent = model.event;
|
||||
function replace(node) {
|
||||
if (node !== btn.firstChild) {
|
||||
btn.replaceChild(node, btn.firstChild);
|
||||
}
|
||||
}
|
||||
var overCount = 0;
|
||||
function over(e) {
|
||||
if (overCount++ > 0) return;
|
||||
replace(btn.elm_hover);
|
||||
}
|
||||
function out(e) {
|
||||
if (btn.contains(e.toElement || e.relatedTarget)) return;
|
||||
overCount = 0;
|
||||
replace(btn.elm_up);
|
||||
}
|
||||
function up() {
|
||||
replace(btn.elm_hover);
|
||||
elm.notify(btn.elm_signal.id, btn.elm_value);
|
||||
}
|
||||
function down() {
|
||||
replace(btn.elm_down);
|
||||
}
|
||||
btn.addEventListener('mouseover', over);
|
||||
btn.addEventListener('mouseout' , out);
|
||||
btn.addEventListener('mousedown', down);
|
||||
btn.addEventListener('mouseup' , up);
|
||||
|
||||
btn.elmUp = Render.render(model.up);
|
||||
btn.elmHover = Render.render(model.hover);
|
||||
btn.elmDown = Render.render(model.down);
|
||||
btn.appendChild(btn.elm_up);
|
||||
|
||||
function replace(node) {
|
||||
if (node !== btn.firstChild) btn.replaceChild(node, btn.firstChild);
|
||||
}
|
||||
var overCount = 0;
|
||||
function over(e) {
|
||||
if (overCount++ > 0) return;
|
||||
replace(btn.elmHover);
|
||||
}
|
||||
function out(e) {
|
||||
if (btn.contains(e.toElement || e.relatedTarget)) return;
|
||||
overCount = 0;
|
||||
replace(btn.elmUp);
|
||||
}
|
||||
function up() {
|
||||
replace(btn.elmHover);
|
||||
elm.notify(events.id, btn.elmEvent);
|
||||
}
|
||||
function down() { replace(btn.elmDown); }
|
||||
btn.addEventListener('mouseover', over);
|
||||
btn.addEventListener('mouseout' , out);
|
||||
btn.addEventListener('mousedown', down);
|
||||
btn.addEventListener('mouseup' , up);
|
||||
var clicker = newNode('div');
|
||||
clicker.style.width = btn.elm_up.style.width;
|
||||
clicker.style.height = btn.elm_up.style.height;
|
||||
clicker.style.position = 'absolute';
|
||||
clicker.style.top = 0;
|
||||
btn.appendChild(clicker);
|
||||
|
||||
btn.appendChild(btn.elmUp);
|
||||
return btn;
|
||||
}
|
||||
|
||||
var clicker = newNode('div');
|
||||
clicker.style.width = btn.elmUp.style.width;
|
||||
clicker.style.height = btn.elmUp.style.height;
|
||||
clicker.style.position = 'absolute';
|
||||
clicker.style.top = 0;
|
||||
btn.appendChild(clicker);
|
||||
function updateCustomButton(node, oldModel, newModel) {
|
||||
var signal = newModel.signal;
|
||||
node.elm_up.elm_signal = signal;
|
||||
node.elm_hover.elm_signal = signal;
|
||||
node.elm_down.elm_signal = signal;
|
||||
|
||||
return btn;
|
||||
}
|
||||
var value = newModel.value;
|
||||
node.elm_up.elm_value = value;
|
||||
node.elm_hover.elm_value = value;
|
||||
node.elm_down.elm_value = value;
|
||||
|
||||
function update(node, oldModel, newModel) {
|
||||
node.elmEvent = newModel.event;
|
||||
Render.update(node.elmUp, oldModel.up, newModel.up)
|
||||
Render.update(node.elmHover, oldModel.hover, newModel.hover)
|
||||
Render.update(node.elmDown, oldModel.down, newModel.down)
|
||||
}
|
||||
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) {
|
||||
return A3(newElement,
|
||||
Math.max(up.props.width, hover.props.width, down.props.width),
|
||||
Math.max(up.props.height, hover.props.height, down.props.height),
|
||||
{ ctor: 'Custom',
|
||||
type: 'CustomButton',
|
||||
render: render,
|
||||
update: update,
|
||||
model: { event:evnt, up:up, hover:hover, down:down }
|
||||
});
|
||||
}
|
||||
function max3(a,b,c) {
|
||||
var ab = a > b ? a : b;
|
||||
return ab > c ? ab : c;
|
||||
}
|
||||
|
||||
return { _:{}, customButton:F4(button), events:events };
|
||||
}
|
||||
function customButton(signal, value, up, hover, down) {
|
||||
return A3(newElement,
|
||||
max3(up.props.width, hover.props.width, down.props.width),
|
||||
max3(up.props.height, hover.props.height, down.props.height),
|
||||
{ ctor: 'Custom',
|
||||
type: 'CustomButton',
|
||||
render: renderCustomButton,
|
||||
update: updateCustomButton,
|
||||
model: { signal:signal, value:value, up:up, hover:hover, down:down }
|
||||
});
|
||||
}
|
||||
|
||||
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 hoverables(defaultValue) {
|
||||
var events = Signal.constant(defaultValue);
|
||||
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 updateCheckbox(node, oldModel, newModel) {
|
||||
node.elm_signal = newModel.signal;
|
||||
node.elm_handler = newModel.handler;
|
||||
node.checked = newModel.checked;
|
||||
return true;
|
||||
}
|
||||
|
||||
function checkbox(signal, handler, checked) {
|
||||
return A3(newElement, 13, 13, {
|
||||
ctor: 'Custom',
|
||||
type: 'CheckBox',
|
||||
render: renderCheckbox,
|
||||
update: updateCheckbox,
|
||||
model: { signal:signal, handler:handler, checked:checked }
|
||||
});
|
||||
}
|
||||
|
||||
function checkboxes(defaultValue) {
|
||||
var events = Signal.constant(defaultValue);
|
||||
function setRange(node, start, end, dir) {
|
||||
if (node.parentNode) {
|
||||
node.setSelectionRange(start, end, dir);
|
||||
} else {
|
||||
setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
|
||||
}
|
||||
}
|
||||
|
||||
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 updateIfNeeded(css, attribute, latestAttribute) {
|
||||
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));
|
||||
|
||||
function update(node, oldModel, newModel) {
|
||||
node.elmHandler = newModel.handler;
|
||||
node.checked = newModel.checked;
|
||||
return true;
|
||||
}
|
||||
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 box(handler, checked) {
|
||||
return A3(newElement, 13, 13, {
|
||||
ctor: 'Custom',
|
||||
type: 'CheckBox',
|
||||
render: render,
|
||||
update: update,
|
||||
model: { checked:checked, handler:handler }
|
||||
});
|
||||
}
|
||||
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));
|
||||
}
|
||||
|
||||
return { _:{}, checkbox:F2(box), events:events };
|
||||
}
|
||||
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 setRange(node, start, end, dir) {
|
||||
if (node.parentNode) {
|
||||
node.setSelectionRange(start, end, dir);
|
||||
} else {
|
||||
setTimeout(function(){node.setSelectionRange(start, end, dir);}, 0);
|
||||
}
|
||||
}
|
||||
function renderField(model) {
|
||||
var field = newNode('input');
|
||||
updateFieldStyle(field.style, model.style);
|
||||
field.style.borderStyle = 'solid';
|
||||
field.style.pointerEvents = 'auto';
|
||||
|
||||
function mkTextPool(type) { return function fields(defaultValue) {
|
||||
var events = Signal.constant(defaultValue);
|
||||
field.type = model.type;
|
||||
field.placeholder = JS.fromString(model.placeHolder);
|
||||
field.value = JS.fromString(model.content.string);
|
||||
|
||||
var state = null;
|
||||
field.elm_signal = model.signal;
|
||||
field.elm_handler = model.handler;
|
||||
field.elm_old_value = field.value;
|
||||
|
||||
function render(model) {
|
||||
var field = newNode('input');
|
||||
field.elmHandler = model.handler;
|
||||
function inputUpdate(event) {
|
||||
var curr = field.elm_old_value;
|
||||
var next = field.value;
|
||||
if (curr === next) {
|
||||
return;
|
||||
}
|
||||
|
||||
field.id = 'test';
|
||||
field.type = type;
|
||||
field.placeholder = JS.fromString(model.placeHolder);
|
||||
field.value = JS.fromString(model.state.string);
|
||||
setRange(field, model.state.selectionStart, model.state.selectionEnd, 'forward');
|
||||
field.style.border = 'none';
|
||||
state = model.state;
|
||||
var direction = field.selectionDirection === 'forward' ? 'Forward' : 'Backward';
|
||||
var start = field.selectionStart;
|
||||
var end = field.selectionEnd;
|
||||
field.value = field.elm_old_value;
|
||||
|
||||
function update() {
|
||||
var start = field.selectionStart,
|
||||
end = field.selectionEnd;
|
||||
if (field.selectionDirection === 'backward') {
|
||||
start = end;
|
||||
end = field.selectionStart;
|
||||
}
|
||||
state = { _:{},
|
||||
string:JS.toString(field.value),
|
||||
selectionStart:start,
|
||||
selectionEnd:end };
|
||||
elm.notify(events.id, field.elmHandler(state));
|
||||
}
|
||||
function mousedown() {
|
||||
update();
|
||||
elm.node.addEventListener('mouseup', mouseup);
|
||||
}
|
||||
function mouseup() {
|
||||
update();
|
||||
elm.node.removeEventListener('mouseup', mouseup)
|
||||
}
|
||||
field.addEventListener('keyup', update);
|
||||
field.addEventListener('mousedown', mousedown);
|
||||
elm.notify(field.elm_signal.id, field.elm_handler({
|
||||
_:{},
|
||||
string: JS.toString(next),
|
||||
selection: {
|
||||
_:{},
|
||||
start: start,
|
||||
end: end,
|
||||
direction: { ctor: direction }
|
||||
},
|
||||
}));
|
||||
}
|
||||
|
||||
return field;
|
||||
}
|
||||
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);
|
||||
}
|
||||
function mouseup(event) {
|
||||
mouseUpdate(event);
|
||||
elm.node.removeEventListener('mouseup', mouseup)
|
||||
}
|
||||
field.addEventListener('input', inputUpdate);
|
||||
field.addEventListener('mousedown', mousedown);
|
||||
field.addEventListener('focus', function() {
|
||||
field.elm_hasFocus = true;
|
||||
});
|
||||
field.addEventListener('blur', function() {
|
||||
field.elm_hasFocus = false;
|
||||
});
|
||||
|
||||
function update(node, oldModel, newModel) {
|
||||
node.elmHandler = newModel.handler;
|
||||
if (state === newModel.state) return;
|
||||
var newStr = JS.fromString(newModel.state.string);
|
||||
if (node.value !== newStr) node.value = newStr;
|
||||
return field;
|
||||
}
|
||||
|
||||
var start = newModel.state.selectionStart;
|
||||
var end = newModel.state.selectionEnd;
|
||||
var direction = 'forward';
|
||||
if (end < start) {
|
||||
start = end;
|
||||
end = newModel.state.selectionStart;
|
||||
direction = 'backward';
|
||||
}
|
||||
|
||||
if (node.selectionStart !== start
|
||||
|| node.selectionEnd !== end
|
||||
|| node.selectionDirection !== direction) {
|
||||
setRange(node, start, end, direction);
|
||||
}
|
||||
}
|
||||
function updateField(field, oldModel, newModel) {
|
||||
if (oldModel.style !== newModel.style) {
|
||||
updateFieldStyle(field.style, newModel.style);
|
||||
}
|
||||
field.elm_signal = newModel.signal;
|
||||
field.elm_handler = newModel.handler;
|
||||
|
||||
function field(handler, placeHolder, state) {
|
||||
return A3(newElement, 200, 30,
|
||||
{ ctor: 'Custom',
|
||||
type: type + 'Input',
|
||||
render: render,
|
||||
update: update,
|
||||
model: { handler:handler,
|
||||
placeHolder:placeHolder,
|
||||
state:state }
|
||||
});
|
||||
}
|
||||
field.type = newModel.type;
|
||||
field.placeholder = JS.fromString(newModel.placeHolder);
|
||||
var value = JS.fromString(newModel.content.string);
|
||||
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);
|
||||
}
|
||||
}
|
||||
|
||||
return { _:{}, field:F3(field), events:events };
|
||||
}
|
||||
}
|
||||
function mkField(type) {
|
||||
function field(style, signal, handler, placeHolder, content) {
|
||||
var padding = style.padding;
|
||||
var outline = style.outline.width;
|
||||
var adjustWidth = padding.left + padding.right + outline.left + outline.right;
|
||||
var adjustHeight = padding.top + padding.bottom + outline.top + outline.bottom;
|
||||
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,
|
||||
content:content,
|
||||
style:style,
|
||||
type:type
|
||||
}
|
||||
});
|
||||
}
|
||||
return F5(field);
|
||||
}
|
||||
|
||||
return elm.Native.Graphics.Input.values = {
|
||||
buttons:buttons,
|
||||
customButtons:customButtons,
|
||||
hoverables:hoverables,
|
||||
checkboxes:checkboxes,
|
||||
fields:mkTextPool('text'),
|
||||
emails:mkTextPool('email'),
|
||||
passwords:mkTextPool('password'),
|
||||
dropDown:dropDown
|
||||
};
|
||||
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 = {
|
||||
input:input,
|
||||
button:F3(button),
|
||||
customButton:F5(customButton),
|
||||
checkbox:F3(checkbox),
|
||||
dropDown:F2(dropDown),
|
||||
field:mkField('text'),
|
||||
email:mkField('email'),
|
||||
password:mkField('password'),
|
||||
hoverable:F3(hoverable),
|
||||
clickable:F3(clickable)
|
||||
};
|
||||
|
||||
};
|
||||
|
|
|
@ -15,18 +15,16 @@ Elm.Native.Regex.make = function(elm) {
|
|||
function caseInsensitive(re) {
|
||||
return new RegExp(re.source, 'gi');
|
||||
}
|
||||
function pattern(raw) {
|
||||
function regex(raw) {
|
||||
return new RegExp(raw, 'g');
|
||||
}
|
||||
|
||||
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) {
|
||||
n = n.ctor === "All" ? Infinity : n._0;
|
||||
var out = [];
|
||||
var number = 0;
|
||||
var string = JS.fromString(str);
|
||||
|
@ -51,10 +49,8 @@ Elm.Native.Regex.make = function(elm) {
|
|||
return JS.toList(out);
|
||||
}
|
||||
|
||||
function replaceAll(re, replacer, string) {
|
||||
return replace(Infinity, re, replacer, string);
|
||||
}
|
||||
function replace(n, re, replacer, string) {
|
||||
n = n.ctor === "All" ? Infinity : n._0;
|
||||
var count = 0;
|
||||
function jsReplacer(match) {
|
||||
if (count++ > n) return match;
|
||||
|
@ -77,10 +73,10 @@ Elm.Native.Regex.make = function(elm) {
|
|||
return string.replace(re, jsReplacer);
|
||||
}
|
||||
|
||||
function split(re, string) {
|
||||
return JS.toList(JS.fromString(string).split(re));
|
||||
}
|
||||
function splitN(n, re, str) {
|
||||
function split(n, re, str) {
|
||||
if (n === Infinity) {
|
||||
return JS.toList(JS.fromString(string).split(re));
|
||||
}
|
||||
var string = JS.fromString(str);
|
||||
var result;
|
||||
var out = [];
|
||||
|
@ -95,18 +91,13 @@ Elm.Native.Regex.make = function(elm) {
|
|||
}
|
||||
|
||||
return Elm.Native.Regex.values = {
|
||||
pattern: pattern,
|
||||
regex: regex,
|
||||
caseInsensitive: caseInsensitive,
|
||||
escape: escape,
|
||||
|
||||
contains: F2(contains),
|
||||
findAll: F2(findAll),
|
||||
find: F3(find),
|
||||
|
||||
replaceAll: F3(replaceAll),
|
||||
replace: F4(replace),
|
||||
|
||||
split: F2(split),
|
||||
splitN: F3(splitN),
|
||||
split: F3(split),
|
||||
};
|
||||
};
|
||||
};
|
||||
|
|
|
@ -6,10 +6,7 @@ Elm.Native.Show.make = function(elm) {
|
|||
|
||||
var NList = Elm.Native.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 Json = Elm.Json.make(elm);
|
||||
var Tuple2 = Elm.Native.Utils.make(elm).Tuple2;
|
||||
|
||||
var toString = function(v) {
|
||||
|
|
|
@ -1,61 +1,64 @@
|
|||
Elm.Native.Http = {};
|
||||
Elm.Native.Http.make = function(elm) {
|
||||
|
||||
elm.Native = elm.Native || {};
|
||||
elm.Native.Http = elm.Native.Http || {};
|
||||
if (elm.Native.Http.values) return elm.Native.Http.values;
|
||||
elm.Native = elm.Native || {};
|
||||
elm.Native.Http = elm.Native.Http || {};
|
||||
if (elm.Native.Http.values) return elm.Native.Http.values;
|
||||
|
||||
var JS = Elm.JavaScript.make(elm);
|
||||
var List = Elm.List.make(elm);
|
||||
var Signal = Elm.Signal.make(elm);
|
||||
|
||||
var JS = Elm.JavaScript.make(elm);
|
||||
var List = Elm.List.make(elm);
|
||||
var Signal = Elm.Signal.make(elm);
|
||||
|
||||
|
||||
function registerReq(queue,responses) { return function(req) {
|
||||
if (req.url.ctor !== '[]') { sendReq(queue,responses,req); }
|
||||
};
|
||||
}
|
||||
|
||||
function updateQueue(queue,responses) {
|
||||
if (queue.length > 0) {
|
||||
elm.notify(responses.id, queue[0].value);
|
||||
if (queue[0].value.ctor !== 'Waiting') {
|
||||
queue.shift();
|
||||
setTimeout(function() { updateQueue(queue,responses); }, 0);
|
||||
}
|
||||
function registerReq(queue,responses) {
|
||||
return function(req) {
|
||||
if (req.url.length > 0) {
|
||||
sendReq(queue,responses,req);
|
||||
}
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
function sendReq(queue,responses,req) {
|
||||
var response = { value: { ctor:'Waiting' } };
|
||||
queue.push(response);
|
||||
function updateQueue(queue,responses) {
|
||||
if (queue.length > 0) {
|
||||
elm.notify(responses.id, queue[0].value);
|
||||
if (queue[0].value.ctor !== 'Waiting') {
|
||||
queue.shift();
|
||||
setTimeout(function() { updateQueue(queue,responses); }, 0);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
var request = null;
|
||||
if (window.ActiveXObject) { request = new ActiveXObject("Microsoft.XMLHTTP"); }
|
||||
if (window.XMLHttpRequest) { request = new XMLHttpRequest(); }
|
||||
request.onreadystatechange = function(e) {
|
||||
if (request.readyState === 4) {
|
||||
response.value = (request.status >= 200 && request.status < 300 ?
|
||||
{ ctor:'Success', _0:JS.toString(request.responseText) } :
|
||||
{ ctor:'Failure', _0:request.status, _1:JS.toString(request.statusText) });
|
||||
setTimeout(function() { updateQueue(queue,responses); }, 0);
|
||||
}
|
||||
function sendReq(queue,responses,req) {
|
||||
var response = { value: { ctor:'Waiting' } };
|
||||
queue.push(response);
|
||||
|
||||
var request = (window.ActiveXObject
|
||||
? new ActiveXObject("Microsoft.XMLHTTP")
|
||||
: new XMLHttpRequest());
|
||||
|
||||
request.onreadystatechange = function(e) {
|
||||
if (request.readyState === 4) {
|
||||
response.value = (request.status >= 200 && request.status < 300 ?
|
||||
{ ctor:'Success', _0:JS.toString(request.responseText) } :
|
||||
{ ctor:'Failure', _0:request.status, _1:JS.toString(request.statusText) });
|
||||
setTimeout(function() { updateQueue(queue,responses); }, 0);
|
||||
}
|
||||
};
|
||||
request.open(JS.fromString(req.verb), JS.fromString(req.url), true);
|
||||
function setHeader(pair) {
|
||||
request.setRequestHeader( JS.fromString(pair._0), JS.fromString(pair._1) );
|
||||
}
|
||||
List.map(setHeader)(req.headers);
|
||||
request.send(JS.fromString(req.body));
|
||||
}
|
||||
|
||||
function send(requests) {
|
||||
var responses = Signal.constant(elm.Http.values.Waiting);
|
||||
var sender = A2( Signal.lift, registerReq([],responses), requests );
|
||||
function f(x) { return function(y) { return x; } }
|
||||
return A3( Signal.lift2, f, responses, sender );
|
||||
}
|
||||
|
||||
return elm.Native.Http.values = {
|
||||
send:send
|
||||
};
|
||||
request.open(JS.fromString(req.verb), JS.fromString(req.url), true);
|
||||
function setHeader(pair) {
|
||||
request.setRequestHeader( JS.fromString(pair._0), JS.fromString(pair._1) );
|
||||
}
|
||||
List.map(setHeader)(req.headers);
|
||||
request.send(JS.fromString(req.body));
|
||||
}
|
||||
|
||||
function send(requests) {
|
||||
var responses = Signal.constant(elm.Http.values.Waiting);
|
||||
var sender = A2( Signal.lift, registerReq([],responses), requests );
|
||||
function f(x) { return function(y) { return x; } }
|
||||
return A3( Signal.lift2, f, responses, sender );
|
||||
}
|
||||
|
||||
return elm.Native.Http.values = {send:send};
|
||||
|
||||
};
|
||||
|
|
|
@ -20,15 +20,12 @@ Elm.Native.Mouse.make = function(elm) {
|
|||
y.defaultNumberOfKids = 0;
|
||||
|
||||
var isDown = Signal.constant(false);
|
||||
var isClicked = Signal.constant(false);
|
||||
var clicks = Signal.constant(Utils.Tuple0);
|
||||
|
||||
var node = elm.display === ElmRuntime.Display.FULLSCREEN ? document : elm.node;
|
||||
|
||||
elm.addListener([isClicked.id, clicks.id], node, 'click', function click() {
|
||||
elm.notify(isClicked.id, true);
|
||||
elm.addListener([clicks.id], node, 'click', function click() {
|
||||
elm.notify(clicks.id, Utils.Tuple0);
|
||||
elm.notify(isClicked.id, false);
|
||||
});
|
||||
elm.addListener([isDown.id], node, 'mousedown', function down() {
|
||||
elm.notify(isDown.id, true);
|
||||
|
@ -44,8 +41,7 @@ Elm.Native.Mouse.make = function(elm) {
|
|||
position: position,
|
||||
x:x,
|
||||
y:y,
|
||||
isClicked: isClicked,
|
||||
isDown: isDown,
|
||||
clicks: clicks
|
||||
};
|
||||
};
|
||||
};
|
||||
|
|
|
@ -127,12 +127,6 @@ Elm.Native.Signal.make = function(elm) {
|
|||
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 update() { return Utils.Tuple2(Date.now(), a.value); }
|
||||
return new LiftN(update, [a]);
|
||||
|
@ -225,9 +219,6 @@ Elm.Native.Signal.make = function(elm) {
|
|||
keepIf : F3(function(pred,base,sig) {
|
||||
return new DropIf(function(x) {return !pred(x);},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);},
|
||||
sampleOn : F2(sampleOn),
|
||||
timestamp : timestamp
|
||||
|
|
|
@ -144,7 +144,8 @@ Elm.Native.String.make = function(elm) {
|
|||
return str.indexOf(sub) === 0;
|
||||
}
|
||||
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) {
|
||||
var subLen = sub.length;
|
||||
|
@ -248,4 +249,4 @@ Elm.Native.String.make = function(elm) {
|
|||
toList: toList,
|
||||
fromList: fromList,
|
||||
};
|
||||
};
|
||||
};
|
||||
|
|
|
@ -4,11 +4,10 @@ Elm.Native.Text.make = function(elm) {
|
|||
elm.Native.Text = elm.Native.Text || {};
|
||||
if (elm.Native.Text.values) return elm.Native.Text.values;
|
||||
|
||||
var JS = Elm.JavaScript.make(elm);
|
||||
var Utils = Elm.Native.Utils.make(elm);
|
||||
var Color = Elm.Native.Color.make(elm);
|
||||
var toCss = Elm.Native.Color.make(elm).toCss;
|
||||
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) {
|
||||
if (s.length == 0) { return s; }
|
||||
|
@ -51,13 +50,51 @@ Elm.Native.Text.make = function(elm) {
|
|||
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) {
|
||||
return { style: 'font-size:' + px + 'px;', text:text }
|
||||
}
|
||||
function typeface(name, text) {
|
||||
return { style: 'font-family:' + name + ';', text:text }
|
||||
function typeface(names, text) {
|
||||
return { style: 'font-family:' + toTypefaces(names) + ';', text:text }
|
||||
}
|
||||
function monospace(text) {
|
||||
return { style: 'font-family:monospace;', text:text }
|
||||
|
@ -71,25 +108,16 @@ Elm.Native.Text.make = function(elm) {
|
|||
function link(href, text) {
|
||||
return { href: toText(href), text:text };
|
||||
}
|
||||
function underline(text) {
|
||||
return { line: ' underline', text:text };
|
||||
}
|
||||
function overline(text) {
|
||||
return { line: ' overline', text:text };
|
||||
}
|
||||
function strikeThrough(text) {
|
||||
return { line: ' line-through', text:text };
|
||||
function line(line, text) {
|
||||
return { style: 'text-decoration:' + toLine(line) + ';', text:text };
|
||||
}
|
||||
|
||||
function color(c, text) {
|
||||
var color = (c._3 === 1)
|
||||
? ('rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')')
|
||||
: ('rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')');
|
||||
return { style: 'color:' + color + ';', text:text };
|
||||
function color(color, text) {
|
||||
return { style: 'color:' + toCss(color) + ';', text:text };
|
||||
}
|
||||
|
||||
function position(align) {
|
||||
function create(text) {
|
||||
function block(align) {
|
||||
return function(text) {
|
||||
var raw = {
|
||||
ctor :'RawHtml',
|
||||
html : Utils.makeText(text),
|
||||
|
@ -100,7 +128,6 @@ Elm.Native.Text.make = function(elm) {
|
|||
var pos = A2(Utils.htmlHeight, 0, raw);
|
||||
return A3(Element.newElement, pos._0, pos._1, raw);
|
||||
}
|
||||
return create;
|
||||
}
|
||||
|
||||
function markdown(text, guid) {
|
||||
|
@ -115,36 +142,25 @@ Elm.Native.Text.make = function(elm) {
|
|||
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 = {
|
||||
toText: toText,
|
||||
|
||||
height : F2(height),
|
||||
italic : italic,
|
||||
bold : bold,
|
||||
underline : underline,
|
||||
overline : overline,
|
||||
strikeThrough : strikeThrough,
|
||||
line : F2(line),
|
||||
monospace : monospace,
|
||||
typeface : F2(typeface),
|
||||
color : F2(color),
|
||||
link : F2(link),
|
||||
|
||||
justified : position('justify'),
|
||||
centered : position('center'),
|
||||
righted : position('right'),
|
||||
text : text,
|
||||
plainText : plainText,
|
||||
markdown : markdown,
|
||||
leftAligned : block('left'),
|
||||
rightAligned : block('right'),
|
||||
centered : block('center'),
|
||||
justified : block('justify'),
|
||||
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 (typeof x === "object") {
|
||||
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;
|
||||
}
|
||||
if (typeof x === 'function') {
|
||||
|
@ -76,14 +81,8 @@ Elm.Native.Utils.make = function(elm) {
|
|||
|
||||
function makeText(text) {
|
||||
var style = '';
|
||||
var line = '';
|
||||
var href = '';
|
||||
while (true) {
|
||||
if (text.line) {
|
||||
line += text.line;
|
||||
text = text.text;
|
||||
continue;
|
||||
}
|
||||
if (text.style) {
|
||||
style += text.style;
|
||||
text = text.text;
|
||||
|
@ -95,7 +94,6 @@ Elm.Native.Utils.make = function(elm) {
|
|||
continue;
|
||||
}
|
||||
if (href) text = '<a href="' + href + '">' + text + '</a>';
|
||||
if (line) style += 'text-decoration:' + line + ';';
|
||||
if (style) text = '<span style="' + style + '">' + text + '</span>';
|
||||
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).
|
||||
|
||||
# Create
|
||||
@docs pattern, caseInsensitive, escape
|
||||
@docs regex, escape, caseInsensitive
|
||||
|
||||
# Match
|
||||
@docs Match
|
||||
# Helpful Data Structures
|
||||
|
||||
# Find and Replace
|
||||
@docs contains, find, findAll, replace, replaceAll
|
||||
These data structures are needed to help define functions like [`find`](#find)
|
||||
and [`replace`](#replace).
|
||||
|
||||
# Split
|
||||
@docs split, splitN
|
||||
@docs HowMany, Match
|
||||
|
||||
# Use
|
||||
@docs contains, find, replace, split
|
||||
|
||||
-}
|
||||
|
||||
|
@ -21,31 +22,35 @@ import Native.Regex
|
|||
|
||||
data Regex = Regex
|
||||
|
||||
{-| Escape all special characters. So `pattern (escape "$$$")`
|
||||
will match exactly `"$$$"` even though `$` is a special character.
|
||||
{-| Escape strings to be regular expressions, making all special characters
|
||||
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 = 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).
|
||||
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
|
||||
pattern = Native.Regex.pattern
|
||||
regex : String -> Regex
|
||||
regex = Native.Regex.regex
|
||||
|
||||
|
||||
{-| Make a pattern case insensitive -}
|
||||
{-| Make a regex case insensitive -}
|
||||
caseInsensitive : Regex -> Regex
|
||||
caseInsensitive = Native.Regex.caseInsensitive
|
||||
|
||||
{-| Check to see if a Regex is contained in a string.
|
||||
|
||||
```haskell
|
||||
contains (pattern "123") "12345" == True
|
||||
contains (pattern "b+") "aabbcc" == True
|
||||
contains (regex "123") "12345" == True
|
||||
contains (regex "b+") "aabbcc" == True
|
||||
|
||||
contains (pattern "789") "12345" == False
|
||||
contains (pattern "z+") "aabbcc" == False
|
||||
contains (regex "789") "12345" == False
|
||||
contains (regex "z+") "aabbcc" == False
|
||||
```
|
||||
-}
|
||||
contains : Regex -> String -> Bool
|
||||
|
@ -55,79 +60,67 @@ contains = Native.Regex.contains
|
|||
Here are details on each field:
|
||||
|
||||
* `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).
|
||||
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.
|
||||
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.
|
||||
* `index` — the index of the match in the original string.
|
||||
* `number` — if you find many matches, you can think of each one
|
||||
as being labeled with a `number` starting at one. So the first time you
|
||||
find a match, that is match `number` one. Second time is match `number` two.
|
||||
This is useful when paired with `replaceAll` if replacement is dependent on how
|
||||
This is useful when paired with `replace All` if replacement is dependent on how
|
||||
many times a pattern has appeared before.
|
||||
-}
|
||||
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
|
||||
words = findAll (pattern "\\w+") "hello world"
|
||||
findTwoCommas = find (AtMost 2) (regex ",")
|
||||
|
||||
map .match words == ["hello","world"]
|
||||
map .index words == [0,6]
|
||||
-- map .index (findTwoCommas "a,b,c,d,e") == [1,3]
|
||||
-- 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 .submatches places == [ [Just "boat"], [Just "lake"] ]
|
||||
-- map .match places == ["on a boat", "in a lake"]
|
||||
-- map .submatches places == [ [Just "boat"], [Just "lake"] ]
|
||||
```
|
||||
-}
|
||||
findAll : 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 : HowMany -> Regex -> String -> [Match]
|
||||
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.
|
||||
|
||||
```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
|
||||
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 : HowMany -> Regex -> (Match -> String) -> String -> String
|
||||
replace = Native.Regex.replace
|
||||
|
||||
{-| Split a string, using the regex as the separator.
|
||||
|
||||
```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
|
||||
|
||||
{-| 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 List (foldr)
|
||||
|
||||
import Basics (fst, snd, not)
|
||||
import Native.Error
|
||||
import Maybe as M
|
||||
|
||||
data Signal a = Signal
|
||||
|
||||
{-| 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
|
||||
first signal is not true initially. -}
|
||||
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
|
||||
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
|
||||
signal is true initially. -}
|
||||
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.
|
||||
|
||||
|
|
|
@ -15,7 +15,7 @@ are enclosed in `"double quotes"`. Strings are *not* lists of characters.
|
|||
@docs contains, startsWith, endsWith, indexes, indices
|
||||
|
||||
# Conversions
|
||||
@docs toInt, toFloat, toList, fromList
|
||||
@docs show, toInt, toFloat, toList, fromList
|
||||
|
||||
# Formatting
|
||||
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
|
||||
-}
|
||||
|
||||
import Native.Show
|
||||
import Native.String
|
||||
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 = Native.String.isEmpty
|
||||
|
||||
|
@ -63,7 +68,11 @@ append = Native.String.append
|
|||
concat : [String] -> String
|
||||
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 = Native.String.length
|
||||
|
||||
|
@ -81,7 +90,10 @@ map = Native.String.map
|
|||
filter : (Char -> Bool) -> String -> String
|
||||
filter = Native.String.filter
|
||||
|
||||
{-| Reverse a string. `(reverse "stressed" == "desserts")` -}
|
||||
{-| Reverse a string.
|
||||
|
||||
reverse "stressed" == "desserts"
|
||||
-}
|
||||
reverse : String -> String
|
||||
reverse = Native.String.reverse
|
||||
|
||||
|
@ -103,6 +115,8 @@ foldr = Native.String.foldr
|
|||
|
||||
split "," "cat,dog,cow" == ["cat","dog","cow"]
|
||||
split "/" "home/evan/Desktop/" == ["home","evan","Desktop"]
|
||||
|
||||
Use `Regex.split` if you need something more flexible.
|
||||
-}
|
||||
split : String -> String -> [String]
|
||||
split = Native.String.split
|
||||
|
@ -115,7 +129,10 @@ split = Native.String.split
|
|||
join : String -> [String] -> String
|
||||
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 = Native.String.repeat
|
||||
|
||||
|
@ -231,7 +248,7 @@ any = Native.String.any
|
|||
|
||||
all isDigit "90210" == True
|
||||
all isDigit "R2-D2" == False
|
||||
any isDigit "heart" == False
|
||||
all isDigit "heart" == False
|
||||
-}
|
||||
all : (Char -> Bool) -> String -> Bool
|
||||
all = Native.String.all
|
||||
|
@ -241,6 +258,8 @@ all = Native.String.all
|
|||
contains "the" "theory" == True
|
||||
contains "hat" "theory" == False
|
||||
contains "THE" "theory" == False
|
||||
|
||||
Use `Regex.contains` if you need something more flexible.
|
||||
-}
|
||||
contains : String -> String -> Bool
|
||||
contains = Native.String.contains
|
||||
|
@ -274,6 +293,14 @@ indexes = Native.String.indexes
|
|||
indices : String -> String -> [Int]
|
||||
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.
|
||||
|
||||
toInt "123" == Just 123
|
||||
|
|
|
@ -1,99 +1,210 @@
|
|||
module Text where
|
||||
|
||||
{-| Functions for displaying text
|
||||
{-| A library for styling and displaying text. Whlie the `String` library
|
||||
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
|
||||
@docs toText
|
||||
|
||||
# Creating Elements
|
||||
@docs plainText, asText, text, centered, justified, righted
|
||||
|
||||
# Formatting
|
||||
@docs color, typeface, height, link
|
||||
Each of the following functions places `Text` into a box. The function you use
|
||||
determines the alignment of the text.
|
||||
|
||||
# Simple Formatting
|
||||
@docs monospace, bold, italic, underline, overline, strikeThrough
|
||||
@docs leftAligned, rightAligned, centered, justified
|
||||
|
||||
# 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 Color (Color)
|
||||
import Basics (..)
|
||||
import String
|
||||
import Color (Color, black)
|
||||
import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)
|
||||
import Maybe (Maybe)
|
||||
import Maybe (Maybe, Nothing)
|
||||
import JavaScript (JSString)
|
||||
import Native.Show
|
||||
import Native.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 = Native.Text.toText
|
||||
|
||||
{-| Set the typeface of some text. The first argument should be a comma
|
||||
separated listing of the desired typefaces:
|
||||
{-| Set the style of some text. For example, if you design a `Style` called
|
||||
`footerStyle` that is specifically for the bottom of your page, you could apply
|
||||
it to text like this:
|
||||
|
||||
"helvetica, arial, sans-serif"
|
||||
|
||||
Works the same as the CSS font-family property.
|
||||
style footerStyle (toText "the old prince / 2007")
|
||||
-}
|
||||
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
|
||||
|
||||
{-| 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 = 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 = 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 = Native.Text.height
|
||||
|
||||
{-| Set the color of a string. -}
|
||||
{-| Set the color of some text:
|
||||
|
||||
color red (toText "Red")
|
||||
-}
|
||||
color : Color -> Text -> Text
|
||||
color = Native.Text.color
|
||||
|
||||
{-| Make a string bold. -}
|
||||
{-| Make text bold:
|
||||
|
||||
toText "sometimes you want " ++ bold (toText "emphasis")
|
||||
-}
|
||||
bold : Text -> Text
|
||||
bold = Native.Text.bold
|
||||
|
||||
{-| Italicize a string. -}
|
||||
{-| Make text italic:
|
||||
|
||||
toText "make it " ++ italic (toText "important")
|
||||
-}
|
||||
italic : Text -> Text
|
||||
italic = Native.Text.italic
|
||||
|
||||
{-| Draw a line above a string. -}
|
||||
overline : Text -> Text
|
||||
overline = Native.Text.overline
|
||||
{-| Put lines on text:
|
||||
|
||||
{-| Underline a string. -}
|
||||
underline : Text -> Text
|
||||
underline = Native.Text.underline
|
||||
line Under (toText "underlined")
|
||||
line Over (toText "overlined")
|
||||
line Through (toText "strike out")
|
||||
-}
|
||||
line : Line -> Text -> Text
|
||||
line = Native.Text.line
|
||||
|
||||
{-| Draw a line through a string. -}
|
||||
strikeThrough : Text -> Text
|
||||
strikeThrough = Native.Text.strikeThrough
|
||||
{-| `Text` is aligned along the left side of the text block. This is sometimes
|
||||
known as *ragged right*.
|
||||
-}
|
||||
leftAligned : Text -> Element
|
||||
leftAligned = Native.Text.leftAligned
|
||||
|
||||
{-| Display justified, styled text. -}
|
||||
justified : Text -> Element
|
||||
justified = Native.Text.justified
|
||||
{-| `Text` is aligned along the right side of the text block. This is sometimes
|
||||
known as *ragged left*.
|
||||
-}
|
||||
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 = Native.Text.centered
|
||||
|
||||
{-| Display right justified, styled text. -}
|
||||
righted : Text -> Element
|
||||
righted = Native.Text.righted
|
||||
{-| `Text` is aligned along the left and right sides of the text block. Word
|
||||
spacing is adjusted to make this possible.
|
||||
-}
|
||||
justified : Text -> Element
|
||||
justified = Native.Text.justified
|
||||
|
||||
{-| Display styled text. -}
|
||||
text : Text -> Element
|
||||
text = Native.Text.text
|
||||
{-| Display a string with no styling:
|
||||
|
||||
{-| Display a plain string. -}
|
||||
plainText string = leftAligned (toText string)
|
||||
-}
|
||||
plainText : String -> Element
|
||||
plainText = Native.Text.plainText
|
||||
plainText str =
|
||||
leftAligned (toText str)
|
||||
|
||||
{-| for internal use only -}
|
||||
markdown : Element
|
||||
|
@ -102,9 +213,10 @@ markdown = Native.Text.markdown
|
|||
{-| Convert anything to its textual representation and make it displayable in
|
||||
the browser:
|
||||
|
||||
asText == text . monospace . show
|
||||
asText value = text (monospace (show value))
|
||||
|
||||
Excellent for debugging.
|
||||
-}
|
||||
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 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"
|
||||
, "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"
|
||||
, "repository": "http://github.com/evancz/Elm.git"
|
||||
, "elm-version": "0.11"
|
||||
, "elm-version": "0.12"
|
||||
, "dependencies": {}
|
||||
, "exposed-modules":
|
||||
[ "Basics"
|
||||
|
@ -11,11 +11,13 @@
|
|||
, "Char"
|
||||
, "Color"
|
||||
, "Date"
|
||||
, "Debug"
|
||||
, "Dict"
|
||||
, "Either"
|
||||
, "Graphics.Element"
|
||||
, "Graphics.Collage"
|
||||
, "Graphics.Input"
|
||||
, "Graphics.Input.Field"
|
||||
, "Http"
|
||||
, "JavaScript"
|
||||
, "JavaScript.Experimental"
|
||||
|
@ -32,6 +34,7 @@
|
|||
, "Text"
|
||||
, "Time"
|
||||
, "Touch"
|
||||
, "Trampoline"
|
||||
, "Transform2D"
|
||||
, "WebSocket"
|
||||
, "Window"
|
||||
|
|
|
@ -5,8 +5,8 @@
|
|||
// structure.
|
||||
ElmRuntime.swap = function(from, to) {
|
||||
function similar(nodeOld,nodeNew) {
|
||||
idOkay = nodeOld.id === nodeNew.id;
|
||||
lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
|
||||
var idOkay = nodeOld.id === nodeNew.id;
|
||||
var lengthOkay = nodeOld.kids.length === nodeNew.kids.length;
|
||||
return idOkay && lengthOkay;
|
||||
}
|
||||
function swap(nodeOld,nodeNew) {
|
||||
|
|
|
@ -91,7 +91,7 @@ function init(display, container, module, ports, moduleToReplace) {
|
|||
checkPorts(elm);
|
||||
} catch(e) {
|
||||
var directions = "<br/> Open the developer console for more details."
|
||||
Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');
|
||||
Module.main = Elm.Text.make(elm).leftAligned('<code>' + e.message + directions + '</code>');
|
||||
reportAnyErrors = function() { throw e; }
|
||||
}
|
||||
inputs = ElmRuntime.filterDeadInputs(inputs);
|
||||
|
|
|
@ -254,6 +254,7 @@ function makeCanvas(w,h) {
|
|||
function render(model) {
|
||||
var div = newElement('div');
|
||||
div.style.overflow = 'hidden';
|
||||
div.style.position = 'relative';
|
||||
update(div, model, model);
|
||||
return div;
|
||||
}
|
||||
|
|
|
@ -7,10 +7,16 @@ var newElement = Utils.newElement, extract = Utils.extract,
|
|||
addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,
|
||||
fromList = Utils.fromList, eq = Utils.eq;
|
||||
|
||||
function setProps(props, e) {
|
||||
e.style.width = (props.width |0) + 'px';
|
||||
e.style.height = (props.height|0) + 'px';
|
||||
if (props.opacity !== 1) { e.style.opacity = props.opacity; }
|
||||
function setProps(elem, e) {
|
||||
var props = elem.props;
|
||||
var element = elem.element;
|
||||
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') {
|
||||
e.style.backgroundColor = extract(props.color._0);
|
||||
}
|
||||
|
@ -28,15 +34,30 @@ function setProps(props, e) {
|
|||
e.appendChild(a);
|
||||
}
|
||||
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() {
|
||||
if (overCount++ > 0) return;
|
||||
props.hover(true);
|
||||
if (e.elm_hover_count++ > 0) return;
|
||||
var handler = e.elm_hover_handler;
|
||||
if (handler !== null) {
|
||||
handler(true);
|
||||
}
|
||||
});
|
||||
e.addEventListener('mouseout', function(evt) {
|
||||
if (e.contains(evt.toElement || evt.relatedTarget)) return;
|
||||
overCount = 0;
|
||||
props.hover(false);
|
||||
e.elm_hover_count = 0;
|
||||
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;
|
||||
|
@ -99,6 +120,8 @@ function goDown(e) { return e }
|
|||
function goRight(e) { e.style.styleFloat = e.style.cssFloat = "left"; return e; }
|
||||
function flowWith(f, array) {
|
||||
var container = newElement('div');
|
||||
if (f == goIn) container.style.pointerEvents = 'none';
|
||||
|
||||
for (var i = array.length; i--; ) {
|
||||
container.appendChild(f(render(array[i])));
|
||||
}
|
||||
|
@ -126,7 +149,12 @@ function toPos(pos) {
|
|||
|
||||
// must clear right, left, top, bottom, and transform
|
||||
// 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.margin = 'auto';
|
||||
var transform = '';
|
||||
|
@ -146,7 +174,7 @@ function setPos(pos,w,h,e) {
|
|||
|
||||
function container(pos,elem) {
|
||||
var e = render(elem);
|
||||
setPos(pos, elem.props.width, elem.props.height, e);
|
||||
setPos(pos, elem, e);
|
||||
var div = newElement('div');
|
||||
div.style.position = 'relative';
|
||||
div.style.overflow = 'hidden';
|
||||
|
@ -183,7 +211,7 @@ function rawHtml(elem) {
|
|||
return div;
|
||||
}
|
||||
|
||||
function render(elem) { return setProps(elem.props, makeElement(elem)); }
|
||||
function render(elem) { return setProps(elem, makeElement(elem)); }
|
||||
function makeElement(e) {
|
||||
var elem = e.element;
|
||||
switch(elem.ctor) {
|
||||
|
@ -209,7 +237,9 @@ function update(node, curr, next) {
|
|||
case "RawHtml":
|
||||
// only markdown blocks have guids, so this must be a text block
|
||||
if (nextE.guid === null) {
|
||||
node.innerHTML = nextE.html;
|
||||
if(currE.html.valueOf() !== nextE.html.valueOf()) {
|
||||
node.innerHTML = nextE.html;
|
||||
}
|
||||
break;
|
||||
}
|
||||
if (nextE.guid !== currE.guid) {
|
||||
|
@ -275,7 +305,7 @@ function update(node, curr, next) {
|
|||
break;
|
||||
case "Container":
|
||||
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;
|
||||
case "Custom":
|
||||
if (currE.type === nextE.type) {
|
||||
|
@ -289,10 +319,19 @@ function update(node, curr, next) {
|
|||
}
|
||||
|
||||
function updateProps(node, curr, next) {
|
||||
var props = next.props, currP = curr.props, e = node;
|
||||
if (props.width !== currP.width) e.style.width = (props.width |0) + 'px';
|
||||
if (props.height !== currP.height) e.style.height = (props.height|0) + 'px';
|
||||
if (props.opacity !== 1 && props.opacity !== currP.opacity) {
|
||||
var props = next.props;
|
||||
var currP = curr.props;
|
||||
var e = node;
|
||||
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;
|
||||
}
|
||||
var nextColor = (props.color.ctor === 'Just' ?
|
||||
|
@ -317,6 +356,20 @@ function updateProps(node, curr, next) {
|
|||
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 };
|
||||
|
|
|
@ -10,7 +10,7 @@ License-file: LICENSE
|
|||
|
||||
Author: Evan Czaplicki
|
||||
Maintainer: info@elm-lang.org
|
||||
Copyright: Copyright: (c) 2011-2013 Evan Czaplicki
|
||||
Copyright: Copyright: (c) 2011-2014 Evan Czaplicki
|
||||
|
||||
Category: Compiler, Language
|
||||
|
||||
|
|
|
@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)
|
|||
import Text.PrettyPrint as P
|
||||
|
||||
import SourceSyntax.Literal as Lit
|
||||
import SourceSyntax.Pattern as Pat
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import SourceSyntax.PrettyPrint (Pretty, pretty)
|
||||
import Parse.Helpers (IParser, iParse)
|
||||
import Parse.Literal (literal)
|
||||
|
@ -31,24 +31,25 @@ propertyTests =
|
|||
where
|
||||
-- This test was autogenerated from the Pattern test and should be
|
||||
-- left in all its ugly glory.
|
||||
longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')
|
||||
, Pat.PRecord [
|
||||
"q7yclkcm7k_ikstrczv_"
|
||||
, "wQRv6gKsvvkjw4b5F"
|
||||
,"c9'eFfhk9FTvsMnwF_D"
|
||||
,"yqxhEkHvRFwZ"
|
||||
,"o"
|
||||
,"nbUlCn3y3NnkVoxhW"
|
||||
,"iJ0MNy3KZ_lrs"
|
||||
,"ug"
|
||||
,"sHHsX"
|
||||
,"mRKs9d"
|
||||
,"o2KiCX5'ZRzHJfRi8" ]
|
||||
, Pat.PVar "su'BrrbPUK6I33Eq" ]
|
||||
longPat = P.Data "I" [ P.Literal (Lit.Chr '+')
|
||||
, P.Record
|
||||
[ "q7yclkcm7k_ikstrczv_"
|
||||
, "wQRv6gKsvvkjw4b5F"
|
||||
,"c9'eFfhk9FTvsMnwF_D"
|
||||
,"yqxhEkHvRFwZ"
|
||||
,"o"
|
||||
,"nbUlCn3y3NnkVoxhW"
|
||||
,"iJ0MNy3KZ_lrs"
|
||||
,"ug"
|
||||
,"sHHsX"
|
||||
,"mRKs9d"
|
||||
,"o2KiCX5'ZRzHJfRi8" ]
|
||||
, P.Var "su'BrrbPUK6I33Eq"
|
||||
]
|
||||
|
||||
prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool
|
||||
prop_parse_print p x =
|
||||
either (const False) (== x) . parse_print p $ x
|
||||
|
||||
parse_print :: (Pretty a) => IParser a -> a -> Either String a
|
||||
parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty
|
||||
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 Parse.Helpers (reserveds)
|
||||
|
||||
import SourceSyntax.Literal
|
||||
import SourceSyntax.Pattern
|
||||
import SourceSyntax.Type hiding (listOf)
|
||||
import qualified SourceSyntax.Literal as L
|
||||
import qualified SourceSyntax.Pattern as P
|
||||
import qualified SourceSyntax.Type as T
|
||||
|
||||
instance Arbitrary Literal where
|
||||
arbitrary = oneof [ IntNum <$> arbitrary
|
||||
, FloatNum <$> (arbitrary `suchThat` noE)
|
||||
, Chr <$> arbitrary
|
||||
-- This is too permissive
|
||||
, Str <$> arbitrary
|
||||
-- Booleans aren't actually source syntax
|
||||
-- , Boolean <$> arbitrary
|
||||
]
|
||||
shrink l = case l of
|
||||
IntNum n -> IntNum <$> shrink n
|
||||
FloatNum f -> FloatNum <$> (filter noE . shrink $ f)
|
||||
Chr c -> Chr <$> shrink c
|
||||
Str s -> Str <$> shrink s
|
||||
Boolean b -> Boolean <$> shrink b
|
||||
instance Arbitrary L.Literal where
|
||||
arbitrary =
|
||||
oneof
|
||||
[ L.IntNum <$> arbitrary
|
||||
, L.FloatNum <$> (arbitrary `suchThat` noE)
|
||||
, L.Chr <$> arbitrary
|
||||
-- This is too permissive
|
||||
, L.Str <$> arbitrary
|
||||
-- Booleans aren't actually source syntax
|
||||
-- , Boolean <$> arbitrary
|
||||
]
|
||||
|
||||
shrink lit =
|
||||
case lit of
|
||||
L.IntNum n -> L.IntNum <$> shrink n
|
||||
L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)
|
||||
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 = notElem 'e' . show
|
||||
|
||||
genVector :: Int -> (Int -> Gen a) -> Gen [a]
|
||||
genVector n generator = do
|
||||
len <- choose (0,n)
|
||||
let m = n `div` (len + 1)
|
||||
vectorOf len $ generator m
|
||||
|
||||
instance Arbitrary Pattern where
|
||||
instance Arbitrary P.Pattern where
|
||||
arbitrary = sized pat
|
||||
where pat :: Int -> Gen Pattern
|
||||
pat n = oneof [ pure PAnything
|
||||
, PVar <$> lowVar
|
||||
, PRecord <$> (listOf1 lowVar)
|
||||
, PLiteral <$> arbitrary
|
||||
, PAlias <$> lowVar <*> pat (n-1)
|
||||
, PData <$> capVar <*> sizedPats
|
||||
]
|
||||
where sizedPats = do
|
||||
len <- choose (0,n)
|
||||
let m = n `div` (len + 1)
|
||||
vectorOf len $ pat m
|
||||
where
|
||||
pat :: Int -> Gen P.Pattern
|
||||
pat n =
|
||||
oneof
|
||||
[ 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
|
||||
PAnything -> []
|
||||
PVar v -> PVar <$> shrinkWHead v
|
||||
PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)
|
||||
PLiteral l -> PLiteral <$> shrink l
|
||||
PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)
|
||||
PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)
|
||||
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 [] = error "Should be nonempty"
|
||||
shrinkWHead (x:xs) = (x:) <$> shrink xs
|
||||
|
||||
instance Arbitrary Type where
|
||||
instance Arbitrary T.Type where
|
||||
arbitrary = sized tipe
|
||||
where tipe :: Int -> Gen Type
|
||||
tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe
|
||||
, Var <$> lowVar
|
||||
, Data <$> capVar <*> depthTipes
|
||||
, Record <$> fields <*> pure Nothing
|
||||
, Record <$> fields1 <*> (Just <$> lowVar)
|
||||
]
|
||||
where depthTipe = choose (0,n) >>= tipe
|
||||
depthTipes = do
|
||||
len <- choose (0,n)
|
||||
let m = n `div` (len + 1)
|
||||
vectorOf len $ tipe m
|
||||
where
|
||||
tipe :: Int -> Gen T.Type
|
||||
tipe n =
|
||||
let depthTipe = tipe =<< choose (0,n)
|
||||
field = (,) <$> lowVar <*> depthTipe
|
||||
fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)
|
||||
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)
|
||||
]
|
||||
|
||||
field = (,) <$> lowVar <*> depthTipe
|
||||
fields = do
|
||||
len <- choose (0,n)
|
||||
let m = n `div` (len + 1)
|
||||
vectorOf len $ (,) <$> lowVar <*> tipe m
|
||||
fields1 = (:) <$> field <*> fields
|
||||
shrink tipe =
|
||||
case tipe of
|
||||
T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
|
||||
T.Var _ -> []
|
||||
T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)
|
||||
T.Record fs t -> map snd fs ++ record
|
||||
where
|
||||
record =
|
||||
case t of
|
||||
Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing
|
||||
Just _ ->
|
||||
do fields <- filter (not . null) $ shrinkList shrinkField fs
|
||||
return $ T.Record fields t
|
||||
|
||||
shrink tipe = case tipe of
|
||||
Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)
|
||||
Var _ -> []
|
||||
Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)
|
||||
Record fs t -> map snd fs ++ case t of
|
||||
Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing
|
||||
Just _ ->
|
||||
do
|
||||
fields <- filter (not . null) $ shrinkList shrinkField fs
|
||||
return $ Record fields t
|
||||
where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
|
||||
shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t
|
||||
|
||||
lowVar :: Gen String
|
||||
lowVar = notReserved $ (:) <$> lower <*> listOf varLetter
|
||||
where lower = elements ['a'..'z']
|
||||
where
|
||||
lower = elements ['a'..'z']
|
||||
|
||||
capVar :: Gen String
|
||||
capVar = notReserved $ (:) <$> upper <*> listOf varLetter
|
||||
where upper = elements ['A'..'Z']
|
||||
where
|
||||
upper = elements ['A'..'Z']
|
||||
|
||||
varLetter :: Gen Char
|
||||
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 g xs = g `suchThat` notAnX
|
||||
where notAnX = flip Set.notMember xset
|
||||
xset = Set.fromList xs
|
||||
where
|
||||
notAnX = flip Set.notMember xset
|
||||
xset = Set.fromList xs
|
||||
|
|
Loading…
Reference in a new issue