{-# LANGUAGE ScopedTypeVariables #-} module TypeAnalysisTclUtil ( typeAnalysisToHTclObj, typeAnalysisToBitify, typeAnalysisToDetail, -- for displaying subparts structFieldToDetail, unionTagToDetail, typeAnalysisShort, showWidth, interfaceFieldToDetail ) where import HTcl import TclUtils import TypeAnalysis import PFPrint import Id import PreIds import CType import Pred import Pragma import Data.List(intercalate, sort) import IntegerUtil(integerToString) -- --------------- typeAnalysisToHTclObj :: TypeAnalysis -> HTclObj typeAnalysisToHTclObj (Unknown) = TStr "Unknown" typeAnalysisToHTclObj (Variable) = TStr "Variable" typeAnalysisToHTclObj (Function) = TStr "Function" typeAnalysisToHTclObj (Numeric) = TStr "Numeric" typeAnalysisToHTclObj (String) = TStr "String" typeAnalysisToHTclObj (Primary t k vs isC mwidth) = tag "Primary" $ [TStr $ showType True t k vs] ++ showPolymorphic isC ++ showWidth mwidth typeAnalysisToHTclObj (Vector isC len el mwidth) = tag "Vector" $ [TStr $ showType True idVector kVector vsVector] ++ showPolymorphic isC ++ [tagStr "length" (pvStr len)] ++ [tagStr "elem" (pvStr el)] ++ showWidth mwidth typeAnalysisToHTclObj (List isC el) = tag "List" $ [TStr $ showType True idList kList vsList] ++ showPolymorphic isC ++ [tagStr "elem" (pvStr el)] typeAnalysisToHTclObj (Alias t k vs atype) = tag "Alias" $ [TStr $ showType True t k vs, TStr (pvStr atype)] ++ showTaggedPosition t typeAnalysisToHTclObj (Struct t k vs isC fs mwidth) = tag "Struct" $ [TStr $ showType True t k vs] ++ showPolymorphic isC ++ [tagLst "members" (map structFieldToHTclObj fs)] ++ showWidth mwidth ++ showTaggedPosition t typeAnalysisToHTclObj (Enum t fs mwidth) = tag "Enum" $ [TStr $ showType True t KStar []] ++ -- remove the package qualifier from the enum fields [tagManyStr "members" (map (pvStr . unQualId) fs)] ++ showWidth mwidth ++ showTaggedPosition t typeAnalysisToHTclObj (TaggedUnion t k vs isC fs mwidth) = tag "TaggedUnion" $ [TStr $ showType True t k vs] ++ showPolymorphic isC ++ [tagLst "members" (map unionTagToHTclObj fs)] ++ showWidth mwidth ++ showTaggedPosition t typeAnalysisToHTclObj (Interface t k vs isC fs pragmas) = -- XXX display the pragmas? tag "Interface" $ [TStr $ showType True t k vs] ++ showPolymorphic isC ++ [tagLst "members" (map interfaceFieldToHTclObj fs)] ++ showTaggedPosition t ++ (if (not $ null pragmas) then [tagLst "attributes" (map ifcPragmaToHTclObj pragmas)] else []) typeAnalysisToHTclObj (Typeclass t k vs ps fdeps allow insts fs) = tag "Typeclass" $ [TStr $ showType True t k vs] ++ showSuperclasses ps ++ showDependencies vs fdeps ++ showAllowIncoherent allow ++ [tagLst "members" (map typeclassFieldToHTclObj fs)] ++ showInstances insts ++ showTaggedPosition t ----------------------------------------------------- -- Key, Name size, members fields -- A specific display for bitify command -- Key, Name size, members fields -- Return structure corresponds to Tcl-level interface in SignalTypes.tcl typeAnalysisToBitify :: TypeAnalysis -> HTclObj -- typeAnalysisToBitify (Primary t k vs isC (Just n)) = tag "BASIC" [TStr $ pvStr t, TStr $ show n, TLst [], TLst [] ] -- typeAnalysisToBitify (Vector isC len el (Just n)) = tag "STRUCT" [TStr $ "Vector#(" ++ show vlen ++ ",a)", TStr $ show n, TLst [], TLst $ map genElem [vlen-1, vlen-2..0 ] ] where vlen :: Int = read (pvStr len) elsize = fromInteger(n) `div` vlen genElem :: Int -> HTclObj genElem i = let lsb = (i) * elsize in TLst [TStr ("_[" ++ show i ++ "]"), TStr (pvStr el), TInt elsize, TInt lsb] -- Structs typeAnalysisToBitify (Struct t k vs isC fs (Just n)) = tag "STRUCT" [TStr $ showType False t k vs, TStr $ show n, TLst [], TLst $ snd fields ] where genField :: (Id, Qual Type, Maybe Integer) -> (Int,[HTclObj]) -> (Int,[HTclObj]) genField (f,t,fw) (lsb,prev) = let err = error ("Bitify no size" ++ show f ++ ": " ++ show t) size :: Int = maybe err fromInteger fw in (lsb+size, TLst [TStr $ pvStr (unQualId f), TStr $ pvStr t, TInt size, TInt lsb]:prev) fields :: (Int,[HTclObj]) = foldr genField (0,[]) fs -- Tagged Unions -- TaggedUnion Id Kind [Id] Bool [(Id, Type, Maybe Integer)] (Maybe Integer) typeAnalysisToBitify (TaggedUnion t k vs isC fs (Just n)) = tag "TAGGEDUNION" [TStr $ showType False t k vs, TStr $ show n, TLst $ map genMember fs, TLst $ map genField fs] where genMember :: (Id, Type, Maybe Integer) -> HTclObj genMember (i, t, mi) = TStr $ pvStr i -- genField :: (Id, Type, Maybe Integer) -> HTclObj genField (i, t, mi) = let err = error ("Bitify tagged union no size" ++ show i ++ ": " ++ show t) in TLst [TStr $ pvStr (unQualId i), TStr $ pvStr t, TInt $ maybe err fromInteger mi, TInt 0] -- Aliases typeAnalysisToBitify (Alias t k vs atype) = tag "ALIAS" [TStr (pvStr atype), TInt 0, TLst [], TLst [] ] typeAnalysisToBitify (Enum t fs (Just n)) = tag "ENUM" [TStr $ showType True t KStar [], TStr $ show n, TLst $ map (TStr . pvStr . unQualId) fs, TLst [] ] -- Otherwise unknown typeAnalysisToBitify _ = tag "UNKNOWN" [TStr "", TInt 0, TLst [], TLst []] typeAnalysisShort :: TypeAnalysis -> String typeAnalysisShort (Unknown) = "Unknown" typeAnalysisShort (Variable) = "variable" typeAnalysisShort (Function) = "function" typeAnalysisShort (Numeric) = "numeric type" typeAnalysisShort (String) = "string type" typeAnalysisShort (Primary _ _ _ _ _) = "" typeAnalysisShort (Vector _ _ _ _) = "vector" typeAnalysisShort (List _ _) = "list" typeAnalysisShort (Alias _ _ _ _) = "alias" typeAnalysisShort (Struct _ _ _ _ _ _) = "struct" typeAnalysisShort (Enum _ _ _) = "enum" typeAnalysisShort (TaggedUnion _ _ _ _ _ _) = "tagged Union" typeAnalysisShort (Interface _ _ _ _ _ _) = "interface" typeAnalysisShort (Typeclass {}) = "typeclass" -- --------------- -- Another variation for use with workstation. typeAnalysisToDetail :: TypeAnalysis -> HTclObj typeAnalysisToDetail (Unknown) = TStr "Unknown" typeAnalysisToDetail (Variable) = TStr "Variable" typeAnalysisToDetail (Function) = TStr "Function" typeAnalysisToDetail (Numeric) = TStr "Numeric Type" typeAnalysisToDetail (String) = TStr "String Type" typeAnalysisToDetail (Primary t k vs isC mwidth) = tag "Primary" $ [TLst [TStr $ showType True t k vs]] ++ showPolymorphic isC ++ showWidth mwidth typeAnalysisToDetail (Vector isC len el mwidth) = tag "Vector" $ [TLst [TStr $ showType True idVector kVector vsVector]] ++ showPolymorphic isC ++ [tagStr "length" (pvStr len)] ++ [tagStr "element type" (pvStr el)] ++ showWidth mwidth typeAnalysisToDetail (List isC el) = tag "List" $ [TLst [TStr $ showType True idList kList vsList]] ++ showPolymorphic isC ++ [tagStr "element type" (pvStr el)] typeAnalysisToDetail (Alias t k vs atype) = tag "Alias" $ [TLst [TStr $ showType True t k vs], tagLst "Definition" [TStr (pvStr atype)]] ++ showTaggedPosition t typeAnalysisToDetail (Struct t k vs isC fs mwidth) = tag "Struct" $ [TLst [TStr $ showType True t k vs]] ++ showPolymorphic isC ++ [tagLst "members" (map structFieldToDetail fs)] ++ showWidth mwidth ++ showTaggedPosition t typeAnalysisToDetail (Enum t fs mwidth) = tag "Enum" $ [TLst [TStr $ showType True t KStar []]] ++ -- remove the package qualifier from the enum fields [tagManyStr "members" (map (pvStr . unQualId) fs)] ++ showWidth mwidth ++ showTaggedPosition t typeAnalysisToDetail (TaggedUnion t k vs isC fs mwidth) = tag "TaggedUnion" $ [TLst [TStr $ showType True t k vs]] ++ showPolymorphic isC ++ [tagLst "members" (map unionTagToDetail fs)] ++ showWidth mwidth ++ showTaggedPosition t typeAnalysisToDetail (Interface t k vs isC fs pragmas) = -- XXX display the pragmas? tag "Interface" $ [TLst [TStr $ showType True t k vs]] ++ showPolymorphic isC ++ [tagLst "members" (map interfaceFieldToDetail fs)] ++ (if (not $ null pragmas) then [tagLst "attributes" (map ifcPragmaToHTclObj pragmas)] else []) ++ showTaggedPosition t typeAnalysisToDetail (Typeclass t k vs ps fdeps allow insts fs) = tag "Typeclass" $ [TLst [TStr $ showType True t k vs]] ++ showSuperclasses ps ++ showDependencies vs fdeps ++ showAllowIncoherent allow ++ if (null fs) then [] else [tagLst "members" (map typeclassFieldToDetail fs)] ++ showInstances insts ++ showTaggedPosition t -- --------------- ifcPragmaToHTclObj :: IfcPragma -> HTclObj ifcPragmaToHTclObj p = TStr $ "(* " ++ pvStr p ++ " *)" commentMaybe :: PVPrint a => String -> Maybe a -> String commentMaybe _ Nothing = "" commentMaybe cmt (Just i) = intercalate " " ["//",cmt,pvStr i] structFieldToDetail :: (Id, Qual Type, Maybe Integer) -> HTclObj structFieldToDetail (f, t, mi) = TStr $ intercalate " " [pvStr t, pvStr (unQualId f), commentMaybe "width" mi] unionTagToDetail :: (Id, Type, Maybe Integer) -> HTclObj unionTagToDetail (f,t, mi) = TStr $ intercalate " " [pvStr t, pvStr (unQualId f), commentMaybe "width" mi] typeclassFieldToDetail :: (Id, Qual Type) -> HTclObj typeclassFieldToDetail (f, t) = TStr $ intercalate " " [pvStr t, pvStr (unQualId f)] structFieldToHTclObj :: (Id, Qual Type, Maybe Integer) -> HTclObj structFieldToHTclObj (f,t,n) = -- XXX what about the provisos? -- XXX what if the type is a function/module ? TLst $ [(TStr $ pvStr t), (TStr $ pvStr (unQualId f))] ++ showWidth n unionTagToHTclObj :: (Id, Type, Maybe Integer) -> HTclObj unionTagToHTclObj (f,t, mi) = TLst $ [TStr (pvStr t), TStr ( pvStr (unQualId f))] ++ showWidth mi typeclassFieldToHTclObj :: (Id, Qual Type) -> HTclObj typeclassFieldToHTclObj (f,t) = -- XXX what about the provisos? -- XXX what if the type is a function/module ? TLst $ [(TStr $ pvStr t), (TStr $ pvStr (unQualId f))] interfaceFieldToHTclObj :: (Bool, Id, Qual Type, [IfcPragma]) -> HTclObj interfaceFieldToHTclObj (is_subifc, fid, (ps :=> t), fpragmas) = if (is_subifc) then -- 'ps' is known to be empty tag "interface" [TStr (pvStr t), TStr (pvStr (unQualId fid)), TLst (map ifcPragmaToHTclObj fpragmas) ] else let (arg_ts, res_t) = getArrows t in tagLst "method" [TStr (pvStr res_t), TStr (pvStr (unQualId fid)), TLst (map (TStr . pvStr) arg_ts), TLst (map ifcPragmaToHTclObj fpragmas) ] {- (if (null ps) then "" else "provisos " ++ inParens (commaSep (map pvStr ps))) -} interfaceFieldToDetail :: (Bool, Id, Qual Type, [IfcPragma]) -> HTclObj interfaceFieldToDetail (is_subifc, fid, (ps :=> t), fpragmas) = -- XXX display the field pragmas? -- XXX (could use them to give names to the args?) if (is_subifc) then -- 'ps' is known to be empty TStr $ intercalate " " ["interface", pvStr t, pvpStringNQ fid] else let (arg_ts, res_t) = getArrows t args' = intercalate ", " (map pvStr arg_ts) args = "(" ++ args' ++ ")" in TStr $ intercalate " " ["method", pvStr res_t, pvpStringNQ fid, args] showPolymorphic :: Bool -> [HTclObj] showPolymorphic isC = if (isC) then [] else [TStr "polymorphic"] showSuperclasses :: [Type] -> [HTclObj] showSuperclasses ps = if (null ps) then [] else [tagLst "superclasses" (map (TStr . pvStr) ps)] showDependencies :: [Id] -> [[Bool]] -> [HTclObj] showDependencies _ [bs] | not (or bs) = [] -- no dependencies showDependencies vs fdeps = let sepVars (lefts, rights) [] = (lefts, rights) sepVars (lefts, rights) ((False, v):vs) = sepVars (v:lefts, rights) vs sepVars (lefts, rights) ((True, v):vs) = sepVars (lefts, v:rights) vs showVars [v] = pvStr v showVars vs = "(" ++ (intercalate ", " (map pvStr vs)) ++ ")" showDep bs = let (lefts, rights) = sepVars ([], []) (zip bs vs) in TStr $ showVars (reverse lefts) ++ " determines " ++ showVars (reverse rights) in [tagLst "dependencies" (map showDep fdeps)] showAllowIncoherent :: Maybe Bool -> [HTclObj] showAllowIncoherent (Nothing) = [] showAllowIncoherent (Just False) = [TStr "coherent"] showAllowIncoherent (Just True) = [TStr "incoherent"] showInstances :: [Qual Type] -> [HTclObj] showInstances insts = if (null insts) then [] else -- for now, alphabetize the list let inst_strs = sort (map pvStr insts) in -- XXX include position for each instance? [tagLst "instances" (map TStr inst_strs)] showWidth :: Maybe Integer -> [HTclObj] showWidth (Just w) | w <= toInteger (maxBound :: Int) = [TLst [TStr "width", TInt (fromInteger w)]] showWidth (Just w) = [TLst [TStr "width", TStr (integerToString 10 w)]] showWidth Nothing = [] -- --------------- -- String utilities pvStr :: (PVPrint a) => a -> String pvStr = pvpString -- ---------------