Internal.hs

{-# LANGUAGE FlexibleContexts #-}

module Data.Hourglass.FuzzyParsing.Internal where

import Data.Char      (digitToInt, isDigit, toUpper)
import Data.Hourglass (Month)
import Data.List      (isPrefixOf)

import Text.Parsec

-- | Parser version of Prelude.read
tryRead :: (Read a, Stream s m Char) => String -> ParsecT s st m a
tryRead str =
  case reads str of
    [(res, "")] -> return res
    _ -> fail $ "Cannot read: " ++ str

tryReadInt :: (Stream s m Char, Num a) => String -> ParsecT s st m a
tryReadInt str =
  if all isDigit str
    then return $ fromIntegral $ foldl (\a b -> 10*a+b) 0 $ map digitToInt str
    else fail $ "Cannot read: " ++ str

-- | Apply parser N times
times :: (Stream s m Char)
      => Int
      -> ParsecT s st m t
      -> ParsecT s st m [t]
times 0 _ = return []
times n p = do
  ts <- times (n - 1) p
  t <- optionMaybe p
  case t of
    Just t' -> return (ts ++ [t'])
    Nothing -> return ts

-- | Parse natural number of N digits which is not greater than M
number :: (Stream s m Char, Num a, Ord a)
       => Int -- ^ Number of digits
       -> a   -- ^ Maximum value
       -> ParsecT s st m a
number n m = do
  t <- tryReadInt =<< (n `times` digit)
  if t > m
    then fail "number too large"
    else return t

pYear :: Stream s m Char => ParsecT s st m Int
pYear = do
  y <- number 4 10000
  if y < 2000
    then return (y + 2000)
    else return y

pMonth :: Stream s m Char => ParsecT s st m Month
pMonth = toEnum . pred <$> number 2 12

pDay :: Stream s m Char => ParsecT s st m Int
pDay = number 2 31

uppercase :: String -> String
uppercase = map toUpper

-- | Case-insensitive version of 'isPrefixOf'
isPrefixOfI :: String -> String -> Bool
p `isPrefixOfI` s = uppercase p `isPrefixOf` uppercase s

-- | Use a data type's Bounded, Enum and Show instances to determine if the
-- given string uniquely matches a constructor. The comparison is
-- case-insensitive and starts from the beginning of the strings (so a partial
-- constructor name can still match if there are enough characters for a
-- unique match)
--
-- For example:
--
-- @
--  data Things = Foo | Bar | Baz deriving (Bounded, Enum, Show)
--
--  -- Right Foo
--  uniqFuzzyMatch "f" :: Either [Things] Things
--
--  -- Left [Bar, Baz]
--  uniqFuzzyMatch "ba" :: Either [Things] Things
-- @
uniqFuzzyMatch :: (Bounded a, Enum a, Show a)
               => String
               -> Either [a] a -- ^ Either collection of matches or the unique match
uniqFuzzyMatch n = if length matches == 1
                      then Right (head matches)
                      else Left matches
  where
    possibilities = [minBound..maxBound]
    matches = filter (isPrefixOfI n . show) possibilities