diff --git a/forml.cabal b/forml.cabal
--- a/forml.cabal
+++ b/forml.cabal
@@ -1,5 +1,5 @@
Name: forml
-Version: 0.1.2
+Version: 0.1.3
Synopsis: A statically typed, functional programming language
License: MIT
Author: Andrew Stein
@@ -37,9 +37,10 @@
bytestring >= 0.9.1 && <0.10,
parsec,
indents,
- containers,
+ containers == 0.4.2.1,
+ GraphSCC == 1.0.2,
pandoc,
- jmacro == 0.6.2,
+ jmacro,
MissingH,
interpolatedstring-perl6,
transformers,
diff --git a/src/forml/prelude.forml b/src/forml/prelude.forml
--- a/src/forml/prelude.forml
+++ b/src/forml/prelude.forml
@@ -84,8 +84,9 @@
-- annotated to constrain inferrence - otherwise, these functions would all be
-- inferred as `a -> b -> c`.
- inline (&&): Bool -> Bool -> Bool | x y = do! `x && y`
- inline (||): Bool -> Bool -> Bool | x y = do! `x || y`
+ (&&): Bool -> Bool -> Bool | x y = do! `x && y`
+ (||): Bool -> Bool -> Bool | x y = do! `x || y`
+
inline (*): Num -> Num -> Num | x y = do! `x * y`
inline (/): Num -> Num -> Num | x y = do! `x / y`
inline (%): Num -> Num -> Num | x y = do! `x % y`
@@ -95,6 +96,7 @@
inline (>=): Num -> Num -> Bool | x y = do! `x >= y`
inline (<): Num -> Num -> Bool | x y = do! `x < y`
inline (>): Num -> Num -> Bool | x y = do! `x > y`
+ inline (^): Num -> Num -> Num | x y = do! `Math.pow(x, y)`
-- Equality is overloaded to match records and arrays. By constraining the type of
-- this operator, we need only dispatch on the type of the first element,
@@ -136,6 +138,12 @@
(10 >= 5 + 5) != (4 + 5 <= 10 - 2)
({test: 1} == {test: 1}) == true
({test: 1} != {test: 1}) == false
+
+ inline
+ rand: Num -> JS Num | x =
+ `Math.floor(Math.random() * x)`
+
+
-- Fibonacci function
@@ -243,6 +251,17 @@
let x = "test"
in "hello `x`" is "hello test"
+
+ Regex = { regex: {} }
+
+ regex: String -> String -> Regex | r o = do! `new RegExp(r, o)`
+
+ replace: Regex -> String -> String -> String
+ | r s t =
+
+ do! `(t).replace(r, s)`
+
+ to_string: _ -> String | x = do! `x + ""`
open string
@@ -334,6 +353,18 @@
xx <- x
`$("body").replaceWith(old)`
return xx
+
+ inline on_key:
+
+ Num -> JS {} -> JS {}
+ | key action =
+
+ `jQuery(window).keydown(function(event) {
+ if (event.keyCode == key) {
+ event.preventDefault();
+ action();
+ }
+ })`
-- do! with_page do "body" $= "Test"
-- text <- get "body"
@@ -372,13 +403,13 @@
var report_failed spec results =
let items = spec.results_.items_
- desc = spec.description.split "__::__" !! 1
+ desc = split "__::__" spec.description !! 1
exp = stringify (items !! 0).expected
act = stringify (items !! 0).actual
line = get_line spec.description
do if is_error == 0
- then log "\r "
+ then log "\r "
else return {}
`is_error = 1`
@@ -402,7 +433,7 @@
else report_failed spec results
var reporter = { reportSpecResults: report
- reportRunnerResults: `phantom.exit(is_error)` }
+ reportRunnerResults: `if (typeof phantom != "undefined") { phantom.exit(is_error); }` }
do env <- `jasmine.getEnv()`
@@ -478,8 +509,10 @@
unshift: x -> Num
push: x -> Num
length: Num
- map: (x -> y) -> Array y
+ map: (x -> y) -> (UnboxedArray y)
forEach: (x -> _) -> {}
+ reverse: JS (UnboxedArray x)
+ reduce: (x -> x -> x) -> x
}
private inline unbox: Array a -> UnboxedArray a = cast
@@ -492,10 +525,14 @@
in xs
inline length = .length .: unbox
- inline map f = .map f .: unbox
+ inline map f = box .: .map f .: unbox
inline push! x = chain (.push x)
inline unshift! x = chain (.unshift x)
-
+ reverse x = do yield do! (unbox x).reverse
+ yield x
+
+ reduce f = .reduce (do! `function(x, y) { return f(x)(y); }`) .: unbox
+
inline get: Num -> Array x -> x
| x xs = do! `xs[x]`
@@ -518,7 +555,7 @@
inline
for_each: (Num -> _) -> Array _ -> JS {}
- | f xs = `for (x in xs) { f(x); }`
+ | f xs = `for (x in xs) { f(parseInt(x)); }`
inline
zip_with: (a -> b -> c) -> Array a -> Array b -> Array c
@@ -530,11 +567,15 @@
in do! xs 'for_each g
yield z
+
+ [3, 2, 1] == do! reverse [1, 2, 3]
let x = []
_ = push! 1 x
x == [1]
+ reduce (&&) [true, true, true]
+
[1, 2, 3] == do! put 3 [1, 2]
map (.x) [{x: 1}, {x: 2}] == [1, 2]
@@ -724,11 +765,11 @@
foldr1 _ {nil} = error "Foldr1 called on empty list"
| f x = foldr f (head x) (tail x)
- all? f = foldl1 (λx y = x && y) .: map f
- any? f = foldl1 (λx y = x || y) .: map f
+ all? f = foldl1 (&&) .: map f
+ any? f = foldl1 (||) .: map f
- sum = foldl1 λ(x, y) = x + y
- product = foldl1 λ(x, y) = x * y
+ sum = foldl1 (+)
+ product = foldl1 (*)
concat = foldl1 λx y = x ++ y
concat_map f xs = concat (map f xs)
@@ -738,8 +779,9 @@
minimum = foldl1 λx y = if x > y then y else x
- foldl (λx y = x + y) 0 [: 1, 2, 3, 4 ] == 10
- foldr (λx y = x + y) 0 [: 1, 2, 3, 4 ] == 10
+ foldl (+) 0 [: 1, 2, 3, 4 ] == 10
+ foldr (+) 0 [: 1, 2, 3, 4 ] == 10
+
all? id [:true,true]
not (all? id [:true,false])
any? id [:true,false]
diff --git a/src/forml/readme.forml b/src/forml/readme.forml
--- a/src/forml/readme.forml
+++ b/src/forml/readme.forml
@@ -6,8 +6,6 @@
-- $("header h1").after('
');
-- $("h1").css("font-family", "Montserrat");
-- $("header h1:first-letter").css("color", "#E53007");
-
-
--
-- Forml is a contemporary programming language for the discriminating
@@ -117,8 +115,8 @@
-- ========
-- This is unfortunately not comprehensive, and presumes some working knowledge of
-- ML or Haskell. For more examples, see the annotated
--- [prelude](http://texodus.github.com/forml/Prelude)
--- and [parsec](http://texodus.github.com/forml.Parsec.html).
+-- [prelude](http://texodus.github.com/forml/prelude.html),
+-- [parsec](http://texodus.github.com/forml/parsec.html) and [tetris](http://texodus.github.com/forml/tetris.html).
-- Forml supports a flexible, forgiving syntax that supports many synonymous forms.
-- This will be illustrated by adherring to an entirely random, arbitrary style throughout.
@@ -293,13 +291,11 @@
-- Types, Aliases & Unions
-- -----------------------
- -- Forml is strong & statically typed, and will infer types for most symbols
- -- via Damas-Hindley-Milner inferrence.
-
- increment x = x + 1 -- inferred as `increment: Num -> Num`
-
- --
-
+ -- Forml lacks algebraic data types in the ML sense, instead opting for
+ -- only structural typing of records. However, you can add explicit type
+ -- signatures to tell the Forml compiler it is OK to overload the types
+ -- of specific symbols.
+
num_or_string:
(Num | String) -> String
@@ -311,12 +307,6 @@
Maybe a = {just: a} | {nothing}
- -- Once a type such as this has a name, you may even refer to it recursively
-
- LinkedList a = { head: a, tail: LinkedList a }
-
- --
-
-- algebraic data types to be declared in a local scope, for all
-- records which are structurally equivalent to those declared. For instance,
-- we could declare a `Maybe a` ADT in forml via
@@ -332,6 +322,20 @@
maybe 3 {just: 4} == 4
maybe 3 {nothing} == 3
+ -- Once a type such as this has a name, you may even refer to it recursively
+ -- (note the `type` keyword is always optional).
+
+ type List a = { head: a, tail: List a } | { nil }
+
+ sum: List Num -> Num
+ sum { head: x, tail: xs } = x + sum xs
+ sum { nil } = 0
+
+ sum { head: 2
+ tail: { head: 3
+ tail: { nil } } }
+ == 5
+
-- In case this sort of things floats your boat, you can also declare
-- polymorphic types in "java" style, with `< >`.
@@ -344,6 +348,17 @@
-- Changes
-- =======
+
+ -- 0.1.3
+
+ -- * Fixed many parsing bugs, including negative numbers, indentation
+ -- on anonymous functions & do blocks, string-escaping, `isnt`,
+ -- accessor ordering.
+ -- * Operator partials ala Haskell, `sum = reduce (+)`
+ -- * Fixed type checking of mutually recursive definitions.
+ -- * Fixed Node.js test suite to work nearly-identically to Phantom.js
+ -- * Fixed output to use sensible filenames, and respect the `-o` option.
+ -- * [Tetris!](http://texodus.github.com/forml/tetris.html)
-- 0.1.2
@@ -361,7 +376,19 @@
-- * Documentation generation has been greatly improved. Better styling, generates individual pages for each file.
-- * The prelude is now embedded in the compiler. Simply import it via `open prelude` - the compiler will include
-- the code automatically. Currently weighs in at ~11k, if you care about that sort of thing.
- -- * Command line interface is more pleasant to work with
+ -- * Command line interface is more pleasant to work with
+
+ -- Contributors
+ -- ============
+ -- A special thanks to everyone who has contributed to forml!
+
+ -- * [jvshahid](https://github.com/jvshahid)
+ -- * [jhawk](https://github.com/JHawk)
+ -- * [mightybyte](https://github.com/mightybyte)
+ -- * [taku0](https://github.com/taku0)
+ -- * [brow](https://github.com/brow)
+ -- * [dignati](https://github.com/dignati)
+
diff --git a/src/forml/tests.forml b/src/forml/tests.forml
--- a/src/forml/tests.forml
+++ b/src/forml/tests.forml
@@ -133,6 +133,15 @@
length (rev_2 test_x) == length (rev_1 test_x)
length (rev_2 test_x) == length test_x
length (rev_1 test_x) == length (reverse test_x)
+
+
+
+module "Tests for typing bugs"
+
+ open prelude
+
+ ff x = gg x + 1
+ gg x = ff x - 1
module "Tests for parser bugs"
diff --git a/src/hs/Forml/CLI.hs b/src/hs/Forml/CLI.hs
--- a/src/hs/Forml/CLI.hs
+++ b/src/hs/Forml/CLI.hs
@@ -47,7 +47,7 @@
"-o" -> do (name:ys) <- get
put ys
RunConfig a _ c d e f g <- argsParser
- return $ RunConfig (x':a) name c d e f g
+ return $ RunConfig a name c d e f g
('-':_) -> error "Could not parse options"
z -> do RunConfig a _ c d e f g <- argsParser
let b = last $ split "/" $ head $ split "." z
diff --git a/src/hs/Forml/Closure.hs b/src/hs/Forml/Closure.hs
--- a/src/hs/Forml/Closure.hs
+++ b/src/hs/Forml/Closure.hs
@@ -40,7 +40,7 @@
writeFile "temp.js" x
system$ "java -jar $CLOSURE --compilation_level "
++ y
- ++ " --formatting=pretty_print --formatting=print_input_delimiter "
+ -- ++ " --formatting=pretty_print --formatting=print_input_delimiter "
++ " --js temp.js --warning_level QUIET > temp.compiled.js"
js <- readFile "temp.compiled.js"
system "rm temp.js"
diff --git a/src/hs/Forml/Doc.hs b/src/hs/Forml/Doc.hs
--- a/src/hs/Forml/Doc.hs
+++ b/src/hs/Forml/Doc.hs
@@ -54,20 +54,20 @@
_ -> (d, x)
-docs :: String -> [String] -> [Title] -> [Program] -> [Source] -> IO ()
-docs _ [] [] [] [] = return ()
-docs js (tests:testses) (title:titles) (program @ (Program xs):programs) (source:sources) =
+docs :: String -> [String] -> [Title] -> [String] -> [Program] -> [Source] -> IO ()
+docs _ [] [] [] [] [] = return ()
+docs js (tests:testses) (filename':filenames) (title:titles) (program @ (Program xs):programs) (source:sources) =
let html = highlight (get_tests xs) $ toHTML (annotate_tests source program)
- filename = [qq|$title.html|]
+ filename = [qq|$filename'.html|]
compiled = [qq||]
hook = [qq||]
- in do monitor [qq|Docs {title}.html|] $
+ in do monitor [qq|Docs {filename}|] $
do writeFile filename $ concat [header, css', scripts, compiled, html, hook, footer]
return $ Right ()
- docs js testses titles programs sources
+ docs js testses filenames titles programs sources
-docs _ _ _ _ _ = error "Paradox: `docs` called with non equivalent arguments"
+docs _ _ _ _ _ _ = error "Paradox: `docs` called with non equivalent arguments"
diff --git a/src/hs/Forml/Parser/Utils.hs b/src/hs/Forml/Parser/Utils.hs
--- a/src/hs/Forml/Parser/Utils.hs
+++ b/src/hs/Forml/Parser/Utils.hs
@@ -72,11 +72,12 @@
(escaped_char <|> anyChar) `manyTill` char '"'
where escaped_char = do char '\\'
- x <- oneOf "tnr"
+ x <- oneOf "tnr\\"
case x of
'r' -> return '\r'
'n' -> return '\n'
't' -> return '\t'
+ '\\' -> return '\\'
_ -> error "Unimplemented"
@@ -171,7 +172,7 @@
then parserFail "non-reserved word"
else return y
- where reserved_words = [ "if", "then", "else", "let", "when", "with", "and", "or", "do", "var",
+ where reserved_words = [ "if", "then", "else", "let", "when", "with", "and", "or", "do", "do!", "var",
"module", "open", "yield", "lazy", "inline", "in", "is", "isnt",
"|", "\\", "=", ":", ",", "->", "<-" ]
@@ -182,6 +183,16 @@
else return y
where reserved_words = [ "==", "<=", ">=", "!=", "<", ">", "||", "&&", ".", "," ]
+
+valid_partial_op :: Parser String -> Parser String
+valid_partial_op x = not_reserved$
+
+ do y <- x
+ if y `elem` reserved_words
+ then parserFail "non-reserved word"
+ else return y
+
+ where reserved_words = [ ".", "," ]
type_sep :: Parser Char
diff --git a/src/hs/Forml/TypeCheck.hs b/src/hs/Forml/TypeCheck.hs
--- a/src/hs/Forml/TypeCheck.hs
+++ b/src/hs/Forml/TypeCheck.hs
@@ -19,7 +19,7 @@
module Forml.TypeCheck where
import Data.List (intersect, partition,
- union, (\\))
+ union, (\\), reverse)
import qualified Data.List as L
import qualified Data.Map as M
@@ -43,6 +43,8 @@
import Forml.Parser.Utils
import Forml.TypeCheck.Types
+import Data.Graph (graphFromEdges, SCC(..))
+import Data.Graph.SCC (sccList)
-- Type Inference
@@ -77,8 +79,7 @@
infer (SymbolExpression i) =
do sc <- find (show i)
- (ps :=> t) <- freshInst sc
- predicate ps
+ t <- freshInst sc
return t
infer (JSExpression _) =
@@ -100,7 +101,7 @@
do t <- newTVar Star
as <- get_assumptions
[_ :>: q] <- with_scope$ ims as
- (_ :=> t') <- freshInst q
+ t' <- freshInst q
unify t t'
return t
@@ -110,7 +111,7 @@
as'' <- get_assumptions
return$ as'' \\ as
- infer (AccessorExpression (Addr s f x) y) = infer (acc y)
+ infer (AccessorExpression (Addr s f x) y) = infer (acc $ reverse y)
where acc :: [Symbol] -> Expression Definition
acc [] = x
@@ -127,22 +128,22 @@
do ts <- mapM infer xs
let r = TypeRecord (TRecord (M.fromList (zip (map f names) ts)) TComplete Star)
t' <- newTVar Star
- sc <- find $ quantify (tv r) ([] :=> r)
+ sc <- find $ quantify (tv r) r
case sc of
Nothing ->
do unify t' r
return t'
Just (Forall _ scr, sct) ->
- do (_ :=> t'') <- freshInst sct
- (qs :=> t''') <- return$ inst (map TypeVar$ tv t'') (scr)
- (_ :=> t) <- freshInst (quantify (tv t''' \\ tv t'') (qs :=> t'''))
+ do t'' <- freshInst sct
+ t''' <- return$ inst (map TypeVar$ tv t'') (scr)
+ t <- freshInst (quantify (tv t''' \\ tv t'') t''')
unify t r
unify t' t''
s <- get_substitution
let t''' = apply s t
r''' = apply s r
- qt = quantify (tv t''') $ [] :=> t'''
- rt = quantify (tv r''') $ [] :=> r'''
+ qt = quantify (tv t''') t'''
+ rt = quantify (tv r''') r'''
sct' = apply s t''
if qt /= rt
then do add_error$ "Record does not match expected signature for " ++ show sct' ++ "\n"
@@ -209,15 +210,6 @@
--- Generalization
-
-split :: Monad m => ClassEnv -> [TypeVar] -> [TypeVar] -> [Pred] -> m ([Pred], [Pred])
-split ce fs _ ps =
-
- do ps' <- reduce ce ps
- let (ds, rs) = partition (all (`elem` fs) . tv) ps'
- return (ds, rs) -- \\ rs')
-
instance Infer [Definition] () where
infer bs =
@@ -239,9 +231,7 @@
mapM (\(t, as) -> f (unify t) as) (zip def_types axiom_types)
- ps <- get_predicates
as <- get_assumptions
- ps' <- substitute ps
ss <- get_substitution
fs' <- substitute as
@@ -250,19 +240,13 @@
vss = map tv ts'
gs = foldr1 union vss \\ fs
- ce <- get_classenv
- (ds, rs) <- split ce fs (foldr1 intersect vss) ps'
-
if restricted then
- let gs' = gs \\ tv rs
- scs' = map (quantify gs' . ([]:=>)) ts'
- in do predicate (ds ++ rs)
- assume (zipWith (:>:) is scs')
+ let scs' = map (quantify gs) ts'
+ in do assume (zipWith (:>:) is scs')
return ()
else
- let scs' = map (quantify gs . (rs:=>)) ts'
- in do predicate ds
- assume (zipWith (:>:) is scs')
+ let scs' = map (quantify gs) ts'
+ in do assume (zipWith (:>:) is scs')
return ()
where get_name (Definition _ _ (Symbol x) _) = x
@@ -295,29 +279,22 @@
infer (Definition _ _ name axs) =
do sc <- find$ f name
- (qs :=> t) <- freshInst sc
+ t <- freshInst sc
axiom_types <- with_scope$ mapM (with_scope . infer) axs
s <- get_substitution
mapM (flip unify t) axiom_types -- TODO apply sub to axiom_types?
as <- get_assumptions
- ce <- get_classenv
- ps <- get_predicates
- let qs' = apply s qs
- t' = apply s t
+ let t' = apply s t
fs = tv (apply s as)
gs = tv t' \\ fs
- sc' = quantify gs (qs' :=> t')
- ps' = filter (not . entail ce qs') (apply s ps)
+ sc' = quantify gs t'
- (_, rs) <- split ce fs gs ps'
if sc /= sc' then
add_error$ "Signature too general\n\n Expected: " ++ show sc ++ "\n Actual: " ++ show sc'
- else if not (null rs) then
- add_error$ "Context too weak\n\n Expected: " ++ show sc ++ "\n Actual: " ++ show sc'
else
assume (f name :>: sc)
@@ -356,7 +333,7 @@
g name (TypeAxiom t) = [ name :>: to_scheme' t' | t' <- enumerate_types t ]
to_scheme' :: Type -> Scheme
- to_scheme' t = quantify (tv t) ([] :=> t)
+ to_scheme' t = quantify (tv t) t
sigs :: [Definition] -> [Assumption]
sigs [] = []
@@ -393,7 +370,7 @@
let f (_ :>: scheme) =
- [ do (_ :=> t) <- freshInst scheme
+ [ do t <- freshInst scheme
return t ]
f _ = []
@@ -404,7 +381,7 @@
in do schemes <- sequence $ concat $ map f assumptions
let symbols = concat $ map g assumptions
let rec = TypeRecord (TRecord (M.fromList (zip symbols schemes)) TComplete Star)
- return $ quantify (tv rec) ([] :=> rec)
+ return $ quantify (tv rec) rec
h (Symbol x) = x
@@ -428,12 +405,12 @@
to_scheme :: TypeDefinition -> UnionType -> [Assumption]
-to_scheme (TypeDefinition n vs) t = [ quantify (vars y) ([]:=> y) :>>: def_type y
+to_scheme (TypeDefinition n vs) t = [ quantify (vars y) y :>>: def_type y
| y <- enumerate_types t ]
where vars y = map (\x -> TVar x (infer_kind x y)) vs
- def_type y = quantify (vars y) ([] :=> foldl app poly_type (map TypeVar (vars y)))
+ def_type y = quantify (vars y) (foldl app poly_type (map TypeVar (vars y)))
poly_type = Type (TypeConst n (to_kind (length vs)))
@@ -510,64 +487,52 @@
sort_dep :: [[Definition]] -> [[Definition]]
sort_dep [] = []
-sort_dep xs = case map (:[])$ concat$ map snd$ filter fst free of
- [] -> error$ "Unresolvable dependency ordering in " ++ show (get_names xs)
- xs -> xs ++ sort_dep (map snd$ filter (not . fst) free)
-
-
- where as = get_needed (get_names xs) (zip (get_names xs) (get_expressions xs))
-
- free = get_free as `zip` xs
-
- get_free [] = []
- get_free ([]:xs) = True : get_free xs
- get_free (_:xs) = False : get_free xs
-
- get_names [] = []
- get_names ([Definition _ _ n _]:xs) = show n : get_names xs
+sort_dep (concat -> xs) = unwrap `map` sccList graph
- get_needed _ [] = []
- get_needed names ((n,x):xs) =
- ((names \\ [n]) `L.intersect` (concat$ map get_symbols x)) : get_needed names xs
+ where (graph, reverse_lookup, _) = graphFromEdges . map to_node $ xs
- get_expressions :: [[Definition]] -> [[Expression Definition]]
+ unwrap (AcyclicSCC v) = [ get_node . reverse_lookup $ v ]
+ unwrap (CyclicSCC v) = map (get_node . reverse_lookup) v
+
+ get_node (d, _, _) = d
+
+ to_node :: Definition -> (Definition, String, [String])
+ to_node def @ (Definition _ _ n as) =
+ (def, show n, concat . map get_symbols . get_expressions $ as)
+
get_expressions [] = []
- get_expressions ([Definition _ _ _ as]:xs) = get_expressions' as : get_expressions xs
-
- get_expressions' [] = []
- get_expressions' (TypeAxiom _: xs) = get_expressions' xs
- get_expressions' (EqualityAxiom (Match _ (Just y)) (Addr _ _ x): xs) = y : x : get_expressions' xs
- get_expressions' (EqualityAxiom _ (Addr _ _ x): xs) = x : get_expressions' xs
+ get_expressions (TypeAxiom _: xs') = get_expressions xs'
+ get_expressions (EqualityAxiom (Match _ (Just y)) (Addr _ _ x): xs') = y : x : get_expressions xs'
+ get_expressions (EqualityAxiom _ (Addr _ _ x): xs') = x : get_expressions xs'
get_symbols (RecordExpression (unzip . M.toList -> (_, xs))) = concat (map get_symbols xs)
get_symbols (AccessorExpression (Addr _ _ x) _) = get_symbols x
- get_symbols (ApplyExpression a b) = get_symbols a ++ concat (map get_symbols b)
- get_symbols (IfExpression a b c) = get_symbols a ++ get_symbols b ++ get_symbols c
- get_symbols (LiteralExpression _) = []
- get_symbols (SymbolExpression x) = [show x]
- get_symbols (JSExpression _) = []
+ get_symbols (ApplyExpression a b) = get_symbols a ++ concat (map get_symbols b)
+ get_symbols (IfExpression a b c) = get_symbols a ++ get_symbols b ++ get_symbols c
+ get_symbols (LiteralExpression _) = []
+ get_symbols (SymbolExpression x) = [show x]
+ get_symbols (JSExpression _) = []
get_symbols (LazyExpression (Addr _ _ x) _) = get_symbols x
- get_symbols (FunctionExpression as) = concat$ map get_symbols$ get_expressions' as
- get_symbols (LetExpression _ x) = get_symbols x
- get_symbols (ListExpression x) = concat (map get_symbols x)
-js_type :: Type
+ get_symbols (FunctionExpression as) = concat$ map get_symbols$ get_expressions as
+ get_symbols (LetExpression _ x) = get_symbols x
+ get_symbols (ListExpression x) = concat (map get_symbols x)
+ get_symbols _ = error "Unimplemented TypeCheck 544"
+
+js_type :: Type
js_type = Type (TypeConst "JS" (KindFunction Star Star))
tiProgram :: Program -> [(Namespace, [Assumption])] -> ([(Namespace, [Assumption])], [String])
tiProgram (Program bgs) env =
runTI $ do TI (\x -> (x { modules = env }, ()))
- assume$ "true" :>: (Forall [] ([] :=> Type (TypeConst "Bool" Star)))
- assume$ "false" :>: (Forall [] ([] :=> Type (TypeConst "Bool" Star)))
- assume$ "error" :>: (Forall [Star] ([] :=> TypeGen 0))
- assume$ "run" :>: (Forall [Star] ([] :=> (TypeApplication js_type (TypeGen 0) -:> TypeGen 0)))
+ assume$ "true" :>: (Forall [] (Type (TypeConst "Bool" Star)))
+ assume$ "false" :>: (Forall [] (Type (TypeConst "Bool" Star)))
+ assume$ "error" :>: (Forall [Star] (TypeGen 0))
+ assume$ "run" :>: (Forall [Star] (TypeApplication js_type (TypeGen 0) -:> TypeGen 0))
infer'$ to_group bgs
s <- get_substitution
- ce <- get_classenv
- ps <- get_predicates
ms <- TI (\y -> (y, modules y))
- rs <- reduce ce (apply s ps)
e <- get_errors
return ((apply s ms), S.toList . S.fromList $ e)
diff --git a/src/hs/Forml/TypeCheck/Types.hs b/src/hs/Forml/TypeCheck/Types.hs
--- a/src/hs/Forml/TypeCheck/Types.hs
+++ b/src/hs/Forml/TypeCheck/Types.hs
@@ -1,9 +1,6 @@
-{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -17,18 +14,16 @@
module Forml.TypeCheck.Types where
-import Data.List (nub, intersect, union)
-import System.IO.Unsafe
+import Data.List ((\\), nub, intersect, union)
import Text.InterpolatedString.Perl6
-import Data.List (nub, (\\), intersect, union, partition)
-
import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.Set as S
import Control.Monad
+import Control.Arrow
import Data.Monoid
import Forml.Types.Namespace hiding (Module)
@@ -36,7 +31,7 @@
type Id = String
enumId :: Int -> Id
-enumId n = "v" ++ show n
+enumId n = 'v' : show n
data Kind = Star | KindFunction Kind Kind deriving (Show, Eq, Ord)
@@ -127,7 +122,7 @@
instance Types a => Types [a] where
apply s = map (apply s)
- tv = nub . concat . map tv
+ tv = nub . concatMap tv
infixr 4 @@
(@@) :: Substitution -> Substitution -> Substitution
@@ -213,10 +208,10 @@
data Z a = Z a | Error String
instance Monad Z where
- return x = Z x
+ return = Z
(Z x) >>= f = f x
(Error x) >>= _ = Error x
- fail x = Error x
+ fail = Error
mgu :: Type -> Type -> TI Substitution
mgu x y = do z <- mgu' x y
@@ -237,7 +232,7 @@
case g of
Nothing -> return $ Left e --add_error e >> return []
Just (x, sct) ->
- do (qs' :=> t'') <- freshInst sct
+ do t'' <- freshInst sct
return $ Right x
second_chance e y x @ (TypeRecord (TRecord _ (TPartial _) _)) = second_chance e x y
@@ -255,8 +250,8 @@
find' as
where find' [] = return $ Left e
- find' ((i':>>:(Forall _ (_ :=> (Type (TypeConst x' k'))))):as)
- | x == x' = do (_ :=> i'') <- freshInst i'
+ find' ((i' :>>: Forall _ (Type (TypeConst x' k'))):as)
+ | x == x' = do i'' <- freshInst i'
i'' `mgu'` t'
find' (_:as) = find' as
@@ -266,22 +261,22 @@
second_chance e x y = return $ Left e
apply_rules t' r =
- do sc <- find $ quantify (tv r) ([] :=> r)
+ do sc <- find $ quantify (tv r) r
case sc of
Nothing ->
do unify t' r
return t'
Just (Forall _ scr, sct) ->
- do (_ :=> t'') <- freshInst sct
- (qs :=> t''') <- return$ inst (map TypeVar$ tv t'') (scr)
- (_ :=> t) <- freshInst (quantify (tv t''' \\ tv t'') (qs :=> t'''))
+ do t'' <- freshInst sct
+ t''' <- return$ inst (map TypeVar$ tv t'') scr
+ t <- freshInst (quantify (tv t''' \\ tv t'') t''')
unify t r
unify t' t''
s <- get_substitution
let t''' = apply s t
r''' = apply s r
- qt = quantify (tv t''') $ [] :=> t'''
- rt = quantify (tv r''') $ [] :=> r'''
+ qt = quantify (tv t''') $ t'''
+ rt = quantify (tv r''') $ r'''
sct' = apply s t''
if qt /= rt
then do add_error$ "Record does not match expected signature for " ++ show sct' ++ "\n"
@@ -311,153 +306,11 @@
--- Type Classes
--- --------------------------------------------------------------------------------
-data Qual t = [Pred] :=> t deriving Eq
-data Pred = IsIn Id Type deriving (Show, Eq)
-
-instance (Show t) => Show (Qual t) where
- show (_ :=> t) = show t
-
-instance Types t => Types (Qual t) where
- apply s (ps :=> t) = apply s ps :=> apply s t
- tv (ps :=> t) = tv ps `union` tv t
-
-instance Types Pred where
- apply s (IsIn i t) = IsIn i (apply s t)
- tv (IsIn _ t) = tv t
-
-mguPred, matchPred :: Pred -> Pred -> Maybe Substitution
-mguPred = lift (|=|)
-lift :: forall (m :: * -> *) a.
- Monad m =>
- (Type -> Type -> m a) -> Pred -> Pred -> m a
-matchPred = lift match
-
-lift m (IsIn i t) (IsIn i' t')
- | i == i' = m t t'
- | otherwise = fail "classes differ"
-
-type Class = ([Id], [Inst])
-type Inst = Qual Pred
-
-
-
--- Class Environments
--- --------------------------------------------------------------------------------
-
-data ClassEnv = ClassEnv { classes :: Id -> Maybe Class,
- defaults :: [Type] }
-
-super :: ClassEnv -> Id -> [Id]
-super ce i = case classes ce i of Just (is, _) -> is
-
-insts :: ClassEnv -> Id -> [Inst]
-insts ce i = case classes ce i of Just (_, its) -> its
-
-defined :: Maybe a -> Bool
-defined (Just x) = True
-defined Nothing = False
-
-modify :: ClassEnv -> Id -> Class -> ClassEnv
-modify ce i c = ce{classes = \j -> if i==j then Just c
- else classes ce j}
-
-initialEnv :: ClassEnv
-initialEnv = ClassEnv { classes = \_ -> fail "class not defined",
- defaults = [num_type] }
-
-type EnvTransformer = ClassEnv -> Maybe ClassEnv
-
-infixr 5 <::>
-(<::>) :: EnvTransformer -> EnvTransformer -> EnvTransformer
-(f <::> g) ce = do ce' <- f ce
- g ce'
-
-addClass :: Id -> [Id] -> EnvTransformer
-addClass i is ce
- | defined (classes ce i) = fail "class already defined"
- | any (not . defined . classes ce) is = fail "superclass not defined"
- | otherwise = return (modify ce i (is, []))
-
-addPreludeClasses :: EnvTransformer
-addPreludeClasses = addCoreClasses <::> addNumClasses
-
-addCoreClasses :: EnvTransformer
-addCoreClasses = addClass "Eq" []
- <::> addClass "Ord" ["Eq"]
- <::> addClass "Show" []
- <::> addClass "Read" []
- <::> addClass "Bounded" []
- <::> addClass "Enum" []
- <::> addClass "Functor" []
- <::> addClass "Monad" []
-
-addNumClasses :: EnvTransformer
-addNumClasses = addClass "Num" ["Eq", "Show"]
- <::> addClass "Real" ["Num", "Ord"]
- <::> addClass "Fractional" ["Num"]
- <::> addClass "Integral" ["Real", "Enum"]
- <::> addClass "RealFrac" ["Real", "Fractional"]
- <::> addClass "Floating" ["Fractional"]
- <::> addClass "RealFloat" ["RealFrac", "Floating"]
-
-
-
--- Entailment
--- --------------------------------------------------------------------------------
-
-bySuper :: ClassEnv -> Pred -> [Pred]
-bySuper ce p@(IsIn i t) =
- p : concat [ bySuper ce (IsIn i' t) | i' <- super ce i ]
-
-byInst :: ClassEnv -> Pred -> Maybe [Pred]
-byInst ce p@(IsIn i t) = msum [ tryInst it | it <- insts ce i ]
- where tryInst (ps :=> h) = do u <- matchPred h p
- Just (map (apply u) ps)
-
-entail :: ClassEnv -> [Pred] -> Pred -> Bool
-entail ce ps p = any (p `elem`) (map (bySuper ce) ps) ||
- case byInst ce p of
- Nothing -> False
- Just qs -> all (entail ce ps) qs
-
-inHnf :: Pred -> Bool
-inHnf (IsIn _ t) = hnf t
- where hnf (TypeVar v) = True
- hnf (Type tc) = False
- hnf (TypeApplication t _) = hnf t
-
-toHnfs :: Monad m => ClassEnv -> [Pred] -> m [Pred]
-toHnfs ce ps = do pss <- mapM (toHnf ce) ps
- return (concat pss)
-
-toHnf :: Monad m => ClassEnv -> Pred -> m [Pred]
-toHnf ce p | inHnf p = return [p]
- | otherwise = case byInst ce p of
- Nothing -> fail "context reduction"
- Just ps -> toHnfs ce ps
-
-simplify :: ClassEnv -> [Pred] -> [Pred]
-simplify ce = loop []
- where loop rs [] = rs
- loop rs (p:ps) | entail ce (rs++ps) p = loop rs ps
- | otherwise = loop (p:rs) ps
-
-reduce :: Monad m => ClassEnv -> [Pred] -> m [Pred]
-reduce ce ps = do qs <- toHnfs ce ps
- return (simplify ce qs)
-
-scEntail :: ClassEnv -> [Pred] -> Pred -> Bool
-scEntail ce ps p = any (p `elem`) (map (bySuper ce) ps)
-
-
-
-- Type Schemes
-- --------------------------------------------------------------------------------
-data Scheme = Forall [Kind] (Qual Type) deriving Eq
+data Scheme = Forall [Kind] Type deriving Eq
instance Show Scheme where
show (Forall [] t) = show t
@@ -468,14 +321,14 @@
apply s (Forall ks qt) = Forall ks (apply s qt)
tv (Forall _ qt) = tv qt
-quantify :: [TypeVar] -> Qual Type -> Scheme
+quantify :: [TypeVar] -> Type -> Scheme
quantify vs qt = Forall ks (apply s qt)
where vs' = [ v | v <- tv qt, v `elem` vs ]
ks = map kind vs'
s = zip vs' (map TypeGen [0..])
toScheme :: Type -> Scheme
-toScheme t = Forall [] ([] :=> t)
+toScheme t = Forall [] t
@@ -517,9 +370,9 @@
find' x
where find' [] = return Nothing
- find' ((i':>>:sc):as) = do (_ :=> i'') <- freshInst i
- (_ :=> i''') <- freshInst i'
- x <- i'' `can_unify` i'''
+ find' ((i':>>:sc):as) = do i'' <- freshInst i
+ i''' <- freshInst i'
+ x <- i'' `can_unify` i'''
if x then return $ Just (i', sc) else find' as
find' (_:as) = find' as
@@ -532,7 +385,7 @@
find''' (_:>:_:xs) t = find''' xs t
find''' ((Forall _ x :>>: y):xs) t =
- do (_ :=> t') <- return$ inst (map TypeVar$ tv t) x
+ do t' <- return$ inst (map TypeVar$ tv t) x
case t' |=| t of
Error _ -> find''' xs t
@@ -549,15 +402,13 @@
-- --------------------------------------------------------------------------------
data TIState = TIState { substitution :: Substitution
- , seed :: Int
- , class_env :: ClassEnv
- , msg :: String
- , warnings :: [String]
- , errors :: [String]
- , modules :: [(Namespace, [Assumption])]
- , namespace :: Namespace
- , assumptions :: [Assumption]
- , predicates :: [Pred] }
+ , seed :: Int
+ , msg :: String
+ , warnings :: [String]
+ , errors :: [String]
+ , modules :: [(Namespace, [Assumption])]
+ , namespace :: Namespace
+ , assumptions :: [Assumption] }
newtype TI a = TI (TIState -> (TIState, a))
@@ -565,36 +416,30 @@
fail x = TI (\y -> error$ x ++ "\n" ++ msg y)
return x = TI (\y -> (y, x))
TI f >>= g = TI (\x -> case f x of
- (y, x) -> let TI gx = g x
- in gx y)
+ (y, x') -> let TI gx = g x'
+ in gx y)
instance Functor TI where
fmap f y = y >>= (\x -> TI (\x' -> (x', f x)))
instance Types [(Namespace, [Assumption])] where
- apply s v = map (\(x, y) -> (x, apply s y)) v
- tv = concat . map (\(_, y) -> tv y)
+ apply = map . second . apply
+ tv = concatMap (\(_, y) -> tv y)
runTI :: TI a -> a
-runTI (TI f) = x where (t,x) = f (TIState [] 0 initialEnv "" [] [] [] (Namespace []) [] [])
+runTI (TI f) = x where (_, x) = f (TIState [] 0 "" [] [] [] (Namespace []) [])
get_assumptions :: TI [Assumption]
get_msg :: TI String
set_msg :: String -> TI ()
-get_predicates :: TI [Pred]
-set_predicates :: [Pred] -> TI ()
get_substitution :: TI Substitution
-get_classenv :: TI ClassEnv
add_error :: String -> TI ()
get_assumptions = TI (\x -> (x, assumptions x))
get_msg = TI (\x -> (x, msg x))
set_msg x = TI (\y -> (y { msg = x }, ()))
-get_predicates = TI (\x -> (x, predicates x))
-set_predicates x = TI (\y -> (y { predicates = x }, ()))
get_substitution = TI (\x -> (x, substitution x))
-get_classenv = TI (\x -> (x, class_env x))
add_error y = TI (\x -> (x { errors = errors x ++ [y ++ "\n" ++ msg x] }, ()))
set_assumptions :: [Assumption] -> TI ()
get_errors :: TI [String]
@@ -614,24 +459,13 @@
instance Assume [Assumption] where
assume x = TI (\y -> (y { assumptions = assumptions y ++ x}, ()))
-class Predicated a where
- predicate :: a -> TI ()
-
-instance Predicated Pred where
- predicate x = TI (\y -> (y { predicates = predicates y ++ (x:[]) }, ()))
-
-instance Predicated [Pred] where
- predicate x = TI (\y -> (y { predicates = predicates y ++ x}, ()))
-
-
with_scope :: TI a -> TI a
with_scope x = do as <- get_assumptions
- ps <- get_predicates
- y <- x
+ y <- x
set_assumptions as
- set_predicates ps
return y
+-- TODO
with_module :: String -> TI [Assumption] -> TI ()
with_module name x = do --as <- get_assumptions
ns <- get_namespace
@@ -671,7 +505,7 @@
newTVar k = TI (\x -> let v = TVar (enumId (seed x)) k
in (x { seed = seed x + 1}, TypeVar v))
-freshInst :: Scheme -> TI (Qual Type)
+freshInst :: Scheme -> TI Type
freshInst (Forall ks qt) = do ts <- mapM newTVar ks
return (inst ts qt)
@@ -690,18 +524,11 @@
instance Instantiate a => Instantiate [a] where
inst ts = map (inst ts)
-instance Instantiate t => Instantiate (Qual t) where
- inst ts (ps :=> t) = inst ts ps :=> inst ts t
-
-instance Instantiate Pred where
- inst ts (IsIn c t) = IsIn c (inst ts t)
-
class Infer e t | e -> t where infer :: e -> TI t
-
list_scheme :: Scheme
list_scheme = Forall [Star] qual_list
- where qual_list = [] :=> TypeApplication (Type (TypeConst "List" (KindFunction Star Star))) (TypeGen 0)
+ where qual_list = TypeApplication (Type (TypeConst "List" (KindFunction Star Star))) (TypeGen 0)
bool_type :: Type
bool_type = Type (TypeConst "Bool" Star)
diff --git a/src/hs/Forml/Types/Expression.hs b/src/hs/Forml/Types/Expression.hs
--- a/src/hs/Forml/Types/Expression.hs
+++ b/src/hs/Forml/Types/Expression.hs
@@ -108,7 +108,8 @@
inner_no_accessor =
- indentPairs "(" syntax ")"
+ try (indentPairs "(" (try (SymbolExpression . Operator <$> valid_partial_op (many1 operator))) ")")
+ <|> indentPairs "(" syntax ")"
<|> js
<|> try record
<|> named_key
@@ -126,9 +127,9 @@
(Match [VarPattern "__y"] Nothing)
(Addr s c
(AccessorExpression
- (Addr s c
- (SymbolExpression (Symbol "__y")))
- [x]))])
+ (Addr s c
+ (SymbolExpression (Symbol "__y")))
+ [x]))])
accessor_apply =
@@ -161,34 +162,34 @@
string "do"
i <- try (string "!") <|> return ""
P.spaces
- l <- withPos line
+ l <- withPosTemp line
if i == "!"
then return$ ApplyExpression (SymbolExpression (Symbol "run")) [wrap s l]
else return$ wrap s l
- where line = try bind <|> try let_bind <|> try return'
+ where line = try bind <|> try let_bind <|> return'
wrap s x = LazyExpression (Addr s s (ApplyExpression (SymbolExpression (Symbol "run")) [x])) Every
bind = do p <- syntax
whitespace <* (string "<-" <|> string "←") <* whitespace
- ex <- withPos syntax
- spaces *> same
+ ex <- withPosTemp syntax
+ P.spaces *> same
f ex p <$> addr line
let_bind = withPosTemp $ do string "let"
whitespace1
- defs <- withPos def
- spaces
+ defs <- withPosTemp def
+ P.spaces
same
LetExpression <$> return defs <*> line
- where def = try syntax `sepBy1` try (spaces *> same)
+ where def = try syntax `sepBy1` try (P.spaces *> same)
return' = do v <- syntax
option v $ try $ unit_bind v
- unit_bind v = do spaces *> same
+ unit_bind v = do P.spaces *> same
f v AnyPattern <$> addr line
f ex pat zx = ApplyExpression
@@ -200,11 +201,11 @@
lazy = do string "lazy"
whitespace1
- LazyExpression <$> withPos (addr$ try syntax) <*> return Once
+ LazyExpression <$> withPosTemp (addr syntax) <*> return Once
yield = do string "yield"
whitespace1
- LazyExpression <$> withPos (addr$ try syntax) <*> return Every
+ LazyExpression <$> withPosTemp (addr syntax) <*> return Every
if' = withPos $ do string "if"
whitespace1
@@ -229,19 +230,27 @@
where table = [ [ix "^"]
, [ix "*", ix "/"]
- , [px "-", px "!" ]
+ , [ Prefix neg ]
, [ix "+", ix "-"]
, [ Infix user_op_right AssocRight, Infix user_op_left AssocLeft ]
- , [ix "<", ix "<=", ix ">=", ix ">", ix "==", ix "!=", ix "is", ix "isnt"]
+ , [ix "<", ix "<=", ix ">=", ix ">", ix "==", ix "!=", ix "isnt", ix "is"]
, [ix "&&", ix "||", ix "and", ix "or" ] ]
ix s = Infix (try . op $ (unwind <$> string s) <* notFollowedBy operator) AssocLeft
- unwind "and" = Operator "&&"
- unwind "or" = Operator "||"
- unwind "is" = Operator "=="
+ unwind "and" = Operator "&&"
+ unwind "or" = Operator "||"
+ unwind "is" = Operator "=="
unwind "isnt" = Operator "!="
- unwind x = Operator x
+ unwind x = Operator x
+
+ neg = try $ do spaces
+ string "-"
+ spaces
+ return (\x -> ApplyExpression
+ (SymbolExpression (Operator "-"))
+ [LiteralExpression (IntLiteral 0), x])
+
px s = Prefix (try neg)
where neg = do spaces
@@ -324,14 +333,12 @@
return $ FunctionExpression (t ++ eqs)
type_axiom = do string ":"
- spaces
- indented
- TypeAxiom <$> withPos type_axiom_signature
+ P.spaces
+ TypeAxiom <$> withPosTemp type_axiom_signature
eq_axiom = do patterns <- syntax
string "="
- spaces
- indented
+ P.spaces
ex <- withPosTemp $ withPos (addr syntax)
return $ EqualityAxiom patterns ex
@@ -487,7 +494,8 @@
instance (Show d, ToLocalStat d) => ToJExpr (Expression d) where
--- toJExpr (ApplyExpression (SymbolExpression (Symbol "run")) [x]) = [jmacroE| `(x)`() |]
+ toJExpr (ApplyExpression (SymbolExpression (Symbol "run")) [x]) = [jmacroE| `(x)`() |]
+ toJExpr (ApplyExpression (SymbolExpression (Operator "&&")) [x, y]) = [jmacroE| `(x)` && `(y)` |]
toJExpr (ApplyExpression (SymbolExpression f @ (Operator _)) [x, y]) =
toJExpr (ApplyExpression (SymbolExpression (Symbol (to_name f))) [x,y])
diff --git a/src/hs/Forml/Types/Literal.hs b/src/hs/Forml/Types/Literal.hs
--- a/src/hs/Forml/Types/Literal.hs
+++ b/src/hs/Forml/Types/Literal.hs
@@ -33,5 +33,5 @@
instance Infer Literal Type where
infer (StringLiteral _) = return (Type (TypeConst "String" Star))
infer (IntLiteral _) = return (Type (TypeConst "Num" Star))
- infer (DoubleLiteral _) = return (Type (TypeConst "Double" Star))
+ infer (DoubleLiteral _) = return (Type (TypeConst "Num" Star))
diff --git a/src/hs/Forml/Types/Namespace.hs b/src/hs/Forml/Types/Namespace.hs
--- a/src/hs/Forml/Types/Namespace.hs
+++ b/src/hs/Forml/Types/Namespace.hs
@@ -39,7 +39,7 @@
syntax = Namespace <$> (many1 lower `sepBy1` char '.')
instance ToJExpr Namespace where
- toJExpr (Namespace []) = ref "window"
+ toJExpr (Namespace []) = [jmacroE| (typeof global == "undefined" ? window : global) |]
toJExpr (Namespace (end -> x : xs)) = [jmacroE| `(Namespace xs)`[`(x)`] |]
diff --git a/src/hs/Forml/Types/Pattern.hs b/src/hs/Forml/Types/Pattern.hs
--- a/src/hs/Forml/Types/Pattern.hs
+++ b/src/hs/Forml/Types/Pattern.hs
@@ -219,9 +219,8 @@
infer (ListPattern xs) = do ts <- mapM infer xs
t' <- newTVar Star
- (qs :=> t) <- freshInst list_scheme
+ t <- freshInst list_scheme
mapM_ (unify t') ts
- predicate qs
return t
infer (RecordPattern (unzip . M.toList -> (names, patterns)) p) =
@@ -234,22 +233,22 @@
let r = TypeRecord (TRecord (M.fromList (zip (map f names) ts)) p' Star)
t' <- newTVar Star
- sc <- find $ quantify (tv r) ([] :=> r)
+ sc <- find $ quantify (tv r) r
case sc of
Nothing ->
do unify t' r
return t'
Just (Forall _ scr, sct) ->
- do (_ :=> t'') <- freshInst sct
- (qs :=> t''') <- return$ inst (map TypeVar$ tv t'') scr
- (_ :=> t) <- freshInst (quantify (tv t''' L.\\ tv t'') (qs :=> t'''))
+ do t'' <- freshInst sct
+ t''' <- return$ inst (map TypeVar$ tv t'') scr
+ t <- freshInst (quantify (tv t''' L.\\ tv t'') t''')
unify t r
unify t' t''
s <- get_substitution
let t''' = apply s t
r''' = apply s r
- qt = quantify (tv t''') $ [] :=> t'''
- rt = quantify (tv r''') $ [] :=> r'''
+ qt = quantify (tv t''') t'''
+ rt = quantify (tv r''') r'''
if qt /= rt
then do add_error$ "Object constructor does not match signature\n"
++ " Expected: " ++ show qt ++ "\n"
diff --git a/src/hs/Forml/Types/Statement.hs b/src/hs/Forml/Types/Statement.hs
--- a/src/hs/Forml/Types/Statement.hs
+++ b/src/hs/Forml/Types/Statement.hs
@@ -286,7 +286,7 @@
print' (y:[]) = [jmacroE| `(ref y)` |]
print' (y:ys) = [jmacroE| `(print' ys)`[`(y)`] |]
- in declare x [jmacroE| `(print' $ reverse ns)`[`(x)`] || window[`(x)`] |] ++ open (Namespace ns) xs
+ in declare x [jmacroE| `(print' $ reverse ns)`[`(x)`] || (typeof global == "undefined" ? window : global)[`(x)`] |] ++ open (Namespace ns) xs
diff --git a/src/hs/Main.hs b/src/hs/Main.hs
--- a/src/hs/Main.hs
+++ b/src/hs/Main.hs
@@ -19,6 +19,8 @@
import System.Environment
import System.IO
+
+import Data.String.Utils (split)
import Data.List as L
import Forml.CLI
@@ -31,8 +33,7 @@
import qualified Forml.Optimize as O
import Forml.Parser
import Forml.Static
-import Forml.TypeCheck hiding (split)
-import Data.String.Utils (split)
+import Forml.TypeCheck
to_parsed :: Title -> Source -> TypeSystem -> Either [Error] (TypeSystem, Program)
to_parsed name src env = case parseForml name src of
@@ -41,11 +42,14 @@
(as, []) -> Right (as, x)
(_, y) -> Left y
+to_filename = head . split "." . last . split "/"
+
parse_forml :: [Filename] -> IO ([Filename], TypeSystem, [(Program, Source)], [Title])
parse_forml filenames =
do sources <- mapM get_source filenames
- foldM parse' ("prelude.forml" : filenames, [], [], []) (prelude' : sources)
+ (_, a, b, c) <- foldM parse' ("prelude.forml" : filenames, [], [], []) (prelude' : sources)
+ return $ (to_filename `fmap` ("prelude.forml" : filenames), a, b, c)
where parse' :: ([Filename], TypeSystem, [(Program, Source)], [Title]) -> String -> IO ([Filename], TypeSystem, [(Program, Source)], [Title])
parse' (zs, ts, as, titles) src'' =
@@ -105,7 +109,7 @@
compile rc =
- do (_, types, src', titles) <- parse_forml$ inputs rc
+ do (filenames, types, src', titles) <- parse_forml$ inputs rc
let src'' = O.run_optimizer (fmap fst src') types
let (js', tests') = gen_js (fmap snd src') src''
@@ -116,20 +120,21 @@
else do warn "Closure [libs]" js'
tests <- case rc of
- RunConfig { optimize = True, run_tests = Phantom } ->
- zipWithM (\title t -> monitor [qq|Closure {title}.spec.js |]$ closure_local t "SIMPLE_OPTIMIZATIONS") (drop 1 titles) (drop 1 tests')
- _ -> warn "Closure [tests]" tests'
+ RunConfig { optimize = True } ->
+ zipWithM (\title t -> monitor [qq|Closure {title}.spec.js |]$ closure_local t "SIMPLE_OPTIMIZATIONS") (drop 1 filenames) (drop 1 tests')
+ _ -> warn "Closure [tests]" (drop 1 tests')
+
writeFile (output rc ++ ".js") js
zipWithM writeFile (map (++ ".spec.js") titles) tests
if write_docs rc
then let programs = map fst (drop 1 src')
sources = map snd (drop 1 src')
- in do docs js tests (drop 1 titles) programs sources
+ in do docs js tests (drop 1 filenames) (drop 1 titles) programs sources
else monitor "Docs" $ return $ Right ()
- sequence (zipWith (test rc js) (drop 1 titles) tests)
+ sequence (zipWith (test rc js) (drop 1 filenames) tests)
if (show_types rc)
then putStrLn ("\nTypes\n\n " ++ concat (map f types))
diff --git a/src/html/styles.css b/src/html/styles.css
--- a/src/html/styles.css
+++ b/src/html/styles.css
@@ -2,7 +2,7 @@
body {
padding:50px;
- font:14px/1.5 Lato, Helvetica, Arial, sans-serif;
+ font: 14px/1.5 Lato, Helvetica, Arial, sans-serif;
font-weight:300;
color:black;
}
@@ -10,7 +10,7 @@
h1, h2, h3, h4, h5, h6 {
color:#222;
margin:0 0 20px;
- font-family: Montserrat;
+ font-family: Montserrat, Helvetica;
}
p, ul, ol, table, pre, dl {
@@ -260,11 +260,9 @@
@media print, screen and (max-width: 480px) {
body {
padding:15px;
+ font-size: 10px;
}
- header ul {
- display:none;
- }
}
@media print {