gistfile1.hs

{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
module Main where

import           Language.Lua.Parser
import           Language.Lua.Types

import qualified Language.ECMAScript3.Syntax       as JS
import           Language.ECMAScript3.PrettyPrint  (renderExpression)

import           System.Environment                (getArgs)
import           Control.Monad
import           Prelude                           hiding (exp)

unsupported :: Show a => a -> b
unsupported = error . ("unsupported exp: " ++) . show

class ToJsExp a where
    toJsExp :: a -> JS.Expression ()

instance ToJsExp (Exp a) where
    toJsExp (Nil _) = JS.NullLit ()
    toJsExp (Bool _ bool) = JS.BoolLit () bool
    toJsExp (Number _ num) = JS.NumLit () (read num)
    toJsExp (String _ str) = JS.StringLit () str
    toJsExp (TableConst _ table) = toJsExp table
    toJsExp unsupportedexp = unsupported (fmap (const ()) unsupportedexp)

instance ToJsExp (Table a) where
    toJsExp (Table _ fields)
      | all arrField fields =
          JS.ArrayLit () $ map (\(Field _ exp) -> toJsExp exp) fields
      | all objField fields =
          JS.ObjectLit () $ map (\(NamedField _ (Name _ name) exp) -> (JS.PropId () (JS.Id () name), toJsExp exp)) fields
      | otherwise = unsupported (map (fmap (const ())) fields)

      where
        arrField Field{} = True
        arrField _       = False

        objField NamedField{} = True
        objField _            = False

main :: IO ()
main = do
    args <- getArgs
    contents <- readFile (head args)
    case parseText exp contents of
      Left err -> print err
      Right result -> putStrLn $ renderExpression $ toJsExp result