module Tip.Haskell.Rename (renameDecls, isOperator, RenameMap) where
#include "errors.h"
import Tip.Haskell.Repr
import Tip.Haskell.Translate
import Tip.Utils.Rename
import Tip.Pretty
import Data.Set (Set)
import qualified Data.Set as S
import Data.Map (Map)
import qualified Data.Map as M
import Data.Char
import qualified Data.Foldable as F
type RenameMap a = Map (HsId a) (HsId String)
renameDecls :: forall a . (Ord a,PrettyVar a) => Decls (HsId a) -> (Decls (HsId String),RenameMap a)
renameDecls ds = runRenameM suggest blocks M.empty (rename ds)
where
blocks = map Other (keywords ++ map snd hsBuiltins ++ exacts)
exacts :: [String]
exacts = [ s | Exact s <- F.toList ds ]
++ [ s | Qualified _ _ s <- F.toList ds ]
suggest :: HsId a -> [HsId String]
suggest (Qualified m ms s) = Qualified m ms s:__
suggest (Exact s) = Exact s:__
suggest i
| i `S.member` us = map (Other . upper) (disambigHs (makeUniform (varStr i)))
| otherwise = map (Other . lower) (disambigHs (makeUniform (varStr i)))
us = uppercase ds
uppercase :: Ord a => Decls a -> Set a
uppercase (Decls ds) = S.fromList $
[ x | TypeDef (TyCon x _) _ <- ds ] ++
[ x | DataDecl x _ _ _ <- ds ] ++
[ x | DataDecl _ _ cons _ <- ds, (x,_) <- cons ]
makeUniform :: String -> String
makeUniform s
| couldBeOperator s = filter (`elem` opSyms) s
| otherwise = initialAlpha (filter isAlphaNum s)
initialAlpha :: String -> String
initialAlpha s@(c:_) | isAlpha c = s
| otherwise = 'x':s
disambigHs :: String -> [String]
disambigHs s
| isOperator s = s : [ s ++ replicate n '.' | n <- [1..] ]
| otherwise = disambig id s
upper :: String -> String
upper s@(c:r)
| isOperator s = if c == ':' then s else ':':s
| otherwise = if isUpper c then s else toUpper c:r
lower :: String -> String
lower s@(c:r)
| isOperator s = if c == ':' then r else s
| otherwise = if isLower c then s else toLower c:r
isOperator :: String -> Bool
isOperator = all (`elem` opSyms)
couldBeOperator :: String -> Bool
couldBeOperator s = i2d (numOps s) / i2d (length s) >= 0.5
where
i2d :: Int -> Double
i2d = fromInteger . toInteger
numOps :: String -> Int
numOps = length . filter (`elem` opSyms)
opSyms :: String
opSyms = "!#$%&*+./<=>?@\\^|-~:"
keywords :: [String]
keywords =
[ "!"
, "'"
, "''"
, "-"
, "--"
, "-<"
, "-<<"
, "->"
, "::"
, ";"
, "<-"
, ","
, "="
, "=>"
, ">"
, "?"
, "#"
, "*"
, "@"
, "\\"
, "_"
, "`"
, "|"
, "~"
, "as"
, "case", "of"
, "class"
, "data"
, "family"
, "instance"
, "default"
, "deriving"
, "do"
, "forall"
, "foreign"
, "hiding"
, "if", "then", "else"
, "import"
, "infix", "infixl", "infixr"
, "let", "in"
, "mdo"
, "module"
, "newtype"
, "proc"
, "qualified"
, "rec"
, "type"
, "family"
, "where"
]