module Language.Eiffel.Util where
import Control.Applicative hiding (getConst)
import Control.Monad
import Control.Lens hiding (from, lens)
import Data.Maybe
import qualified Data.HashMap.Strict as Map
import qualified Data.Text as Text
import Data.Text (Text)
import Language.Eiffel.Syntax
class Feature a expr | a -> expr where
featureName :: a -> Text
featureArgs :: a -> [Decl]
featureResult :: a -> Typ
featurePre :: a -> [Clause expr]
featurePost :: a -> [Clause expr]
featureIsFrozen :: a -> Bool
featureRename :: a -> RenameClause -> a
data FeatureEx expr =
forall a. Feature a expr => FeatureEx a
instance Feature (FeatureEx expr) expr where
featureName (FeatureEx f) = featureName f
featureArgs (FeatureEx f) = featureArgs f
featureResult (FeatureEx f) = featureResult f
featurePre (FeatureEx f) = featurePre f
featurePost (FeatureEx f) = featurePost f
featureIsFrozen (FeatureEx f) = featureIsFrozen f
featureRename (FeatureEx f) = FeatureEx . featureRename f
wrapSomeFeature :: (forall f . Feature f expr => f -> b)
-> SomeFeature body expr
-> b
wrapSomeFeature f (SomeRoutine r) = f r
wrapSomeFeature f (SomeAttr a) = f a
wrapSomeFeature f (SomeConst c) = f c
instance Feature (SomeFeature body expr) expr where
featureName = wrapSomeFeature featureName
featureArgs = wrapSomeFeature featureArgs
featureResult = wrapSomeFeature featureResult
featurePre = wrapSomeFeature featurePre
featurePost = wrapSomeFeature featurePost
featureIsFrozen = wrapSomeFeature featureIsFrozen
featureRename (SomeRoutine rout) r = SomeRoutine (featureRename rout r)
featureRename (SomeAttr attr) r = SomeAttr (featureRename attr r)
featureRename (SomeConst c) r = SomeConst (featureRename c r)
instance Feature (AbsRoutine body expr) expr where
featureName = routineName
featureArgs = routineArgs
featureResult = routineResult
featurePre = contractClauses . routineReq
featurePost = contractClauses . routineEns
featureIsFrozen = routineFroz
featureRename rout r@(Rename orig new alias)
| routineName rout == orig = rout { routineName = new
, routineAlias = alias
, routineArgs = newArgs
}
| otherwise = rout {routineArgs = newArgs}
where newArgs = map (renameDecl r) (routineArgs rout)
instance Feature (Attribute expr) expr where
featureName = declName . attrDecl
featureArgs = const []
featureResult = declType . attrDecl
featurePre = contractClauses . attrReq
featurePost = contractClauses . attrEns
featureIsFrozen = attrFroz
featureRename attr r =
attr {attrDecl = renameDecl r (attrDecl attr)}
instance Feature (Constant expr) expr where
featureName = declName . constDecl
featureArgs = const []
featureResult = declType . constDecl
featurePre _ = []
featurePost _ = []
featureIsFrozen = constFroz
featureRename constant r =
constant {constDecl = renameDecl r (constDecl constant)}
class Feature a expr => ClassFeature a body expr | a -> expr, a -> body where
allFeatures :: AbsClas body expr -> [a]
findFeature :: AbsClas body expr -> Text -> Maybe a
instance ClassFeature (Constant expr) body expr where
findFeature = findFeature' toConstMb
allFeatures = allConstants
instance ClassFeature (AbsRoutine body expr) body expr where
findFeature = findFeature' toRoutineMb
allFeatures = allRoutines
instance ClassFeature (Attribute expr) body expr where
findFeature = findFeature' toAttrMb
allFeatures = allAttributes
instance ClassFeature (FeatureEx expr) body expr where
allFeatures clas = map FeatureEx (allAttributes clas) ++
map FeatureEx (allRoutines clas) ++
map FeatureEx (allConstants clas)
findFeature = findFeature' (Just . FeatureEx)
findFeature' :: (SomeFeature body expr -> Maybe a)
-> AbsClas body expr
-> Text
-> Maybe a
findFeature' from cls name = join $ from <$> findSomeFeature cls name
constToAttr :: Constant exp -> Attribute Expr
constToAttr (Constant froz d _) =
Attribute froz d Nothing [] (Contract False []) (Contract False [])
allAttributes = allHelper fmAttrs
allRoutines = allHelper fmRoutines
allConstants = allHelper fmConsts
allHelper lens =
map (view exportFeat) . Map.elems . view lens . featureMap
allCreates = concatMap createNames . creates
allAttributeDecls = map attrDecl . allAttributes
allConstantDecls = map constDecl . allConstants
allInherited = concatMap inheritClauses . inherit
allInheritedTypes = map inheritClass . allInherited
isCreateName n c = n `elem` allCreates c
toRoutineMb (SomeRoutine r) = Just r
toRoutineMb _ = Nothing
toAttrMb (SomeAttr r) = Just r
toAttrMb _ = Nothing
toConstMb (SomeConst r) = Just r
toConstMb _ = Nothing
updFeatureMap :: AbsClas body exp -> FeatureMap body exp -> AbsClas body exp
updFeatureMap c featMap = c {featureMap = featMap}
updFeatBody :: RoutineBody a -> PosAbsStmt b -> RoutineBody b
updFeatBody impl body = impl {routineBody = body}
mapRoutinesM :: (Applicative m, Monad m) =>
(AbsRoutine body exp -> m (AbsRoutine body exp)) ->
FeatureMap body exp ->
m (FeatureMap body exp)
mapRoutinesM f = mapMOf (fmRoutines.traverse.exportFeat) f
mapAttributes :: (Attribute exp -> Attribute exp)
-> FeatureMap body exp
-> FeatureMap body exp
mapAttributes f = over (fmAttrs.traverse.exportFeat) f
mapAttributesM :: (Monad m, Applicative m) =>
(Attribute exp -> m (Attribute exp)) ->
FeatureMap body exp ->
m (FeatureMap body exp)
mapAttributesM f = mapMOf (fmAttrs.traverse.exportFeat) f
mapContract clauseF cs =
cs { contractClauses = map clauseF (contractClauses cs)}
mapExprs :: (AbsRoutine body exp -> AbsRoutine body' exp')
-> (Constant exp -> Constant exp')
-> (Clause exp -> Clause exp')
-> FeatureMap body exp
-> FeatureMap body' exp'
mapExprs routF constF clauseF fm =
FeatureMap (mapUpd routF fmRoutines)
(mapUpd updAttr fmAttrs)
(mapUpd constF fmConsts)
where
updAttr a = a { attrEns = mapContract clauseF (attrEns a)
, attrReq = mapContract clauseF (attrReq a)
}
mapUpd f lens = Map.map (over exportFeat f) (view lens fm)
classMapAttributes f c =
c {featureMap = mapAttributes f (featureMap c)}
classMapAttributesM :: (Applicative m, Monad m) =>
(Attribute exp -> m (Attribute exp)) ->
AbsClas body exp ->
m (AbsClas body exp)
classMapAttributesM f c = do
fm <- mapAttributesM f (featureMap c)
return (c {featureMap = fm})
classMapRoutines :: (AbsRoutine body exp -> AbsRoutine body exp)
-> AbsClas body exp -> AbsClas body exp
classMapRoutines f c =
c {featureMap = over (fmRoutines.traverse.exportFeat) f (featureMap c)}
classMapRoutinesM :: (Applicative m, Monad m) =>
(AbsRoutine body exp -> m (AbsRoutine body exp)) ->
AbsClas body exp ->
m (AbsClas body exp)
classMapRoutinesM f c = do
fm <- mapRoutinesM f (featureMap c)
return (c {featureMap = fm})
classMapConstants f c =
c {featureMap = over (fmConsts.traverse.exportFeat) f (featureMap c)}
classMapExprs :: (AbsRoutine body exp -> AbsRoutine body' exp')
-> (Clause exp -> Clause exp')
-> (Constant exp -> Constant exp')
-> AbsClas body exp -> AbsClas body' exp'
classMapExprs featrF clauseF constF c =
c { featureMap = mapExprs featrF constF clauseF (featureMap c)
, invnts = map clauseF (invnts c)
}
makeRoutineIs :: SomeFeature body Expr -> SomeFeature EmptyBody Expr
makeRoutineIs (SomeRoutine r) = SomeRoutine (makeRoutineI r)
makeRoutineIs (SomeAttr a) = SomeAttr a
makeRoutineIs (SomeConst c) = SomeConst c
makeAttributeI :: Attribute exp -> Attribute Expr
makeAttributeI (Attribute froz decl assgn notes _ _) =
Attribute froz decl assgn notes (Contract False []) (Contract False [])
clasInterface :: AbsClas body Expr -> ClasInterface
clasInterface c =
c { featureMap = over (fmRoutines.traverse.exportFeat)
(makeRoutineI)
(featureMap c)
}
makeRoutineI :: AbsRoutine body Expr -> RoutineI
makeRoutineI f = f { routineImpl = EmptyBody
, routineRescue = Nothing}
clasMap :: [AbsClas body exp] -> Map ClassName (AbsClas body exp)
clasMap = Map.fromList . map (\ c -> (className c, c))
attrMap :: AbsClas body exp -> Map Text Typ
attrMap = declsToMap . map attrDecl . allAttributes
findRoutine :: Clas -> Text -> Maybe Routine
findRoutine = findFeature
findOperator :: AbsClas body Expr -> Text -> Int ->
Maybe (AbsRoutine body Expr)
findOperator c opName numArgs =
let fs = allRoutines c
ffs = filter (\ rout -> routineAlias rout == Just opName &&
length (routineArgs rout) == numArgs) fs
in listToMaybe ffs
findSomeFeature :: AbsClas body expr -> Text -> Maybe (SomeFeature body expr)
findSomeFeature cls name =
lkup fmRoutines SomeRoutine <|>
lkup fmAttrs SomeAttr <|>
lkup fmConsts SomeConst
where
lkup lens cast = cast <$>
view exportFeat <$>
Map.lookup nameLow (view lens featMap)
featMap = featureMap cls
nameLow = Text.toLower name
findFeatureEx :: AbsClas body expr -> Text -> Maybe (FeatureEx expr)
findFeatureEx = findFeature
findRoutineInt :: ClasInterface -> Text -> Maybe RoutineI
findRoutineInt = findFeature
findAttrInt :: AbsClas body expr -> Text -> Maybe (Attribute expr)
findAttrInt = findFeature
findConstantInt :: AbsClas body Expr -> Text -> Maybe (Constant Expr)
findConstantInt = findFeature
fullName :: AbsClas body exp -> RoutineI -> Text
fullName c f = fullNameStr (className c) (routineName f)
fullNameStr :: Text -> Text -> Text
fullNameStr cName fName = Text.concat ["__", cName, "_", fName]
genericStubs :: AbsClas body exp -> [AbsClas body' exp']
genericStubs = map makeGenericStub . generics
makeGenericStub :: Generic -> AbsClas body exp
makeGenericStub (Generic g constrs _) =
AbsClas { deferredClass = False
, frozenClass = False
, expandedClass = False
, classNote = []
, className = g
, currProc = Dot
, procGeneric = []
, obsoleteClass = False
, procExpr = []
, generics = []
, inherit = [Inheritance False $ map simpleInherit constrs]
, creates = []
, converts = []
, featureMap = FeatureMap Map.empty Map.empty Map.empty
, invnts = []
}
where
simpleInherit t = InheritClause t [] [] [] [] []
renameDecl :: RenameClause -> Decl -> Decl
renameDecl r@(Rename orig new _) (Decl n t)
| n == orig = Decl new t'
| otherwise = Decl n t'
where
t' = renameType r t
renameType r (ClassType n ts) = ClassType n (map (renameType r) ts)
renameType (Rename orig new _) (Like i)
| i == orig = Like new
| otherwise = Like i
renameType r t = error $ "renameType: rename " ++ show r ++
" in type: " ++ show t
renameAll :: [RenameClause] -> AbsClas body exp -> AbsClas body exp
renameAll renames cls = renamed
where
renamed = foldr renameClass cls renames
renameKey (Rename old new _aliasMb) k
| k == Text.toLower old = new
| otherwise = k
renameKeys r c = c { featureMap = fmMapKeys (renameKey r) (featureMap c)}
renameClass r = renameKeys r .
classMapConstants (flip featureRename r) .
classMapAttributes (flip featureRename r) .
classMapRoutines (flip featureRename r)
undefineName :: Text -> AbsClas body exp -> AbsClas body exp
undefineName name cls =
cls { featureMap = fmKeyFilter (/= name) (featureMap cls)}
undefineAll :: InheritClause -> AbsClas body exp -> AbsClas body exp
undefineAll inh cls = foldr undefineName cls (undefine inh)
mergeableClass :: AbsClas body exp -> Bool
mergeableClass _clas = True
mergeClass :: AbsClas body exp -> AbsClas body exp -> AbsClas body exp
mergeClass class1 class2
| mergeableClass class1 && mergeableClass class2 =
class1 { invnts = invnts class1 ++ invnts class2
, featureMap = featureMap class1 `fmUnion` featureMap class2
}
| otherwise = error $ "mergeClasses: classes not mergeable " ++
show (className class1, className class2)
mergeClasses :: [AbsClas body exp] -> AbsClas body exp
mergeClasses = foldr1 mergeClass
fmMapKeys :: (Text -> Text) -> FeatureMap body exp -> FeatureMap body exp
fmMapKeys f = fmKeyMap fmRoutines . fmKeyMap fmAttrs . fmKeyMap fmConsts
where
fmKeyMap setter = over setter mapKeys
mapKeys :: Map Text v -> Map Text v
mapKeys = Map.fromList . map (\(k,v) -> (f k, v)) . Map.toList
fmKeyFilter :: (Text -> Bool)
-> FeatureMap body exp
-> FeatureMap body exp
fmKeyFilter p = fmFilt fmRoutines . fmFilt fmAttrs . fmFilt fmConsts
where
fmFilt setter = over setter filt
filt = Map.filterWithKey (\ k _v -> p k)
fmUnion
:: FeatureMap body exp
-> FeatureMap body exp
-> FeatureMap body exp
fmUnion fm1 fm2 =
FeatureMap
(Map.union (view fmRoutines fm1) (view fmRoutines fm2))
(Map.union (view fmAttrs fm1) (view fmAttrs fm2))
(Map.union (view fmConsts fm1) (view fmConsts fm2))
fmEmpty = FeatureMap Map.empty Map.empty Map.empty
fmUnions = foldr fmUnion fmEmpty
argMap :: RoutineWithBody a -> Map Text Typ
argMap = declsToMap . routineArgs
localMap :: RoutineWithBody a -> Map Text Typ
localMap = declsToMap . routineDecls
routineDecls :: AbsRoutine (RoutineBody exp1) exp -> [Decl]
routineDecls r =
case routineImpl r of
RoutineDefer -> []
RoutineExternal _ _ -> []
body -> routineLocal body
opAlias :: BinOp -> Text
opAlias Add = "+"
opAlias Sub = "-"
opAlias Mul = "*"
opAlias Div = "/"
opAlias Quot = "//"
opAlias Rem = "\\"
opAlias Pow = "^"
opAlias And = "and"
opAlias AndThen = "and then"
opAlias Or = "or"
opAlias OrElse = "or else"
opAlias Xor = "xor"
opAlias Implies = "implies"
opAlias (SymbolOp o) = o
opAlias (RelOp o _) = rel o
where
rel Lte = "<="
rel Lt = "<"
rel Gt = ">"
rel Gte = ">="
rel relOp = error $ "opAlias: non user-level operator " ++ show relOp
equalityOp :: BinOp -> Bool
equalityOp (RelOp Eq _) = True
equalityOp (RelOp Neq _) = True
equalityOp (RelOp TildeEq _) = True
equalityOp (RelOp TildeNeq _) = True
equalityOp _ = False
unOpAlias Not = "not"
unOpAlias Neg = "-"
unOpAlias Old = "unOpAlias: `old' is not a user-operator."
classToType :: AbsClas body exp -> Typ
classToType clas = ClassType (className clas) (map genType (generics clas))
where genType g = ClassType (genericName g) []
isBasic :: Typ -> Bool
isBasic t = any ($ t) [isBooleanType, isIntegerType, isNaturalType, isRealType, isCharType]
intBits :: [Integer]
intBits = [8, 16, 32, 64]
typeBounds :: Typ -> (Integer, Integer)
typeBounds (ClassType n []) = fromJust $ lookup n wholeMap
where
intMap = zip integerTypeNames
(map (\bits -> let half = bits `quot` 2
in ( 2^half, 2^half 1)) intBits)
natMap = zip naturalTypeNames
(map (\bits -> (0, 2^bits 1)) intBits)
wholeMap = intMap ++ natMap
typeBounds t = error $ "typeBounds: won't work on " ++ show t
isBooleanType :: Typ -> Bool
isBooleanType = (== "BOOLEAN") . classNameType
isIntegerType :: Typ -> Bool
isIntegerType = isInTypeNames integerTypeNames
isNaturalType :: Typ -> Bool
isNaturalType = isInTypeNames naturalTypeNames
isRealType :: Typ -> Bool
isRealType = isInTypeNames realTypeNames
isCharType :: Typ -> Bool
isCharType = isInTypeNames charTypeNames
isInTypeNames names (ClassType name _) = name `elem` names
isInTypeNames _ _ = False
integerTypeNames :: [Text]
integerTypeNames = map ((Text.append "INTEGER_") . Text.pack . show) intBits
naturalTypeNames :: [Text]
naturalTypeNames = map ((Text.append "NATURAL_") . Text.pack . show) intBits
realTypeNames :: [Text]
realTypeNames = ["REAL_32", "REAL_64"]
charTypeNames :: [Text]
charTypeNames = ["CHARACTER_8", "CHARACTER_32"]
classNameType :: Typ -> Text
classNameType (ClassType cn _) = cn
classNameType (Sep _ _ cn) = cn
classNameType t = error $ "Non-class type " ++ show t
intType :: Typ
intType = namedType "INTEGER_32"
boolType :: Typ
boolType = namedType "BOOLEAN"
realType :: Typ
realType = namedType "REAL_64"
charType :: Typ
charType = namedType "CHARACTER_8"
stringType :: Typ
stringType = namedType "STRING_8"
anyType :: Typ
anyType = namedType "ANY"
namedType :: ClassName -> Typ
namedType name = ClassType name []
insertDecl :: Decl -> Map Text Typ -> Map Text Typ
insertDecl (Decl s t) = Map.insert s t
declsToMap :: [Decl] -> Map Text Typ
declsToMap = foldr insertDecl Map.empty
newVar :: ProcDecl -> Proc
newVar (SubTop p) = p
newVar (CreateLessThan p _) = p