formal-0.1.0: src/hs/Main.hs
{-# LANGUAGE FlexibleContexts, NamedFieldPuns, OverlappingInstances,
QuasiQuotes, RankNTypes, RecordWildCards, TemplateHaskell,
TupleSections, ViewPatterns #-}
module Main(main) where
import Text.InterpolatedString.Perl6
import Control.Applicative
import Control.Monad.State hiding (lift)
import System.Directory
import System.Environment
import System.Exit
import System.IO
import System.Process
import Control.Concurrent
import Text.Pandoc
import Data.Char (isAscii, ord)
import Data.List as L
import Data.Monoid
import Data.String.Utils
import Formal.Closure
import Formal.Javascript
import Formal.Javascript.Backend
import Formal.Javascript.Utils (prelude)
import Formal.Parser
import Formal.TypeCheck hiding (split)
import Formal.Types.Statement
import Formal.CLI
import qualified Formal.Optimize as O
import qualified Data.ByteString.Char8 as B
import Data.FileEmbed
toEntities :: String -> String
toEntities [] = ""
toEntities (c:cs) | isAscii c = c : toEntities cs
| otherwise = [qq|&#{ord c};{toEntities cs}|]
toHTML :: String -> String
toHTML = toEntities . writeHtmlString defaultWriterOptions . readMarkdown defaultParserState
to_literate :: String -> String -> String
to_literate filename
| (head . tail . split "." $ filename) == "formal" = unlines . map l . lines
| otherwise = id
where l (lstrip -> '-':'-':xs) = lstrip xs
l x = " " ++ x
to_parsed :: String -> String -> TypeSystem -> Either [String] (TypeSystem, (Program, String))
to_parsed name src env = case parseFormal name src of
Left x -> Left [show x]
Right x -> case tiProgram x env of
(as, []) -> Right (as, (x, src))
(_, y) -> Left y
parse_formal :: [String] -> IO ([String], TypeSystem, [(Program, String)])
parse_formal xs = foldM parse' (xs, [], []) xs
where parse' :: ([String], TypeSystem, [(Program, String)]) -> String -> IO ([String], TypeSystem, [(Program, String)])
parse' (zs, ts, as) filename = do hFile <- openFile filename ReadMode
src <- hGetContents hFile
let src' = to_literate filename . (++ "\n") $ src
(ts', as') <- monitor [qq|Loading $filename|] $ return$ to_parsed (head zs) src' ts
return (tail zs, ts ++ ts', as ++ [as'])
gen_js :: [String] -> [Program] -> (String, [(String, String)])
gen_js src p = (compress (read' prelude ++ "\n" ++ (unlines $ map read' $ zipWith (render (Program $ get_program p)) src p)), [("", read' prelude ++ "\n" ++ (unlines $ map read' $ zipWith (render_spec (Program $ get_program p)) src p))])
read' :: [Char] -> [Char]
read' xs @ ('"':_) = read xs
read' x = x
get_program :: [Program] -> [Statement]
get_program (Program ss: ps) = ss ++ get_program ps
get_program [] = []
main :: IO ()
main = do args <- getArgs
main' args
main' :: [String] -> IO ()
main' (parseArgs -> rc') =
if watch rc'
then watch' rc'
else compile rc'
where f (x, y) = show x ++ "\n " ++ concat (L.intersperse "\n " (map show y)) ++ "\n\n "
jquery = $(embedFile "lib/js/jquery.js")
header = $(embedFile "src/html/header.html")
footer = $(embedFile "src/html/footer.html")
jasmine = $(embedFile "lib/js/jasmine-1.0.1/jasmine.js")
`mappend` $(embedFile "lib/js/jasmine-1.0.1/jasmine-html.js")
console = "prelude.html.console_runner()"
report = $(embedFile "src/js/FormalReporter.js")
htmljs = "$('#run_tests').click(prelude.html.table_of_contents)"
watch' rc =
do x <- mapM getModificationTime . inputs $ rc
compile rc
putStr "Waiting ..."
hFlush stdout
wait rc x
wait rc x =
do threadDelay 1000
x' <- mapM getModificationTime . inputs $ rc
if x /= x' then do putStr "\r"
watch' rc
else wait rc x
compile rc =
do (_, as, src') <- parse_formal$ inputs rc
let src'' = O.run_optimizer (fmap fst src') as
let (js', ((_, tests'):_)) = gen_js (fmap snd src') src''
js <- if optimize rc
then (monitor "Closure [libs"$ closure_local (js') "ADVANCED_OPTIMIZATIONS")
else do warn "Closure [libs]" js'
tests <- case rc of
RunConfig { optimize = True, run_tests = Phantom } ->
monitor "Closure [tests"$ closure_local (tests') "SIMPLE_OPTIMIZATIONS"
_ -> warn "Closure [tests]" tests'
writeFile (output rc ++ ".js") js
writeFile (output rc ++ ".spec.js") tests
monitor "Docs" $
if write_docs rc
then let xxx = map fst src'
yyy = map snd src'
html' xxx' yyy' = highlight (case xxx' of (Program xs) -> get_tests xs)$ toHTML (annotate_tests yyy' xxx')
html = concat $ zipWith html' xxx yyy
prelude' = "<script>" ++ B.unpack jasmine ++ B.unpack report ++ js ++ tests ++ "</script>"
hook = "<script>" ++ htmljs ++ "</script>"
in do writeFile ((output rc) ++ ".html") (B.unpack header ++ prelude' ++ html ++ hook ++ B.unpack footer)
return $ Right ()
else return $ Right ()
case run_tests rc of
Node ->
monitor "Testing [Node.js]"$
do (Just std_in, Just std_out, _, p) <-
createProcess (proc "node" []) { std_in = CreatePipe, std_out = CreatePipe }
forkIO $ do errors <- hGetContents std_out
putStr errors
hFlush stdout
hPutStrLn std_in$ B.unpack jasmine
hPutStrLn std_in$ js ++ "\n\n"
hPutStrLn std_in$ tests
hPutStrLn std_in$ console
z <- waitForProcess p
case z of
ExitFailure _ -> return$ Left []
ExitSuccess -> if (show_types rc)
then Right <$> putStrLn ("\nTypes\n\n " ++ concat (map f as))
else return$ Right ()
Phantom ->
monitor "Testing [Phantom.js]"$
do writeFile (output rc ++ ".phantom.js")
(B.unpack jquery ++ B.unpack jasmine ++ js ++ tests ++ console)
(Just std_in, Just std_out, _, p) <-
createProcess (proc "phantomjs" [output rc ++ ".phantom.js"]) { std_in = CreatePipe, std_out = CreatePipe }
forkIO $ do errors <- hGetContents std_out
putStr errors
hFlush stdout
z <- waitForProcess p
system$ "rm " ++ output rc ++ ".phantom.js"
case z of
ExitFailure _ -> return$ Left []
ExitSuccess -> if (show_types rc)
then Right <$> putStrLn ("\nTypes\n\n " ++ concat (map f as))
else return$ Right ()
NoTest ->
do warn "Testing" ()
if (show_types rc)
then putStrLn$ "\nTypes\n\n " ++ concat (map f as)
else return ()