module Language.Modulo.Rename (
addParams,
rename
) where
import Control.Arrow
import Control.Exception
import Control.Monad.State
import Data.Traversable
import qualified Data.Char as Char
import Data.List (isSuffixOf)
import Data.Maybe (catMaybes)
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List as List
import Language.Modulo
import Language.Modulo.Parse
import Language.Modulo.Util
import Language.Modulo.Util.Unmangle (unmangle)
import qualified Data.List.NonEmpty as NonEmpty
addParams :: Module -> Module
addParams mod@(Module n opt doc is ds) = Module n opt doc is (map (fmap decl) ds)
where
decl (FunctionDecl n t) = FunctionDecl n (funType t)
decl x = x
funType (Function as r) = Function (firstComp disamb $fmap funParam as) r
funParam (Nothing,AliasType n) = (Just $ nameEnd n, AliasType n)
funParam (Nothing,PrimType t) = (Just $ Name $ firstLower $(++ "_") $show t, PrimType t)
funParam (n,t) = (n,t)
nameEnd (QName _ n) = Name $ firstLower n
nameEnd (Name n) = Name $ firstLower n
firstLower [] = []
firstLower (x:xs) = Char.toLower x : xs
disamb :: [Maybe Name] -> [Maybe Name]
disamb = snd . List.mapAccumL getUnambName []
where
getUnambName !taken Nothing = (taken, Nothing)
getUnambName !taken (Just x) =
if not (x `elem` taken) then (x:taken, Just x)
else getUnambName taken (Just $ incName x)
incName :: Name -> Name
incName (QName m !n) = QName m (n ++ "_")
incName (Name !n) = Name (n ++ "_")
firstComp :: ([a] -> [a']) -> [(a,b)] -> [(a',b)]
firstComp f = uncurry zip . first f . unzip
rename :: [Module] -> Module -> Module
rename deps mod@(Module n opt doc is ds) = Module n opt doc is (map (fmap renameDecl) ds)
where
renameDecl (TypeDecl n t) = TypeDecl (simplify $ qualify mod n) (fmap renameType t)
renameDecl (FunctionDecl n t) = FunctionDecl (simplify $ qualify mod n) (renameFunType t)
renameDecl (TagDecl t) = TagDecl (renameType t)
renameDecl (ConstDecl n v t) = ConstDecl (simplify $ qualify mod n) v (renameType t)
renameDecl (GlobalDecl n v t) = GlobalDecl (simplify $ qualify mod n) v (renameType t)
renameType (PrimType t) = PrimType t
renameType (AliasType n) = AliasType $ simplify $ resolveName mod (mod : deps) n
renameType (RefType t) = RefType $ renameRefType t
renameType (FunType t) = FunType $ renameFunType t
renameType (CompType t) = CompType $ renameCompType t
renameRefType :: RefType -> RefType
renameRefType (Pointer t) = Pointer (renameType t)
renameRefType (Array t j) = Array (renameType t) j
renameFunType :: FunType -> FunType
renameFunType (Function as r) = Function (fmap (second renameType) as) (renameType r)
renameCompType :: CompType -> CompType
renameCompType (Enum ns) = Enum ns
renameCompType (Struct ns) = Struct $ fmap (\(n,t) -> (n, renameType t)) ns
renameCompType (Union ns) = Union $ fmap (\(n,t) -> (n, renameType t)) ns
renameCompType (BitField ns) = notSupported "Bit-fields"
qualify :: Module -> Name -> Name
qualify _ (QName _ _) = error "Name already qualified"
qualify m (Name n) = if isTrans m then QName (modNameInit $modName m) n else QName (modName m) n
where
modNameInit = toModuleName . init . getModuleNameList
isTrans = optTransient . modOptions
resolveName :: Module -> [Module] -> Name -> Name
resolveName errorMsgMod deps (QName m n) = QName m n
resolveName errorMsgMod deps n@(Name n') = case findName deps n of
Nothing -> error $ "Could not find '" ++ show n' ++ "' in module " ++ show (modName errorMsgMod)
Just m -> QName m n'
findName :: [Module] -> Name -> Maybe ModuleName
findName [] n = Nothing
findName (m:ms) n
| n `elem` mNs = if isTrans m then Just (modNameInit $modName m) else Just (modName m)
| otherwise = findName ms n
where
modNameInit = toModuleName . init . getModuleNameList
isTrans = optTransient . modOptions
mNs = catMaybes . map (getDeclName . snd) . modDecls $ m
simplify :: Name -> Name
simplify (Name n) = Name n
simplify (QName m n) = QName (simp m n) n
where
simp mn@(ModuleName (m :| ms)) n
| unmangle n `isSuffixOf` concatMap unmangle ms
= ModuleName (m :| concat (dropNestEnd (length $ unmangle n) (map unmangle ms)))
| otherwise = mn
x `lastOf` [] = False
x `lastOf` xs = x == last xs
dropNestEnd :: Int -> [[a]] -> [[a]]
dropNestEnd n = reverseDeep . dropNest n . reverseDeep
reverseDeep :: [[a]] -> [[a]]
reverseDeep = reverse . map reverse
dropNest :: Int -> [[a]] -> [[a]]
dropNest _ [] = []
dropNest 0 xss = xss
dropNest n (xs:xss) = drop n xs : dropNest m xss
where
m = n length xs `max` 0
notSupported x = error $ "Not supported yet: " ++ x