@@ -325,11 +325,16 @@ translateName NErased = ""
325325
326326translateSpecialName :: SpecialName -> String
327327translateSpecialName name
328− | WhereN i m n <- name = translateName m ++ translateName n ++ show i
329− | InstanceN n s <- name = translateName n ++ concatMap translateIdentifier s
330− | ParentN n s <- name = translateName n ++ translateIdentifier s
331− | MethodN n <- name = translateName n
332− | CaseN n <- name = translateName n
328+ | WhereN i m n <- name =
329+ "_where" ++ show i ++ "_" ++ translateName m ++ translateName n
330+ | InstanceN n s <- name =
331+ "_inst_" ++ translateName n ++ concatMap translateIdentifier s
332+ | ParentN n s <- name =
333+ "_parent_" ++ translateName n ++ translateIdentifier s
334+ | MethodN n <- name =
335+ "_meth_" ++ translateName n
336+ | CaseN n <- name =
337+ "_case_" ++ translateName n
333338
334339translateConstant :: Const -> JS
335340translateConstant (I i) = JSNum (JSInt i)
@@ -626,59 +631,9 @@ translateExpression (SError msg) =
626631translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
627632 jsCall (idrRTNamespace ++ "print") [JSVar var]
628633
629−translateExpression (SForeign _ _ fun args)
630− | "[]=" `isSuffixOf` fun
631− , (obj:idx:val:[]) <- args =
632− JSRaw $ concat [object obj, index idx, assign val]
633−
634− | "[]" `isSuffixOf` fun
635− , (obj:idx:[]) <- args =
636− JSRaw $ object obj ++ index idx
637−
638− | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
639− , (obj:val:[]) <- args =
640− JSRaw $ concat [object obj, '[' : name ++ "]", assign val]
641−
642− | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
643− , (obj:[]) <- args =
644− JSRaw $ object obj ++ '[' : name ++ "]"
645−
646− | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
647− , (obj:val:[]) <- args =
648− JSRaw $ concat [object obj, field, assign val]
649−
650− | "." `isPrefixOf` fun
651− , (obj:[]) <- args =
652− JSRaw $ object obj ++ field
653−
654− | "." `isPrefixOf` fun
655− , (obj:[(FUnit, _)]) <- args =
656− JSRaw $ concat [object obj, method, "()"]
657−
658− | "." `isPrefixOf` fun
659− , (obj:as) <- args =
660− JSRaw $ concat [object obj, method, arguments as]
661−
662− | "[]=" `isSuffixOf` fun
663− , (idx:val:[]) <- args =
664− JSRaw $ concat [array, index idx, assign val]
665−
666− | "[]" `isSuffixOf` fun
667− , (idx:[]) <- args =
668− JSRaw $ array ++ index idx
669−
670− | otherwise = JSRaw $ fun ++ arguments args
634+translateExpression (SForeign _ _ fun args) =
635+ ffi fun (map generateWrapper args)
671636 where
672− name = filter (`notElem` "[]=") fun
673− method = name
674− field = name
675− array = name
676− object o = translateVariableName (snd o)
677− index i = "[" ++ translateVariableName (snd i) ++ "]"
678− assign v = '=' : generateWrapper v
679− arguments as =
680− '(' : intercalate "," (map generateWrapper as) ++ ")"
681−
682637 generateWrapper (ffunc, name)
683638 | FFunction <- ffunc =
684639 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
@@ -727,6 +682,37 @@ translateExpression SNothing = JSNull
727682translateExpression e =
728683 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
729684
685+data FFI = FFICode Char | FFIArg Int | FFIError String
686+
687+ffi :: String -> [String] -> JS
688+ffi code args = let parsed = ffiParse code in
689+ case ffiError parsed of
690+ Just err -> JSError err
691+ Nothing -> JSRaw $ renderFFI parsed args
692+ where
693+ ffiParse :: String -> [FFI]
694+ ffiParse "" = []
695+ ffiParse ['%'] = [FFIError "Invalid positional argument"]
696+ ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
697+ ffiParse ('%':s:ss)
698+ | isDigit s =
699+ FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
700+ | otherwise =
701+ [FFIError "Invalid positional argument"]
702+ ffiParse (s:ss) = FFICode s : ffiParse ss
703+
704+ ffiError :: [FFI] -> Maybe String
705+ ffiError [] = Nothing
706+ ffiError ((FFIError s):xs) = Just s
707+ ffiError (x:xs) = ffiError xs
708+
709+ renderFFI :: [FFI] -> [String] -> String
710+ renderFFI [] _ = ""
711+ renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
712+ renderFFI ((FFIArg i) : fs) args
713+ | i < length args && i >= 0 = args !! i ++ renderFFI fs args
714+ | otherwise = "Argument index out of bounds"
715+
730716data CaseType = ConCase Int
731717 | TypeCase JSType
732718 | DefaultCase