forml 0.1.2 → 0.1.3
raw patch · 17 files changed
+289/−397 lines, 17 filesdep +GraphSCCdep ~containersdep ~jmacro
Dependencies added: GraphSCC
Dependency ranges changed: containers, jmacro
Files
- forml.cabal +4/−3
- src/forml/prelude.forml +57/−15
- src/forml/readme.forml +45/−18
- src/forml/tests.forml +9/−0
- src/hs/Forml/CLI.hs +1/−1
- src/hs/Forml/Closure.hs +1/−1
- src/hs/Forml/Doc.hs +7/−7
- src/hs/Forml/Parser/Utils.hs +13/−2
- src/hs/Forml/TypeCheck.hs +53/−88
- src/hs/Forml/TypeCheck/Types.hs +38/−211
- src/hs/Forml/Types/Expression.hs +34/−26
- src/hs/Forml/Types/Literal.hs +1/−1
- src/hs/Forml/Types/Namespace.hs +1/−1
- src/hs/Forml/Types/Pattern.hs +7/−8
- src/hs/Forml/Types/Statement.hs +1/−1
- src/hs/Main.hs +14/−9
- src/html/styles.css +3/−5
forml.cabal view
@@ -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,
src/forml/prelude.forml view
@@ -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]
src/forml/readme.forml view
@@ -6,8 +6,6 @@ -- $("header h1").after('<br style="clear: both;"/>'); -- $("h1").css("font-family", "Montserrat"); -- $("header h1:first-letter").css("color", "#E53007");-- -- </script> -- 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)+
src/forml/tests.forml view
@@ -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"
src/hs/Forml/CLI.hs view
@@ -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
src/hs/Forml/Closure.hs view
@@ -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"
src/hs/Forml/Doc.hs view
@@ -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|<script>$js $tests</script>|] hook = [qq|<script>$htmljs;window.document.title='{title}';$('header h1').html('{title}')</script>|] - 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"
src/hs/Forml/Parser/Utils.hs view
@@ -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
src/hs/Forml/TypeCheck.hs view
@@ -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)
src/hs/Forml/TypeCheck/Types.hs view
@@ -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)
src/hs/Forml/Types/Expression.hs view
@@ -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])
src/hs/Forml/Types/Literal.hs view
@@ -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))
src/hs/Forml/Types/Namespace.hs view
@@ -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)`] |]
src/hs/Forml/Types/Pattern.hs view
@@ -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"
src/hs/Forml/Types/Statement.hs view
@@ -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
src/hs/Main.hs view
@@ -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))
src/html/styles.css view
@@ -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 {