git.iko.soy/Idris-dev
on d1663cc help sign in
Idris-dev/src/IRTS/Java/Mangling.hs
113 lines 4.5 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
4module IRTS.Java.Mangling where
6import Core.TT
7import IRTS.Lang
8import IRTS.Simplified
10import Control.Applicative
11import Control.Monad
12import Control.Monad.Error
13import Data.Char
15import Language.Java.Parser
16import Language.Java.Pretty
17import Language.Java.Syntax hiding (Name)
18import qualified Language.Java.Syntax as J
20import System.FilePath
21import Debug.Trace
23prefixCallNamespaces :: Ident -> SDecl -> SDecl
24prefixCallNamespaces name (SFun fname args i e) =
25 SFun fname args i (prefixCallNamespacesExp name e)
26 where
27 prefixCallNamespacesExp :: Ident -> SExp -> SExp
28 prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) =
29 SApp tail (NS n (name:ns)) args
30 prefixCallNamespacesExp name (SLet var e1 e2) =
31 SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2)
32 prefixCallNamespacesExp name (SUpdate var e) =
33 SUpdate var (prefixCallNamespacesExp name e)
34 prefixCallNamespacesExp name (SCase var alts) =
35 SCase var (map (prefixCallNamespacesCase name) alts)
36 prefixCallNamespacesExp name (SChkCase var alts) =
37 SChkCase var (map (prefixCallNamespacesCase name) alts)
38 prefixCallNamespacesExp _ exp = exp
40 prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
41 prefixCallNamespacesCase name (SConCase x y n ns e) =
42 SConCase x y n ns (prefixCallNamespacesExp name e)
43 prefixCallNamespacesCase name (SConstCase c e) =
44 SConstCase c (prefixCallNamespacesExp name e)
45 prefixCallNamespacesCase name (SDefaultCase e) =
46 SDefaultCase (prefixCallNamespacesExp name e)
48liftParsed :: (Show e, MonadError String m) => Either e a -> m a
49liftParsed = either (\ err -> throwError $ "Parser error: " ++ (show err))
50 (return)
52mkClassName :: (MonadError String m) => FilePath -> m Ident
53mkClassName path =
54 liftParsed . parser ident . takeBaseName $ takeFileName path
56mangleWithPrefix :: (Applicative m, MonadError String m) => String -> Name -> m Ident
57mangleWithPrefix prefix (NS name _) = mangleWithPrefix prefix name
58mangleWithPrefix prefix (MN i name) =
59 (\ (Ident x) -> Ident $ x ++ ('_' : show i))
60 <$> mangleWithPrefix prefix (UN name)
61mangleWithPrefix prefix (UN name) =
62 liftParsed
63 . parser ident
64 . (prefix ++)
65 . cleanNonLetter
66 $ cleanWs False name
67 where
68 cleanNonLetter (x:xs)
69 | x == '#' = "_Hash" ++ cleanNonLetter xs
70 | x == '@' = "_At" ++ cleanNonLetter xs
71 | x == '$' = "_Dollar" ++ cleanNonLetter xs
72 | x == '!' = "_Bang" ++ cleanNonLetter xs
73 | x == '.' = "_Dot" ++ cleanNonLetter xs
74 | x == '\'' = "_Prime" ++ cleanNonLetter xs
75 | x == '*' = "_Times" ++ cleanNonLetter xs
76 | x == '+' = "_Plus" ++ cleanNonLetter xs
77 | x == '/' = "_Divide" ++ cleanNonLetter xs
78 | x == '-' = "_Minus" ++ cleanNonLetter xs
79 | x == '%' = "_Mod" ++ cleanNonLetter xs
80 | x == '<' = "_LessThan" ++ cleanNonLetter xs
81 | x == '=' = "_Equals" ++ cleanNonLetter xs
82 | x == '>' = "_MoreThan" ++ cleanNonLetter xs
83 | x == '[' = "_LSBrace" ++ cleanNonLetter xs
84 | x == ']' = "_RSBrace" ++ cleanNonLetter xs
85 | x == '(' = "_LBrace" ++ cleanNonLetter xs
86 | x == ')' = "_RBrace" ++ cleanNonLetter xs
87 | x == ':' = "_Colon" ++ cleanNonLetter xs
88 | x == ' ' = "_Space" ++ cleanNonLetter xs
89 | x == ',' = "_Comma" ++ cleanNonLetter xs
90 | x == '_' = "__" ++ cleanNonLetter xs
91 | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
92 | otherwise = x:cleanNonLetter xs
93 cleanNonLetter [] = []
94 cleanWs capitalize (x:xs)
95 | isSpace x = cleanWs True xs
96 | capitalize = (toUpper x) : (cleanWs False xs)
97 | otherwise = x : (cleanWs False xs)
98 cleanWs _ [] = []
99mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (UN (showCG s))
101mangle :: (Applicative m, MonadError String m) => Name -> m Ident
102mangle = mangleWithPrefix "__IDRCG__"
104mangle' :: Name -> Ident
105mangle' = either error id . mangleWithPrefix "__IDRCG__"
107mangleFull :: (Applicative m, MonadError String m) => Name -> m J.Name
108mangleFull (NS name (rootns:nss)) =
109 (\ r n ns -> J.Name (r:(ns ++ [n])))
110 <$> mangleWithPrefix "" (UN rootns)
111 <*> mangle name
112 <*> mapM (mangle . UN) nss
113mangleFull n = J.Name . (:[]) <$> mangle n