--------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (c) Levent Erkok -- License : BSD3 -- Maintainer : erkokl@gmail.com -- Stability : experimental -- -- Main entry point for the crackNum executable ----------------------------------------------------------------------------- {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternGuards #-} module Main(main) where import Control.Monad (zipWithM_) import Data.Char (isHexDigit, isDigit) import Data.Maybe (fromMaybe, listToMaybe, isNothing) import System.Console.GetOpt (ArgOrder(Permute), getOpt, ArgDescr(..), OptDescr(..), usageInfo) import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import Data.Numbers.CrackNum import Data.Numbers.CrackNum.Utils import Data.Version (showVersion) import Paths_crackNum (version) copyRight :: String copyRight = "(c) Levent Erkok. Released with a BSD3 license." -- | Options accepted by the executable data Flag = FPType Precision -- ^ Crack as a Floating Point with given precision | IType IPrecision -- ^ Crack as an Integer with the given number of bits | ToIEEE String -- ^ Convert to IEEE SP/DP value | Lanes String -- ^ Number of lanes present in the input, crackNum can guess but it can also be specified. | Help -- ^ Help | VIM -- ^ Are we being called from VIM? | Version -- ^ Version deriving Eq options :: [OptDescr Flag] options = [ Option "" ["hp"] (NoArg (FPType HP)) "16 bit half precision" , Option "" ["sp"] (NoArg (FPType SP)) "32 bit single precision" , Option "" ["dp"] (NoArg (FPType DP)) "64 bit double precision" , Option "" ["sb"] (NoArg (IType I8)) " 8 bit signed byte" , Option "" ["sw"] (NoArg (IType I16)) "16 bit signed word" , Option "" ["sd"] (NoArg (IType I32)) "32 bit signed double" , Option "" ["sq"] (NoArg (IType I64)) "64 bit signed quad" , Option "" ["ub"] (NoArg (IType W8)) " 8 bit unsigned byte" , Option "" ["uw"] (NoArg (IType W16)) "16 bit unsigned word" , Option "" ["ud"] (NoArg (IType W32)) "32 bit unsigned double" , Option "" ["uq"] (NoArg (IType W64)) "64 bit unsigned quad" , Option "" ["toIEEE"] (ReqArg ToIEEE "n") "Convert from decimal to IEEE SP/DP formats." , Option "l" ["lanes"] (ReqArg Lanes "n") "number of lanes" , Option "" ["vim"] (NoArg VIM) "output in vim friendly format" , Option "h?" ["help"] (NoArg Help) "print help, with examples" , Option "v" ["version"] (NoArg Version) "print version info" ] helpStr :: String -> String helpStr pn = usageInfo ("Usage: " ++ pn ++ " precision bit/hex-pattern") options usage :: String -> IO () usage pn = do putStrLn $ helpStr pn putStrLn "Examples:" putStrLn "" putStrLn $ " " ++ pn ++ " --hp fc00" putStrLn $ " " ++ pn ++ " --sp fc00 abcd" putStrLn $ " " ++ pn ++ " --dp fc00 abc1 2345 6789" putStrLn $ " " ++ pn ++ " --sp 01111111110000000000000000000000" putStrLn $ " " ++ pn ++ " -l2 --hp 01111111110000000000000000000000" putStrLn $ " " ++ pn ++ " --sb 7f" putStrLn $ " " ++ pn ++ " --sp --toIEEE=-2.3e6" putStrLn $ " " ++ pn ++ " --dp --toIEEE=max" putStrLn $ " " ++ pn ++ " --dp --toIEEE=ulp" putStrLn "" putStrLn "Notes:" putStrLn " - You can use hexadecimal or binary as input." putStrLn " - You can use _,- or space as a digit to improve readability." putStrLn " - You can give input for multiple lanes, we will guess the #of lanes for you." putStrLn " Or, you can specify number of lanes with the -l option." putStrLn " - For \"toIEEE\" option (case doesn't matter):" putStrLn " - You can enter a number in decimal notation (like 2.3)" putStrLn " - You can enter a number in hexadecimal notation (like 0x1.abcp+3)" putStrLn " - OR, enter one of the following:" putStrLn " * infinity, -infinity: Positive/Negative infinities" putStrLn " * nan, snan, qnan: Not-A-Number; signaling/quiet" putStrLn " * 0, -0: Both kinds of zeros" putStrLn " * max : The maximum finite positive value" putStrLn " * -max: The minimum finite negative value" putStrLn " * min : The minimum normal positive value" putStrLn " * -min: The maximum normal negative value" putStrLn " * epsilon: The smallest possible value x s.t. 1+x /= 1." putStrLn " * ulp: The minimum subnormal value" exitFailure -- instead of dealing with vimscript, munge our args here.. heh vimpret :: [String] -> [String] vimpret args = case break (== "--bv") args of ([p], "--bv":rest) -> case mkArgs p of Nothing -> ["--help"] Just pr -> ("--" ++ pr) : rest _ -> ["--help"] where bad = (`elem` ["lanes", "vim", "help"]) validPrecs = filter (not . bad) $ concat [xs | Option _ xs _ _ <- options] dvalidPrecs = map ('-':) validPrecs ddvalidPrecs = map ('-':) dvalidPrecs mkArgs p | p `elem` validPrecs = Just p | p `elem` dvalidPrecs = Just (drop 1 p) | p `elem` ddvalidPrecs = Just (drop 2 p) | True = Nothing main :: IO () main = do origArgs <- getArgs origPN <- getProgName let -- bugger.. make the args a bit more friendly friendly :: String -> String friendly ('-':ns) -- -2/-3 etc become lane stuff | all isDigit ns = "-l" ++ ns friendly ('-':c:cs) | c `notElem` "-l" = "--" ++ (c:cs) friendly s = s cleanArgs = map friendly origArgs (argv, pn) | "--vim" `elem` cleanArgs = ("--vim" : vimpret (filter (/= "--vim") cleanArgs), "CrackNum") | True = (cleanArgs, origPN) case getOpt Permute options argv of (os, rs, []) -> if Version `elem` os then putStrLn $ pn ++ " v" ++ showVersion version ++ ", " ++ copyRight else process pn os rs (_, _, errs) -> do mapM_ putStrLn errs putStr $ helpStr pn where getChosenPrec os = case [p | p@FPType{} <- os] ++ [p | p@IType{} <- os] of [p] -> Just p _ -> Nothing process pn os rs | Help `elem` os = do putStrLn $ pn ++ " v" ++ showVersion version ++ ", " ++ copyRight usage pn | Just v <- listToMaybe [s | ToIEEE s <- os], null rs, Just (FPType p) <- mbPrec = putStrLn $ displayFP $ stringToFP p v | all isDigit lcs && lc > 0, Just p <- mbPrec = lane pn (VIM `elem` os) lc p rs | True = putStr $ helpStr pn where mbPrec = getChosenPrec os lcs = fromMaybe (show (guessLaneCount mbPrec (cleanUp (concat rs)))) (listToMaybe (reverse [n | Lanes n <- os])) lc = read lcs -- Try to guess the lane count if not given; if we can't we'll just return 1 guessLaneCount :: Maybe Flag -> String -> Int guessLaneCount mbp s | not (allHex || allBin) = 1 | isNothing mbp = 1 | Just (FPType p) <- mbp = guessFP ls p | Just (IType p) <- mbp = guessIP ls p | True = 1 where allHex = all isHexDigit s allBin = all isBinDigit s ls | allBin = length s | True = 4 * length s -- | Guess lane count for floating-point guessFP :: Int -> Precision -> Int guessFP 0 _ = 1 guessFP l p | r == 0 = q | True = 1 where sz = fpSz p (q, r) = l `quotRem` sz -- | Guess lane count for integer guessIP :: Int -> IPrecision -> Int guessIP 0 _ = 1 guessIP l p | r == 0 = q | True = 1 where (_, sz) = sgSz p (q, r) = l `quotRem` sz -- | Do the lane.. lane :: String -> Bool -> Int -> Flag -> [String] -> IO () lane pn _ 1 f rs = dispatch pn f rs lane pn vim n f rs | ls `mod` n /= 0 = help $ "Input length " ++ show ls ++ " is not a multiple of lane count: " ++ show n | True = zipWithM_ cvt [n-1, n-2 .. 0] (cluster n s) where s = cleanUp (concat rs) ls = length s help m = do putStrLn $ pn ++ ": " ++ m usage pn cvt i r = do putStrLn $ vimMarker vim ++ mkHeader (Just i) f dispatch pn f [r] vimMarker :: Bool -> String vimMarker False = "" vimMarker True = "VIM " -- | Display the ruler.. mkHeader :: Maybe Int -> Flag -> String mkHeader mbl f = take (fit len) divider where divider | Just l <- mbl = "== Lane: " ++ show l ++ ' ' : repeat '=' | True = repeat '=' fit n = 30 `max` (n + 19) len = case f of FPType p -> fpLen p IType p -> ipLen p _ -> 80 get p xs = fromMaybe 78 (lookup p xs) fpLen p = get p [ (HP, 8 + length hpInds3) , (SP, length spInds3) , (DP, length dpInds3) ] ipLen p = get p [ (W8, length bInds2), (I8, length bInds2) , (W16, length wInds2), (I16, length wInds2) , (W32, length dInds2), (I32, length dInds2) , (W64, length qInds2), (I32, length qInds2) ] dispatch :: String -> Flag -> [String] -> IO () dispatch pn p@FPType{} rs = unpack pn p (unwords rs) dispatch pn p@IType{} rs = unpack pn p (unwords rs) dispatch pn _ _ = usage pn unpack :: String -> Flag -> String -> IO () unpack pn prec orig = case (prec, length s, allHex, allBin) of (FPType HP, 4, True, _ ) -> putStrLn $ displayFP $ integerToFP HP hexVal (FPType HP, 16, _ , True) -> putStrLn $ displayFP $ integerToFP HP binVal (FPType SP, 8, True, _ ) -> putStrLn $ displayFP $ integerToFP SP hexVal (FPType SP, 32, _ , True) -> putStrLn $ displayFP $ integerToFP SP binVal (FPType DP, 16, True, _ ) -> putStrLn $ displayFP $ integerToFP DP hexVal (FPType DP, 64, _ , True) -> putStrLn $ displayFP $ integerToFP DP binVal (IType I8, 2, True, _ ) -> putStrLn $ displayWord I8 hexVal (IType I8, 8, _ , True) -> putStrLn $ displayWord I8 binVal (IType W8, 2, True, _ ) -> putStrLn $ displayWord W8 hexVal (IType W8, 8, _ , True) -> putStrLn $ displayWord W8 binVal (IType I16, 4, True, _ ) -> putStrLn $ displayWord I16 hexVal (IType I16, 16, _ , True) -> putStrLn $ displayWord I16 binVal (IType W16, 4, True, _ ) -> putStrLn $ displayWord W16 hexVal (IType W16, 16, _ , True) -> putStrLn $ displayWord W16 binVal (IType I32, 8, True, _ ) -> putStrLn $ displayWord I32 hexVal (IType I32, 32, _ , True) -> putStrLn $ displayWord I32 binVal (IType W32, 8, True, _ ) -> putStrLn $ displayWord W32 hexVal (IType W32, 32, _ , True) -> putStrLn $ displayWord W32 binVal (IType I64, 16, True, _ ) -> putStrLn $ displayWord I64 hexVal (IType I64, 64, _ , True) -> putStrLn $ displayWord I64 binVal (IType W64, 16, True, _ ) -> putStrLn $ displayWord W64 hexVal (IType W64, 64, _ , True) -> putStrLn $ displayWord W64 binVal _ -> if not (null orig) then do case prec of FPType HP -> putStrLn $ "ERROR: HP format requires 4 hex or 16 bin digits, received: " ++ what FPType SP -> putStrLn $ "ERROR: SP format requires 8 hex or 32 bin digits, received: " ++ what FPType DP -> putStrLn $ "ERROR: DP format requires 16 hex or 64 bin digits, received: " ++ what IType I8 -> putStrLn $ "ERROR: Signed byte format requires 2 hex or 8 bin digits, received: " ++ what IType I16 -> putStrLn $ "ERROR: Signed word format requires 4 hex or 16 bin digits, received: " ++ what IType I32 -> putStrLn $ "ERROR: Signed double format requires 8 hex or 32 bin digits, received: " ++ what IType I64 -> putStrLn $ "ERROR: Signed quad format requires 16 hex or 64 bin digits, received: " ++ what IType W8 -> putStrLn $ "ERROR: Unsigned byte format requires 2 hex or 8 bin digits, received: " ++ what IType W16 -> putStrLn $ "ERROR: Unsigned word format requires 4 hex or 16 bin digits, received: " ++ what IType W32 -> putStrLn $ "ERROR: Unsigned double format requires 8 hex or 32 bin digits, received: " ++ what IType W64 -> putStrLn $ "ERROR: Unsigned quad format requires 16 hex or 64 bin digits, received: " ++ what _ -> putStrLn $ "ERROR: Illegal input received: " ++ what putStrLn $ "\nUse '" ++ pn ++ " --help' for detailed help." exitFailure else usage pn where s = cleanUp orig ls = length s allHex = all isHexDigit s allBin = all isBinDigit s hexVal = readB16 s binVal = readB2 s what | allHex && allBin = show ls ++ " bin/hex digit" ++ plural | allHex = show ls ++ " hex digit" ++ plural | allBin = show ls ++ " bin digit" ++ plural | True = show ls ++ " bogus digit" ++ plural where plural | ls == 1 = "" | True = "s"