gdritter repos telml / 3fc956d
rearrange it all Getty Ritter 1 year, 3 months ago
1 changed file(s) with 174 addition(s) and 98 deletion(s). Collapse all Expand all
+174
-98
telml-bin/src/Main.hs less more
1313 import qualified System.Console.GetOpt as Opt
1414 import qualified System.Environment as Sys
1515
16 data Options = Options
17 { optInputFile :: Maybe String,
18 optUseDefaultTags :: Bool,
19 optTagFile :: Maybe String
20 }
21 deriving (Eq, Show)
22
23 opts :: [Opt.OptDescr (Options -> Options)]
24 opts =
25 [ Opt.Option
26 ['n']
27 ["no-default-tags"]
28 (Opt.NoArg (\o -> o {optUseDefaultTags = False}))
29 "Do not include any default tags",
30 Opt.Option
31 ['t']
32 ["tags"]
33 (Opt.ReqArg (\f o -> o {optTagFile = Just f}) "[file]")
34 "The file of tag definitions to use"
35 ]
36
37 parseOpts :: IO Options
38 parseOpts = do
39 args <- Sys.getArgs
40 let def =
41 Options
42 { optInputFile = Nothing,
43 optUseDefaultTags = True,
44 optTagFile = Nothing
45 }
46 case Opt.getOpt Opt.Permute opts args of
47 (flags, [], []) ->
48 return (foldl (flip id) def flags)
49 (flags, [input], []) ->
50 return (foldl (flip id) def flags) {optInputFile = Just input}
51 (_, _, errors) ->
52 error (unlines errors)
16 -- | The main driver
17 main :: IO ()
18 main = do
19 -- parse command-line options
20 options <- parseOpts
21 -- read the source file
22 telmlSource <- case optInputFile options of
23 Nothing -> getContents
24 Just f -> readFile f
25 -- attempt to parse it
26 let telml = case TeLML.parse telmlSource of
27 Right str -> str
28 Left err -> error err
29 -- read the Lua source file, if provided
30 luaSource <- case optTagFile options of
31 Nothing -> return ""
32 Just f -> BS.readFile f
33 -- run everything needed in the Lua context (i.e. evaluating the
34 -- source and then using it to interpret tags)
35 result <- Lua.runEither (luaMain options luaSource telml)
36 -- either print the result or print the error nicely
37 case result of
38 Right msg -> Text.putStr msg
39 Left err -> putStrLn (Exn.displayException err)
40
41 -- * Lua stuff
42
43 -- | Everything in Lua should be in this monad, which includes our
44 -- custom error type
45 type LuaM r = Lua.LuaE Error r
46
47 -- | Evaluate the provided Lua source code and then use it to
48 -- interpret the `TeLML.Document`.
49 luaMain :: Options -> BS.ByteString -> TeLML.Document -> LuaM Text.Text
50 luaMain opts luaSource doc = do
51 -- load the basic libraries so we have access to stuff like `ipairs`
52 Lua.openbase
53 Lua.pop 1
54
55 -- create the global `telml` table as a namespace for tags
56 Lua.newtable
57 Lua.setglobal "telml"
58
59 -- evaluate the source file. (We don't care what it evaluates to.)
60 _ <- Lua.dostring luaSource
61
62 -- make sure that the user didn't do something funky like redefine
63 -- the global `telml` to a string.
64 telml <- Lua.getglobal "telml"
65 if telml /= Lua.TypeTable
66 then throw (RedefinedTable telml)
67 else return ()
68
69 -- walk over the document, evaluating as we go
70 handleDoc opts doc
71
72 -- | Convert a `TeLML.Document` into a piece of `Text`
73 handleDoc :: Options -> TeLML.Document -> LuaM Text.Text
74 handleDoc opts = fmap mconcat . sequence . map (handleFrag opts)
75
76 -- | Convert a `TeLML.Fragment` into a piece of `Text` with the
77 -- relevant tag evaluation
78 handleFrag :: Options -> TeLML.Fragment -> LuaM Text.Text
79 handleFrag _ (TeLML.TextFrag text) = return text
80 handleFrag opts (TeLML.TagFrag tag) = handleTag opts tag
81
82 -- | Evaluate a tag in light of both the Lua source and the provided
83 -- options
84 handleTag :: Options -> TeLML.Tag -> LuaM Text.Text
85 handleTag opts (TeLML.Tag n ps) = do
86 -- evaluate the "arguments" first
87 ps' <- mapM (handleDoc opts) ps
88 -- look up the tag in the table
89 Lua.pushstring (Text.encodeUtf8 n)
90 -- check the type of the thing we've gotten out. (If it wasn't
91 -- present in the table, we'll get `nil`.)
92 typ <- Lua.gettable 1
93 case typ of
94 Lua.TypeNil
95 -- Defer to the standard tags by default
96 | optUseDefaultTags opts -> standardTags n ps'
97 -- ...but if the user opted out, then throw errors
98 | otherwise -> throw (NoSuchTag n)
99 -- if it's a function, then we can call it!
100 Lua.TypeFunction -> do
101 -- it's already on the stack, so now we need to add all the
102 -- arguments to the stack. They're all strings, so push the
103 -- appropriate bytestrings there
104 mapM_ (Lua.pushstring . Text.encodeUtf8) ps'
105 -- Call the function with the number of args we've passed, and
106 -- expect a single return value
107 Lua.call (Lua.NumArgs (fromIntegral (length ps'))) 1
108 -- look at the top thing on the stack to make sure it's a string
109 -- (or convertible)
110 result <- Lua.tostring 2
111 case result of
112 -- if we got `Nothing`, then it's not a string; throw an error
113 Nothing -> do
114 actualtyp <- Lua.ltype 2
115 throw (NotAString n actualtyp)
116 -- otherwise, it's a string, so pass it back down!
117 Just r -> do
118 Lua.pop 1
119 return (Text.decodeUtf8 r)
120 -- if it's not `nil` _or_ a function, then produce an error about
121 -- it
122 _ -> throw (NotAFunction n typ)
123
124 -- * Errors and error-handling
125
126 -- We wrap the usual LuaHS error type in our own
53127
54128 data Error
55129 = LuaError Lua.Exception
57131 deriving (Show)
58132
59133 instance Exn.Exception Error where
134 -- did you know this tries to use `show` by default? I really wish
135 -- Haskell had something like the str/repr distinction or
136 -- debug/display distinction. Trying to force every string
137 -- representation into `show` is nonsense.
60138 displayException (LuaError err) = Exn.displayException err
61139 displayException (TeLMLError err) = Exn.displayException err
62140
141 -- We need this in order to use our custom error type as a wrapper
142 -- around Lua ones
63143 instance Lua.LuaError Error where
64144 popException = do
65145 err <- Lua.changeErrorType Lua.popException
73153
74154 luaException = LuaError . Lua.luaException
75155
76 type LuaM r = Lua.LuaE Error r
77
156 -- | A function that makes it easy to throw our own exceptions
78157 throw :: Exn.Exception e => e -> LuaM a
79158 throw =
80159 Lua.liftIO . Exn.throwIO . TeLMLError . Exn.toException
81160
82 main :: IO ()
83 main = do
84 options <- parseOpts
85 telmlSource <- case optInputFile options of
86 Nothing -> getContents
87 Just f -> readFile f
88 let telml = case TeLML.parse telmlSource of
89 Right str -> str
90 Left err -> error err
91 luaSource <- case optTagFile options of
92 Nothing -> return ""
93 Just f -> BS.readFile f
94 result <- Lua.runEither (luaMain luaSource telml)
95 case result of
96 Right msg -> Text.putStr msg
97 Left err -> putStrLn (Exn.displayException err)
98 return ()
99
100 luaMain :: BS.ByteString -> TeLML.Document -> LuaM Text.Text
101 luaMain luaSource doc = do
102 Lua.openbase
103 Lua.pop 1
104
105 Lua.newtable
106 Lua.setglobal "telml"
107 _ <- Lua.dostring luaSource
108 telml <- Lua.getglobal "telml"
109 if telml /= Lua.TypeTable
110 then throw (RedefinedTable telml)
111 else return ()
112 handleDoc doc
113
161 -- ** Custom errors
162
163 -- | This represents when a builtin tag expects a specific arity and
164 -- we invoke it with the wrong one
114165 data BuiltinArityMismatch = BuiltinArityMismatch
115166 { bamExpected :: Int,
116167 bamProvided :: Int,
129180 show (bamProvided bam)
130181 ]
131182
183 -- | This is thrown when we can't find any tag with the relevant name
132184 data NoSuchTag = NoSuchTag {nstName :: Text.Text} deriving (Show)
133185
134186 instance Exn.Exception NoSuchTag where
135187 displayException nst =
136188 "No such tag: `" ++ Text.unpack (nstName nst) ++ "`"
137189
190 -- | This is thrown when the Lua defined something with this name, but
191 -- it wasn't actually a function we could call
138192 data NotAFunction = NotAFunction
139193 {nafName :: Text.Text, nafActual :: Lua.Type}
140194 deriving (Show)
149203 " instead"
150204 ]
151205
206 -- | This is thrown when we call a Lua function and it returns
207 -- something which either isn't a string or isn't trivially
208 -- convertable to a string (like a number).
152209 data NotAString = NotAString
153210 {nasName :: Text.Text, nasActual :: Lua.Type}
154211 deriving (Show)
163220 " instead"
164221 ]
165222
223 -- | This is thrown if the code for some reason tries to redefine
224 -- `telml` into something that's not a table.
166225 data RedefinedTable = RedefinedTable
167226 {rtType :: Lua.Type}
168227 deriving (Show)
175234 " instead"
176235 ]
177236
237 -- | Print a Lua type nicely (for error message purposes)
178238 ppType :: Lua.Type -> String
179239 ppType Lua.TypeNil = "nil"
180240 ppType Lua.TypeBoolean = "boolean"
187247 ppType Lua.TypeThread = "thread"
188248 ppType Lua.TypeNone = "something unspeakable"
189249
250 -- * Tag definitions
251
252 -- | Try to interpret this tag from the standard set, throwing an
253 -- error if it doesn't exist
190254 standardTags :: Text.Text -> [Text.Text] -> LuaM Text.Text
191255 standardTags n ps =
192256 case n of
224288 simpleTag _ [item] result = pure (result item)
225289 simpleTag name items _ = throw (BuiltinArityMismatch 1 (length items) name)
226290
227 handleDoc :: TeLML.Document -> LuaM Text.Text
228 handleDoc = fmap mconcat . sequence . map handleFrag
229
230 handleFrag :: TeLML.Fragment -> LuaM Text.Text
231 handleFrag (TeLML.TextFrag text) = return text
232 handleFrag (TeLML.TagFrag tag) = handleTag tag
233
234 handleTag :: TeLML.Tag -> LuaM Text.Text
235 handleTag (TeLML.Tag n ps) = do
236 -- evaluate the "arguments" first
237 ps' <- mapM handleDoc ps
238 Lua.pushstring (Text.encodeUtf8 n)
239 typ <- Lua.gettable 1
240 case typ of
241 Lua.TypeNil -> standardTags n ps'
242 Lua.TypeFunction -> do
243 mapM_ (Lua.pushstring . Text.encodeUtf8) ps'
244 Lua.call (Lua.NumArgs (fromIntegral (length ps'))) 1
245 result <- Lua.tostring 2
246 case result of
247 Nothing -> do
248 actualtyp <- Lua.ltype 2
249 throw (NotAString n actualtyp)
250 Just r -> do
251 Lua.pop 1
252 return (Text.decodeUtf8 r)
253 _ -> throw (NotAFunction n typ)
291 -- * Options and option-parsing
292
293 data Options = Options
294 { optInputFile :: Maybe String,
295 optUseDefaultTags :: Bool,
296 optTagFile :: Maybe String
297 }
298 deriving (Eq, Show)
299
300 optionDescriptions :: [Opt.OptDescr (Options -> Options)]
301 optionDescriptions =
302 [ Opt.Option
303 ['n']
304 ["no-default-tags"]
305 (Opt.NoArg (\o -> o {optUseDefaultTags = False}))
306 "Do not include any default tags",
307 Opt.Option
308 ['t']
309 ["tags"]
310 (Opt.ReqArg (\f o -> o {optTagFile = Just f}) "[file]")
311 "The file of tag definitions to use"
312 ]
313
314 parseOpts :: IO Options
315 parseOpts = do
316 args <- Sys.getArgs
317 let def =
318 Options
319 { optInputFile = Nothing,
320 optUseDefaultTags = True,
321 optTagFile = Nothing
322 }
323 case Opt.getOpt Opt.Permute optionDescriptions args of
324 (flags, [], []) ->
325 return (foldl (flip id) def flags)
326 (flags, [input], []) ->
327 return (foldl (flip id) def flags) {optInputFile = Just input}
328 (_, _, errors) ->
329 error (unlines errors)