git.iko.soy/Idris-dev
on ef93607 help sign in
Idris-dev/src/IRTS/Java/Mangling.hs
108 lines 4.2 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
22prefixCallNamespaces :: Ident -> SDecl -> SDecl
23prefixCallNamespaces name (SFun fname args i e) =
24 SFun fname args i (prefixCallNamespacesExp name e)
25 where
26 prefixCallNamespacesExp :: Ident -> SExp -> SExp
27 prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) =
28 SApp tail (NS n (name:ns)) args
29 prefixCallNamespacesExp name (SLet var e1 e2) =
30 SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2)
31 prefixCallNamespacesExp name (SUpdate var e) =
32 SUpdate var (prefixCallNamespacesExp name e)
33 prefixCallNamespacesExp name (SCase var alts) =
34 SCase var (map (prefixCallNamespacesCase name) alts)
35 prefixCallNamespacesExp name (SChkCase var alts) =
36 SChkCase var (map (prefixCallNamespacesCase name) alts)
37 prefixCallNamespacesExp _ exp = exp
39 prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
40 prefixCallNamespacesCase name (SConCase x y n ns e) =
41 SConCase x y n ns (prefixCallNamespacesExp name e)
42 prefixCallNamespacesCase name (SConstCase c e) =
43 SConstCase c (prefixCallNamespacesExp name e)
44 prefixCallNamespacesCase name (SDefaultCase e) =
45 SDefaultCase (prefixCallNamespacesExp name e)
47liftParsed :: (Show e, MonadError String m) => Either e a -> m a
48liftParsed = either (\ err -> throwError $ "Parser error: " ++ (show err))
49 (return)
51mkClassName :: (MonadError String m) => FilePath -> m Ident
52mkClassName path =
53 liftParsed . parser ident . takeBaseName $ takeFileName path
55mangleWithPrefix :: (Applicative m, MonadError String m) => String -> Name -> m Ident
56mangleWithPrefix prefix (NS name _) = mangleWithPrefix prefix name
57mangleWithPrefix prefix (MN i name) =
58 (\ (Ident x) -> Ident $ x ++ ('_' : show i))
59 <$> mangleWithPrefix prefix (UN name)
60mangleWithPrefix prefix (UN name) =
61 liftParsed
62 . parser ident
63 . (prefix ++)
64 . cleanNonLetter
65 $ cleanWs False name
66 where
67 cleanNonLetter (x:xs)
68 | x == '#' = "_Hash" ++ cleanNonLetter xs
69 | x == '@' = "_At" ++ cleanNonLetter xs
70 | x == '$' = "_Dollar" ++ cleanNonLetter xs
71 | x == '!' = "_Bang" ++ cleanNonLetter xs
72 | x == '.' = "_Dot" ++ cleanNonLetter xs
73 | x == '\'' = "_Prime" ++ cleanNonLetter xs
74 | x == '*' = "_Times" ++ cleanNonLetter xs
75 | x == '+' = "_Plus" ++ cleanNonLetter xs
76 | x == '/' = "_Divide" ++ cleanNonLetter xs
77 | x == '-' = "_Minus" ++ cleanNonLetter xs
78 | x == '%' = "_Mod" ++ cleanNonLetter xs
79 | x == '<' = "_LessThan" ++ cleanNonLetter xs
80 | x == '=' = "_Equals" ++ cleanNonLetter xs
81 | x == '>' = "_MoreThan" ++ cleanNonLetter xs
82 | x == '[' = "_LSBrace" ++ cleanNonLetter xs
83 | x == ']' = "_RSBrace" ++ cleanNonLetter xs
84 | x == '(' = "_LBrace" ++ cleanNonLetter xs
85 | x == ')' = "_RBrace" ++ cleanNonLetter xs
86 | x == '_' = "__" ++ cleanNonLetter xs
87 | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
88 | otherwise = x:cleanNonLetter xs
89 cleanNonLetter [] = []
90 cleanWs capitalize (x:xs)
91 | isSpace x = cleanWs True xs
92 | capitalize = (toUpper x) : (cleanWs False xs)
93 | otherwise = x : (cleanWs False xs)
94 cleanWs _ [] = []
96mangle :: (Applicative m, MonadError String m) => Name -> m Ident
97mangle = mangleWithPrefix "__IDRCG__"
99mangle' :: Name -> Ident
100mangle' = either error id . mangleWithPrefix "__IDRCG__"
102mangleFull :: (Applicative m, MonadError String m) => Name -> m J.Name
103mangleFull (NS name (rootns:nss)) =
104 (\ r n ns -> J.Name (r:(ns ++ [n])))
105 <$> mangleWithPrefix "" (UN rootns)
106 <*> mangle name
107 <*> mapM (mangle . UN) nss
108mangleFull n = J.Name . (:[]) <$> mangle n