----------------------------------------------------------------------------------------- {-| Module : DeriveTypes Copyright : (c) Daan Leijen 2003 License : BSD-style Maintainer : wxhaskell-devel@lists.sourceforge.net Stability : provisional Portability : portable Module that derives more specific types from a C-header signature. Also removes duplicates and ignored definitions. -} ----------------------------------------------------------------------------------------- module DeriveTypes ( deriveTypes, deriveTypesAll , Name(..), Method(..), ClassName, MethodName, PropertyName , classifyName ) where import qualified Data.Set as Set import qualified Data.Map as Map import Data.Char( toLower, toUpper, isSpace, isLower, isUpper ) import Data.List( isPrefixOf, sort, sortBy, intersperse ) import Types import HaskellNames import Classes( isClassName, haskellClassDefs ) {----------------------------------------------------------------------------------------- The whole type derivation can be tuned with this tables -----------------------------------------------------------------------------------------} -- | Map properties names (@GetInvokingWindow@) to object types (@Window@). objectProperties :: Map.Map String Type objectProperties = Map.fromList $ map (\(nm,objname) -> (nm,Object objname)) [("InvokingWindow" , "wxWindow") ,("EventHandler" , "wxEvtHandler") ,("NextHandler" , "wxEvtHandler") ,("PreviousHandler" , "wxEvtHandler") ,("Parent" , "wxWindow") -- a bit weak :-( ,("TopWindow" , "wxWindow") ,("ClientObject" , "wxClientData") ,("ToolClientData" , "wxClientData") ,("TextBackground" , "wxColour") ,("TextForeground" , "wxColour") ,("ForegroundColour", "wxColour") ,("BackgroundColour", "wxColour") ,("CustomColour" , "wxColour") ,("BorderColour" , "wxColour") ,("TextColour" , "wxColour") ,("SystemColour" , "wxColour") ,("Stipple" , "wxBitmap") ,("BitmapLabel" , "wxBitmap") ,("BitmapFocus" , "wxBitmap") ,("BitmapSelected" , "wxBitmap") ,("BitmapDisabled" , "wxBitmap") ,("WeekDayInSameWeek", "wxDateTime") ,("NextWeekDay" , "wxDateTime") ,("PrevWeekDay" , "wxDateTime") ,("WeekDay" , "wxDateTime") ,("LastWeekDay" , "wxDateTime") ,("Week" , "wxDateTime") ,("LastMonthDay" , "wxDateTime") ,("SystemFont" , "wxFont") ,("App" , "wxApp") ,("EventObject" , "wxObject") ,("Constraints" , "wxLayoutConstraints") ,("UpdateRegion" , "wxRegion") ,("SubBitmap" , "wxBitmap") ,("Background" , "wxBrush") -- App ,("TopWindow" , "wxWindow") ,("LogTarget" , "wxLog") ] -- | Property names that correspond with a boolean booleanProperties :: Set.Set String booleanProperties = Set.fromList ["EvtHandlerEnabled" ,"ToolEnabled" ,"Skipped" ,"Enabled" ,"Checked" ] -- | Methods that have an object result. objectMethods :: Map.Map String Type objectMethods = Map.fromList $ map (\(nm,objname) -> (nm,Object objname)) [ ("FindFocus", "wxWindow") , ("FindWindow", "wxWindow") , ("FindClass", "wxClassInfo") -- App , ("FindWindowByName", "wxWindow") , ("FindWindowByLabel", "wxWindow") ] -- | Methods that have a boolean result. booleanMethods :: Set.Set String booleanMethods = Set.fromList ["Dragging" ,"Entering" ,"Leaving" ,"LeftDClick" ,"LeftDown" ,"LeftIsDown" ,"LeftUp" ,"RightDClick" ,"RightDown" ,"RightIsDown" ,"RightUp" ,"MiddleDClick" ,"MiddleDown" ,"MiddleIsDown" ,"MiddleUp" ,"ButtonDown" ,"ButtonIsDown" ,"ButtonUp" ,"ButtonDClick" ,"Moving" ,"MetaDown" ,"ControlDown" ,"AltDown" ,"ShiftDown" ,"MoreRequested" ,"Destroy" ,"DestroyChildren" ,"Close" ,"Disable" ,"Hide" ,"Show" ,"Validate" ] -- | Argument names that correspond to booleans. booleans :: Set.Set String booleans = Set.fromList ["_force","force" ,"_enable","enable","enb" ,"check" ,"modal" ,"eraseBackground" ,"x_scrolling" ,"y_scrolling" ,"useMask" ,"doIt" ,"needMore" -- idleEventRequestMore ,"deleteHandler" -- popEventHandler ,"autoLayout" -- setAutoLayout ,"refresh" -- setScrollbar ] -- | Argument names that correspond to strings. strings :: Set.Set String strings = Set.fromList [ "_name", "name" , "strText" , "str" , "text" , "_txt" , "msg", "_msg", "cap", "_cap" , "string" , "path" , "_lbl" -- HsApp , "shelp", "lhelp" -- Toolbar , "section","keyword","viewer" -- HelpController , "file", "rootpath" , "_dir", "_fle", "_wcd", "message", "wildCard" -- FileDialog ] -- | Argument name pairs that correspond to Points. points :: Set.Set (String,String) points = Set.fromList [ ("x","y") , ("x1","y1") , ("x2","y2") , ("xc","yc") , ("xoffset","yoffset") , ("xpos","ypos") , ("x_pos","y_pos") , ("x_unit","y_unit") , ("_x","_y") , ("xsrc","ysrc") , ("posx","posy") , ("_lft","_top") -- FileDialog ] -- | Argument name pairs that correspond to Sizes. sizes :: Set.Set (String,String) sizes = Set.fromList [ ("w","h") , ("_w","_h") , ("width","height") , ("_width","_height") ] -- | Argument name pairs that correspond to Vectors. vectors :: Set.Set (String,String) vectors = Set.fromList [ ("dx","dy") , ("_dx","_dy") ] -- | Argument name quadruples that correspond to Rectangles. rectangles :: Set.Set (String,String,String,String) rectangles = Set.fromList [ ("x","y","w","h") , ("_x","_y","_w","_h") , ("x","y","width","height") , ("xdest","ydest","width","height") , ("_lft","_top","_wdt","_hgt") ] -- | Argument names that correspond to a certain object. objects :: Map.Map String String objects = Map.fromList [("submenu" ,"wxMenu") ,("handler" ,"wxEvtHandler") ,("dc" ,"wxDC") ,("_prc" ,"wxProcess") ,("ctrl" ,"wxControl") ,("win" ,"wxWindow") ,("_wnd" ,"wxWindow") ,("_prt" ,"wxWindow") ,("parent" ,"wxWindow") ,("_par" ,"wxWindow") ,("_prt" ,"wxWindow") ,("child","wxWindow") ,("_lst","wxList") ,("sibling","wxWindow") ,("otherW","wxWindow") ,("otherWin","wxWindow") ,("nb","wxNotebook") ,("cmap","wxPalette") ,("theFont","wxFont") ,("stipple","wxBitmap") ,("_bmp" ,"wxBitmap") ,("bmp" ,"wxBitmap") ,("bmp1" ,"wxBitmap") ,("bmp2" ,"wxBitmap") ,("t1","wxDateTime") ,("t2","wxDateTime") ,("dt","wxDateTime") ,("col","wxColour") ,("_itm","wxMenuItem") ,("cfg" ,"wxConfigBase") -- htmlHelpController ,("config" ,"wxConfigBase") -- htmlHelpController ] -- | Argument name pairs that correspond to a certain (haskell) function pointer. functions :: Map.Map String String functions = Map.fromList [ ("_fun_CEvent" , "Ptr fun -> Ptr state -> Event evt -> IO ()") ] referenceObjects :: Map.Map String String referenceObjects = Map.fromList [ ("AddTime", "wxDateTime") , ("SubtractTime", "wxDateTime") , ("AddDate", "wxDateTime") , ("SubtractDate", "wxDateTime") , ("LoadBitmap", "wxBitmap") , ("LoadIcon", "wxIcon") ] -- | Definitions that should be ignored. ignore :: [Decl -> Maybe String] ignore = [ -- gizmos: eljgizmos prefix "expEVT_DYNAMIC_SASH" "gizmos" ,prefix "wxRemotelyScrolled" "gizmos" ,prefix "wxTreeCompanionWindow" "gizmos" ,prefix "wxThinSplitterWindow" "gizmos" ,prefix "wxSplitterScrolledWindow" "gizmos" ,prefix "wxMultiCell" "gizmos" ,prefix "wxLED" "gizmos" ,prefix "wxEditableListBox" "gizmos" ,prefix "wxDynamicSash" "gizmos" -- frame layout: eljfl ,equals "expEVT_USER_FIRST" "frame layout" ,prefix "cb" "frame layout" ,prefix "wxFrameLayout" "frame layout" ,prefix "wxToolLayout" "frame layout" ,prefix "wxToolWindow" "frame layout" ,prefix "wxNewBitmapButton" "frame layout" ,prefix "wxDynamicToolBar" "frame layout" ,prefix "wxDynToolInfo" "frame layout" -- plot window: eljplot ,prefix "expEVT_PLOT" "plot" ,prefix "wxPlot" "plot" ,prefix "ELJPlot" "plot" -- joystick: eljjoystick ,prefix "expEVT_JOY" "joystick" ,prefix "wxJoystick" "joystick" -- command processor: eljcommand ,prefix "wxCommandProcessor" "command proc" ,prefix "ELJCommand" "command proc" -- message parameters: eljmime / wrapper.h ,prefix "wxMessageParameters" "message param" -- non-portable ,equals "expEVT_COMMAND_TOGGLEBUTTON_CLICKED" "toggle button" ,prefix "wxToggleButton_" "toggle button" ,prefix "wxDialUpEvent_" "dialup events" ,prefix "wxDialUpManager_" "dialup manager" ,prefix "wxCriticalSection_" "threads" ,prefix "wxMutex_" "threads" ,prefix "wxCondition_" "threads" ,prefix "wxMutexGui_" "threads" -- misc. ,equals "wxDateTime_IsGregorianDate" "gregorian date" ,equals "wxIconBundle_Assign" "icon bundle assign" ,prefix "ELJConnection" "elj connection" ,prefix "ELJServer" "elj server" ,prefix "ELJClient" "elj client" -- basic types ,prefix "wxColour" "colour" ,prefix "wxPoint" "point" ,prefix "wxTreeItemId" "tree item id" ,classprefix "wxSize" "size" ,classprefix "wxString" "string" ] where classprefix s msg decl | (s == declName decl) = Just msg | isPrefixOf (s++"_") (declName decl) = Just msg | otherwise = Nothing prefix s msg decl | isPrefixOf s (declName decl) = Just msg | otherwise = Nothing equals s msg decl | (s == declName decl) = Just msg | otherwise = Nothing {----------------------------------------------------------------------------------------- Derive types -----------------------------------------------------------------------------------------} deriveTypes :: Bool -> [Decl] -> [Decl] deriveTypes showIgnore decls = map (deriveBetterTypes . deriveOutTypes) (removeDupsAndUndefined shouldIgnore showIgnore decls) deriveTypesAll :: Bool -> [Decl] -> [Decl] deriveTypesAll showIgnore decls = map (deriveBetterTypes . deriveOutTypes) (removeDupsAndUndefined (const Nothing) showIgnore decls) {----------------------------------------------------------------------------------------- Ignore certain decls -----------------------------------------------------------------------------------------} shouldIgnore decl = walk ignore where walk [] = Nothing walk (f:fs) = case f decl of Nothing -> walk fs Just msg -> Just msg {----------------------------------------------------------------------------------------- Remove duplicates and undefined stuff -----------------------------------------------------------------------------------------} removeDupsAndUndefined :: (Decl -> Maybe String) -> Bool -> [Decl] -> [Decl] removeDupsAndUndefined shouldIgnore showIgnore decls = filter Set.empty decls where filter set [] = [] filter set (decl:decls) = case shouldIgnore decl of Just msg -> (if showIgnore then traceIgnore msg decl else id) $ filter set decls other | Set.member (declName decl) set -> traceIgnore "duplicate" decl $ filter set decls | otherwise -> decl : filter (Set.insert (declName decl) set) decls {----------------------------------------------------------------------------------------- Derive "Out" types -----------------------------------------------------------------------------------------} deriveOutTypes :: Decl -> Decl deriveOutTypes decl = case (declRet decl,reverse (declArgs decl)) of -- string (StringLen,Arg name (StringOut ctp) :args) -> decl{ declRet = String ctp, declArgs = reverse args } -- bytestring (ByteStringLen,Arg name (ByteStringOut ctp) :args) -> decl{ declRet = ByteString ctp, declArgs = reverse args } -- int array (ArrayLen,Arg name (ArrayIntOut ctp) :args) -> decl{ declRet = ArrayInt ctp, declArgs = reverse args } -- string array (ArrayLen,Arg name (ArrayStringOut ctp) :args) -> decl{ declRet = ArrayString ctp, declArgs = reverse args } -- object array (ArrayLen,Arg name (ArrayObjectOut cname ctp) :args) -> decl{ declRet = ArrayObject cname ctp, declArgs = reverse args } -- unknown array (ArrayLen,args) -> decl{ declRet = Int CInt, declArgs = reverse args } -- point (Void,Arg name (PointOut ctp ):args) -> decl{ declRet = Point ctp , declArgs = reverse args } -- size (Void,Arg name (SizeOut ctp ):args) -> decl{ declRet = Size ctp , declArgs = reverse args } -- vector (Void,Arg name (VectorOut ctp ):args) -> decl{ declRet = Vector ctp , declArgs = reverse args } -- rect (Void,Arg name (RectOut ctp ):args) -> decl{ declRet = Rect ctp , declArgs = reverse args } -- rect -- just for treectrl::getBoundingRect and listctrl::GetItemRect (Int CInt,Arg name (RectOut ctp ):args) -> decl{ declRet = Rect ctp , declArgs = reverse args } -- reference (Void,Arg _ obj@(RefObject _):args) -> decl{ declRet = obj, declArgs = reverse args } -- other other -> decl {----------------------------------------------------------------------------------------- Derive extended types -----------------------------------------------------------------------------------------} deriveBetterTypes :: Decl -> Decl deriveBetterTypes decl = deriveReturnProperties $ deriveThis $ deriveExtReturn $ deriveExtTypes $ deriveStringReturn $ deriveSimpleTypes $ deriveId $ decl -- Extended types: int x, int y => Point deriveExtTypes decl = decl{ declArgs = deriveExtArgs (declArgs decl) } where -- rectangle deriveExtArgs (Arg x (Int ctp): Arg y (Int _): Arg w (Int _): Arg h (Int _): args) | Set.member (concat x,concat y,concat w,concat h) rectangles = Arg (concat [x,y,w,h]) (Rect ctp): deriveExtArgs args -- point deriveExtArgs (Arg x (Int ctp): Arg y (Int _): args) | Set.member (concat x,concat y) points = Arg (x++y) (Point ctp): deriveExtArgs args -- vector deriveExtArgs (Arg dx (Int ctp): Arg dy (Int _): args) | Set.member (concat dx,concat dy) vectors = Arg (dx++dy) (Vector ctp): deriveExtArgs args -- size deriveExtArgs (Arg w (Int ctp): Arg h (Int _): args) | Set.member (concat w,concat h) sizes = Arg (w++h) (Size ctp): deriveExtArgs args -- other deriveExtArgs (arg:args) = arg:deriveExtArgs args deriveExtArgs [] = [] -- Derive string return: "int fun(..., void* _buf)" deriveStringReturn decl = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of -- string (_,Int _,Arg ["_buf"] (Ptr Void):args) -> decl{ declRet = String CVoid, declArgs = reverse args } (_,Int _,Arg ["_buf"] (Ptr Char):args) -> decl{ declRet = String CChar, declArgs = reverse args } other -> decl -- Extended return types. Like string: "int fun(..., void* _buf)" deriveExtReturn decl = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of -- string (_,Int _,Arg ["_buf"] (Ptr Void):args) -> decl{ declRet = String CVoid, declArgs = reverse args } (_,Int _,Arg ["_buf"] (Ptr Char):args) -> decl{ declRet = String CChar, declArgs = reverse args } -- point (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args) | Set.member (concat x,concat y) points -> decl{ declRet = Point ctp, declArgs = reverse args } (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args) | Set.member (concat x,concat y) points -> decl{ declRet = Point CVoid, declArgs = reverse args } -- rect (_,Void,Arg h (Ptr (Int ctp)):Arg w (Ptr (Int _)):Arg y (Ptr (Int _)):Arg x (Ptr (Int _)):args) | Set.member (concat x,concat y,concat w,concat h) rectangles -> decl{ declRet = Rect ctp, declArgs = reverse args } (_,Void,Arg h (Ptr Void):Arg w (Ptr Void):Arg y (Ptr Void):Arg x (Ptr Void):args) | Set.member (concat x,concat y,concat w,concat h) rectangles -> decl{ declRet = Rect CVoid, declArgs = reverse args } -- size (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args) | Set.member (concat x,concat y) sizes -> decl{ declRet = Size ctp, declArgs = reverse args } (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args) | Set.member (concat x,concat y) sizes -> decl{ declRet = Size CVoid, declArgs = reverse args } -- Vector (_,Void,Arg y (Ptr (Int ctp)):Arg x (Ptr (Int _)):args) | Set.member (concat x,concat y) vectors -> decl{ declRet = Vector ctp, declArgs = reverse args } (_,Void,Arg y (Ptr Void):Arg x (Ptr Void):args) | Set.member (concat x,concat y) vectors -> decl{ declRet = Vector CVoid, declArgs = reverse args } -- Null pointer (Name name,Ptr Void,[]) | isPrefixOf "Null_" name && isClassName cname -> decl{ declRet = Object cname } where cname = "wx" ++ drop 5 name -- Is/Has (Method cname (Normal mname),Int ctp,_) | (isPrefixOf "Is" mname || isPrefixOf "Has" mname || isPrefixOf "Can" mname || mname=="Ok" || isPrefixOf "Contains" mname) -> decl{ declRet = Bool } (Method cname (Normal mname),Ptr Void,_) | isPrefixOf "Create" mname && isClassName createName -- frameCreateStatusBar -> decl{ declRet = Object createName} | isPrefixOf "CreateFrom" mname -- bitmapCreateFromMetafile -> decl{ declRet = Object cname } | mname == "CreateLoad" || mname == "CreateDefault" || mname == "CreateEmpty" || mname == "CreateSized" -- bitmapCreateLoad || mname == "FromRaw" || mname == "FromXPM" -- iconFromRaw -> decl{ declRet = Object cname } where createName = drop (length "Create") mname -- Boolean methods (Method cname (Normal mname),Int ctp,_) | Set.member mname booleanMethods -> decl{ declRet = Bool } -- Object methods (Method cname (Normal mname),Ptr Void,_) -> case Map.lookup mname objectMethods of Just tp -> decl{ declRet = tp } Nothing -> decl -- other other -> decl -- returned properties: assumes that deriveThis has already been done deriveReturnProperties decl = case (classifyName (declName decl),declRet decl,reverse (declArgs decl)) of -- Get via reference (Method cname (Get propname),Void,Arg _ (Ptr Void):args) | isClassName ("wx" ++ propname) -> -- trace ("ref: " ++ propname ++ ": " ++ declName decl) $ decl{ declRet = RefObject ("wx" ++ propname), declArgs = reverse args } (Method cname (Get propname),Void,[Arg _ (Object objname),argself@(Arg _ (Object selfname))]) | selfname == cname -> -- trace ("ref: " ++ objname ++ ": " ++ declName decl) $ decl{ declRet = RefObject objname, declArgs = [argself] } -- bit adventurous: deals with things like "bitmapGetSubBitmap" (Method cname (Get propname),Void,(Arg _ (Object objname):args)) | Map.member propname objectProperties -> case Map.lookup propname objectProperties of Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ decl{ declRet = RefObject name, declArgs = reverse args } Nothing -> traceError ("illegal reference object") decl $ decl (Method cname (Get propname),Void,Arg ["_ref"] (Ptr Void):args) -> case Map.lookup propname objectProperties of Just (Object name) -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ decl{ declRet = RefObject name, declArgs = reverse args } Nothing | cname == "wxListEvent" && propname == "Item" -> -- trace ("ref: ListItem: " ++ declName decl) $ decl{ declRet = RefObject "wxListItem", declArgs = reverse args } | cname == "wxTreeEvent" && propname == "Item" -> -- trace ("ref: TreeItemId: " ++ declName decl) $ decl{ declRet = RefObject "wxTreeItemId", declArgs = reverse args } | cname == "wxTreeEvent" && propname == "OldItem" -> -- trace ("ref: TreeItemId: " ++ declName decl) $ decl{ declRet = RefObject "wxTreeItemId", declArgs = reverse args } | otherwise -> traceWarning ("unknown reference object") decl $ decl{ declRet = RefObject "Ptr", declArgs = reverse args } (Method cname (Normal mname),Void,Arg ["_ref"] (Ptr Void):args) -> case Map.lookup mname referenceObjects of Just name -> -- trace ("ref: " ++ name ++ ": " ++ declName decl) $ decl{ declRet = RefObject name, declArgs = reverse args } Nothing | cname == "wxIconBundle" && mname == "Assign" -> decl{ declRet = RefObject "wxIconBundle", declArgs = reverse args } | otherwise -> traceWarning ("unknown reference object") decl $ decl{ declRet = RefObject "Ptr", declArgs = reverse args } -- Get (Method cname (Get propname),Ptr Void,_) | isClassName ("wx" ++ propname) -> decl{ declRet = Object ("wx" ++ propname) } | otherwise -> case Map.lookup propname objectProperties of Just tp -> decl{ declRet = tp } Nothing -> decl (Method cname (Get propname),Int _,_) | Set.member propname booleanProperties -> decl{ declRet = Bool } -- Set (Method cname (Set propname),_,Arg argname (Ptr Void):args) | isClassName ("wx" ++ propname) -> decl{ declArgs = reverse (Arg argname (Object ("wx"++propname)) : args)} | otherwise -> case Map.lookup propname objectProperties of Just tp -> decl{ declArgs = reverse (Arg argname tp : args)} Nothing -> decl (Method cname (Set propname),_,Arg argname (Int _):args) | Set.member propname booleanProperties -> decl{ declArgs = reverse (Arg argname Bool : args)} -- other other -> decl -- Simple types: char* => String deriveSimpleTypes decl = decl{ declArgs = deriveArgs (declArgs decl) } where deriveArgs args = map (\arg -> arg{ argType = deriveArg arg }) args deriveArg arg = case argType arg of Ptr Char -> String CChar Int ctp | Set.member (argName arg) booleans -> Bool | isPrefixOf "is" (argName arg) -> Bool Ptr Void -> case Map.lookup (argName arg) objects of Just name -> Object name _ -> case Map.lookup (argName arg) functions of Just tp -> Fun tp _ | Set.member (argName arg) strings -> String CVoid | isClassName cargName -> Object cargName | otherwise -> Ptr Void where cargName = case argName arg of (c:cs) -> "wx" ++ (toUpper c : cs) other -> other tp -> tp -- Check for "this" pointer -- derive for "wxObject_Create :: ... -> IO (Ptr ())" deriveThis decl = case classifyName (declName decl) of Create cname | declRet decl == Ptr Void -- bitmapCreate -> decl{ declRet = Object cname } Method cname m | not (null args) && (argType (head args) == Ptr Void) && not (elem cname ["ELJApp"]) -> decl{ declArgs = (head args){ argType = Object cname} : tail args } other -> decl where args = declArgs decl -- derive event ids: int expEVT_XXX() and expXXX_XXX(); deriveId decl@Decl{ declRet = Int _, declArgs = [] } | isPrefixOf "expEVT_" (declName decl) = decl{ declRet = EventId } deriveId decl@Decl{ declRet = Int _, declArgs = [] } | isPrefixOf "exp" (declName decl) = decl{ declRet = Id } deriveId decl = decl {----------------------------------------------------------------------------------------- Names -----------------------------------------------------------------------------------------} data Name = Name String | Create { className :: ClassName } | Method { className :: ClassName, method :: Method } deriving Show data Method = Normal { methodName :: MethodName } | Set { propName :: PropertyName } | Get { propName :: PropertyName } deriving Show type ClassName = String type MethodName = String type PropertyName = String classifyName :: String -> Name classifyName s = case s of ('w':'x':name) -> className s ('c':'b':name) -> className s (c:cs) | isUpper c -> className s other -> Name s where className name = case (span (/='_') name) of (cname,method) | isClassName cname && not (null method) -> if (method == "_Create") then Create cname else if (isPrefixOf "_Get" method) then Method cname (Get (drop 4 method)) else if (isPrefixOf "_Set" method) then Method cname (Set (drop 4 method)) else Method cname (Normal (drop 1 method)) (_,_)-> Name s