/
Fay.hs
152 lines (140 loc) · 6.52 KB
/
Fay.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- | Main library entry point.
module Fay
(module Fay.Types
,compileFile
,compileFileWithState
,compileFromTo
,compileFromToAndGenerateHtml
,toJsName
,showCompileError
,getRuntime)
where
import Fay.Compiler
import Fay.Compiler.Misc (printSrcLoc)
import Fay.Compiler.Packages
import Fay.Types
import Control.Applicative
import Control.Monad
import Data.List
import Language.Haskell.Exts (prettyPrint)
import Language.Haskell.Exts.Syntax
import Paths_fay
import System.FilePath
-- | Compile the given file and write the output to the given path, or
-- if nothing given, stdout.
compileFromTo :: CompileConfig -> FilePath -> Maybe FilePath -> IO ()
compileFromTo config filein fileout = do
result <- maybe (compileFile config filein)
(compileFromToAndGenerateHtml config filein)
fileout
case result of
Right out -> maybe (putStrLn out) (`writeFile` out) fileout
Left err -> error $ showCompileError err
-- | Compile the given file and write to the output, also generate any HTML.
compileFromToAndGenerateHtml :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError String)
compileFromToAndGenerateHtml config filein fileout = do
result <- compileFile config { configFilePath = Just filein } filein
case result of
Right out -> do
when (configHtmlWrapper config) $
writeFile (replaceExtension fileout "html") $ unlines [
"<!doctype html>"
, "<html>"
, " <head>"
," <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"
, unlines . map ((" "++) . makeScriptTagSrc) $ configHtmlJSLibs config
, " " ++ makeScriptTagSrc relativeJsPath
, " </script>"
, " </head>"
, " <body>"
, " </body>"
, "</html>"]
return (Right out)
where relativeJsPath = makeRelative (dropFileName fileout) fileout
makeScriptTagSrc :: FilePath -> String
makeScriptTagSrc s = "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"
Left err -> return (Left err)
-- | Compile the given file.
compileFile :: CompileConfig -> FilePath -> IO (Either CompileError String)
compileFile config filein = either Left (Right . fst) <$> compileFileWithState config filein
-- | Compile a file returning the state.
compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,CompileState))
compileFileWithState config filein = do
runtime <- getRuntime
hscode <- readFile filein
raw <- readFile runtime
config' <- resolvePackages config
compileToModule filein config' raw (compileToplevelModule filein) hscode
-- | Compile the given module to a runnable module.
compileToModule :: (Show from,Show to,CompilesTo from to)
=> FilePath
-> CompileConfig -> String -> (from -> Compile to) -> String
-> IO (Either CompileError (String,CompileState))
compileToModule filepath config raw with hscode = do
result <- compileViaStr filepath config with hscode
return $ case result of
Left err -> Left err
Right (PrintState{..},state,_) ->
Right ( generateWrapped (concat $ reverse psOutput)
(stateModuleName state)
, state
)
where
generateWrapped jscode (ModuleName modulename) =
unlines $ filter (not . null)
[if configExportRuntime config then raw else ""
,jscode
,if not (configLibrary config)
then unlines [";"
,"Fay$$_(" ++ modulename ++ ".main);"
]
else ""
]
-- | Convert a Haskell filename to a JS filename.
toJsName :: String -> String
toJsName x = case reverse x of
('s':'h':'.': (reverse -> file)) -> file ++ ".js"
_ -> x
-- | Print a compile error for human consumption.
showCompileError :: CompileError -> String
showCompileError e = case e of
ParseError pos err -> err ++ " at line: " ++ show (srcLine pos) ++ " column: " ++ show (srcColumn pos)
UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d
UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es
UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr
UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p
UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i
UnsupportedLet -> "let not supported here"
UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d
UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit
UnsupportedModuleSyntax m -> "unsupported module syntax" ++ prettyPrint m
UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat
UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt
UnsupportedRecursiveDo -> "recursive `do' isn't supported"
UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs
UnsupportedWhereInAlt alt -> "`where' not supported here: " ++ prettyPrint alt
UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m
EmptyDoBlock -> "empty `do' block"
InvalidDoBlock -> "invalid `do' block"
FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d
FfiFormatBadChars srcloc cs -> printSrcLoc srcloc ++ ": invalid characters for FFI format string: " ++ show cs
FfiFormatNoSuchArg srcloc i -> printSrcLoc srcloc ++ ": no such argument in FFI format string: " ++ show i
FfiFormatIncompleteArg srcloc -> printSrcLoc srcloc ++ ": incomplete `%' syntax in FFI format string"
FfiFormatInvalidJavaScript srcloc code err ->
printSrcLoc srcloc ++ ":" ++
"\ninvalid JavaScript code in FFI format string:\n"
++ err ++ "\nin " ++ code
Couldn'tFindImport i places ->
"could not find an import in the path: " ++ prettyPrint i ++ ", \n" ++
"searched in these places: " ++ intercalate ", " places
UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname
GHCError s -> "ghc: " ++ s
-- | Get the JS runtime source.
getRuntime :: IO String
getRuntime = getDataFileName "js/runtime.js"