PriLabel.hs

module Graphics.UI.AF.General.PriLabel
    ( PriLabel(..)
    , Priority(..)
    , badConstrLabel, goodConstrLabel, fieldNameLabel, userDefinedLabel
    , bestLabel, humanizeLabel
    , defaultLabel, labelless
    )
where

import Char

-- |Prioritized label. If two 'PriLabel' can be used for some
--  component, then the one with highest priority is used.
data PriLabel = PriLabel { priority :: Priority, labelString :: String } deriving (Show)
-- |The label priority.
data Priority = BadConstr | GoodConstr | FieldName | UserDefined deriving (Show, Ord, Eq)

badConstrLabel, goodConstrLabel, fieldNameLabel, userDefinedLabel :: String -> PriLabel
badConstrLabel   label = PriLabel BadConstr   label
goodConstrLabel  label = PriLabel GoodConstr  label
fieldNameLabel   label = PriLabel FieldName   label
userDefinedLabel label = PriLabel UserDefined label

-- |Creates a default (lowest priority) PriLabel
defaultLabel :: String -> PriLabel
defaultLabel label = PriLabel BadConstr label

labelless :: PriLabel
labelless = defaultLabel ""

-- |Choose label with highest priority. If equal then choose the left
-- |(first parameter) label.
bestLabel :: PriLabel -> PriLabel -> PriLabel
bestLabel left@(PriLabel priL _) right@(PriLabel priR _)
    | priL >= priR  = left
    | otherwise     = right

-- |Humanized label strings, by turning labels like "someLabelName"
-- into "Some label name".
humanizeLabel :: PriLabel -> PriLabel
humanizeLabel (PriLabel pri label) = PriLabel pri label'
    where
    label' | pri == UserDefined || elem ' ' label -- safegaurd against accidentally calling humanizeLabel twice 
                                = label
           | elem '_' label     = (first toUpper . nonCamel) label
           | otherwise          = camelCase label
    -- humanizing non-camel case identifiers
    nonCamel []             = []
    nonCamel ('_':[])       = []
    nonCamel (x:[])         = x:[]
    nonCamel ('_':x:[])     = ' ':toUpper x:[]
    nonCamel (x:y:[])       = x:nonCamel [y]
    nonCamel ('_':x:y:xs)
        | isUpper y         = ' ':toUpper x:nonCamel (y:xs)
        | otherwise         = ' ':toLower x:nonCamel (y:xs)
    nonCamel (x:xs)         = x:nonCamel xs
    --
    camelCase xs            = (first toUpper . drop 1 . seperateWords [] . first toUpper) xs
    seperateWords cs []           = cs
    seperateWords [] (x:xs)
        | isUpper x               = ' ':seperateWords [x] xs
        | otherwise               =   x:seperateWords [] xs
    seperateWords (c:[]) (x:xs)
        | isUpper x               = seperateWords (c:x:[]) xs
        | otherwise               = toLower c:x:seperateWords [] (xs)
    seperateWords (cs) (x:xs)
        | isUpper x               = seperateWords (cs ++ [x]) xs
        | otherwise               = (init cs) ++ ' ':(toLower $ last cs):x:seperateWords [] xs
    first _ []     = []
    first f (x:xs) = (f x):xs


{-

testHumanizeLabel :: IO ()
testHumanizeLabel = putStr $ unlines $ map testLabel tests
    where
      testLabel (actual, expected)
          = let (PriLabel _ result) = humanizeLabel (PriLabel GoodConstr actual)
            in (if result == expected then "True" else "Error (" ++ result ++ ")") ++ ": " ++ actual ++ " " ++ expected
      tests = [-- Underscore upper case
                ("download_Site_URI", "Download site URI")
              , ("default_Contents_Author", "Default contents author")
              , ("default_Contents_License", "Default contents license")
              , ("foobar_ASD_Foo", "Foobar ASD foo")
              -- Underscore lower case 
              , ("download_site", "Download site")
              , ("foobar_ASD_foo", "Foobar ASD foo")
              -- Camel case
              , ("FooBarSky", "Foo bar sky")
              , ("FooBASky", "Foo BA sky")
              , ("foobarASDFoo", "Foobar ASD foo")
              --
              , ("a", "A")
              , ("A", "A")
              , ("", "")
              , ("FOO", "FOO")
              ] ++ map (\x -> (x,x)) [ "Download FOO site", "Download something", "Foo" ]
      
-}

{- Rest is trash:

    replace _ _ []                = []
    replace this with (x:xs)
        | this == x               = with:replace this with xs   
        | otherwise               = x:replace this with xs

           -- | elem '_' label     = (first toUpper . replace '_' ' ') label
-}