{-# LANGUAGE ExplicitForAll      #-}
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}

module Main
where

import           Control.Arrow ( (***), second )

import           Data.Char ( toLower, toUpper )
import           Data.List ( isPrefixOf )
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import           Data.String (IsString (..))
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL

import           System.Exit (ExitCode (..), exitWith)

import           Test.HUnit

import           Text.Parsec
import           Text.Regex.XMLSchema.Generic
import           Text.Regex.XMLSchema.Generic.StringLike

-- ------------------------------------------------------------

newtype Test' a = Test' {unTest' :: Test}

type BS    = B.ByteString
type BL    = BL.ByteString
type Text  = T.Text
type TextL = TL.Text

-- ------------------------------------------------------------
-- some little helpers for building r.e.s

star                  :: String -> String
star                  = (++ "*") . pars

plus                  :: String -> String
plus                  = (++ "+") . pars

opt                   :: String -> String
opt                   = (++ "?") . pars

dot                   :: String -> String
dot                   = (++ "\\.")

pars                  :: String -> String
pars                  = ("(" ++) . (++ ")")

orr                   :: String -> String -> String
orr x y               = pars $ pars x ++ "|" ++ pars y

xor                   :: String -> String -> String
xor x y               = pars $ pars x ++ "{|}" ++ pars y

nocase                :: String -> String
nocase                (x:xs)  = '[' : toUpper x : toLower x : ']' : xs
nocase []             = error "nocase with empty list"

alt                   :: [String] -> String
alt                   = pars . foldr1 orr

altNC                 :: [String] -> String
altNC                 = pars . alt . map nocase

subex                 :: String -> String -> String
subex n e             = pars $ "{" ++ n ++ "}" ++ pars e

ws                    :: String
ws                    = "\\s"

ws0                   :: String
ws0                   = star ws

ws1                   :: String
ws1                   = plus ws

s0                    :: String -> String -> String
s0 x y                = x ++ ws0 ++ y

-- the date and time r.e.s

day                   :: String
day                   = "(0?[1-9]|[12][0-9]|3[01])"

month                 :: String
month                 = "(0?[1-9]|1[0-2])"

year2                 :: String
year2                 = "[0-5][0-9]"

year4                 :: String
year4                 = "20" ++ year2

year                  :: String
year                  = year4 `orr` year2

year'                 :: String
year'                 = "'" ++ year2

dayD                  :: String
dayD                  = dot day
monthD                :: String
monthD                = dot month

dayMonthYear          :: String
dayMonthYear          = dayD `s0` monthD `s0` year
dayMonth              :: String
dayMonth              = dayD `s0` monthD

dayOfWeekL            :: String
dayOfWeekL            = altNC
                        [ "montag"
                        , "dienstag"
                        , "mittwoch"
                        , "donnerstag"
                        , "freitag"
                        , "samstag"
                        , "sonnabend"
                        , "sonntag"
                        ]

dayOfWeekA            :: String
dayOfWeekA            = alt . map dot $
                        [ "Mo", "Di", "Mi", "Do", "Fr", "Sa", "So"]

dayOfWeek             :: String
dayOfWeek             = dayOfWeekL `orr` dayOfWeekA

monthL                :: String
monthL                = altNC
                        [ "januar"
                        , "februar"
                        , "märz"
                        , "april"
                        , "mai"
                        , "juni"
                        , "juli"
                        , "august"
                        , "september"
                        , "oktober"
                        , "november"
                        , "dezember"
                        ]

monthA                :: String
monthA                = altNC . map dot $ map snd monthAbr

monthAbr              :: [(Integer, String)]
monthAbr              = (9, "sept") :
                        zip [1..12]
                        [ "jan", "feb", "mär", "apr", "mai", "jun", "jul", "aug", "sep", "okt", "nov", "dez"]

monthN                :: String
monthN                = pars $ monthL `orr` monthA

hour                  :: String
hour                  = pars "([0-1]?[0-9])|(2[0-4])"

minute                :: String
minute                = pars "(0?[0-9])|([1-5][0-9])"

uhr                   :: String
uhr                   = ws0 ++ nocase "uhr"

hourMin               :: String
hourMin               = hour ++ ":" ++ minute ++ opt uhr

wsyear                :: String
wsyear                = year ++ "/[0-9]{2}"

wsem                  :: String
wsem                  = ("Wi?Se?" `orr` nocase "Wintersemester") ++ ws0 ++ wsyear

ssem                  :: String
ssem                  = ("So?Se?" `orr` nocase "Sommersemester") ++ ws0 ++ year

sem                   :: String
sem                   = wsem `orr` ssem

num                   :: String
num                   = "\\d+"

-- the token types

tokenRE               :: String
tokenRE               = foldr1 xor $
                        map  (uncurry subex) $
                        [ ( "ddmmyyyy",    dayMonthYear )
                        , ( "ddMonthyyyy", dayD `s0` monthN `s0` (year `orr` year') )
                        , ( "ddmm",        dayMonth)
                        , ( "ddMonth",     dayD `s0` monthN )
                        , ( "yyyymmdd",    year ++ "[-/]" ++ month ++ "[-/]" ++ day )
                        , ( "yyyy",        year4 `orr` ("'" ++ year2) )
                        , ( "month",       monthN )
                        , ( "weekday",     dayOfWeek )
                        , ( "HHMM",        hourMin ++ opt uhr )
                        , ( "HH",          hour    ++ uhr )
                        , ( "wsem",        wsem)
                        , ( "ssem",        ssem)
                        , ( "word",        "[\\w\\d]+")
                        , ( "del",         "[^\\w\\d]+")
                        ]


-- ------------------------------------------------------------

type Token         = (String, String)
type TokenStream   = [Token]

type DateParser a  = Parsec [(String, String)] () a

type StringFct          = String -> String           -- for fast concatenation

-- must be extended for weekday or semester, if neccessay

data DateVal       = DT  { _year   :: ! Int
                         , _month  :: ! Int
                         , _day    :: ! Int
                         , _hour   :: ! Int
                         , _min    :: ! Int
                         }
                     deriving (Eq, Show)

data DateParse     = DP { _pre    ::   StringFct
                        , _rep    ::   StringFct
                        , _dat    :: ! DateVal
                        }

-- just a helper for result output
data DateRep       = DR { _p ::   String
                        , _r ::   String
                        , _d :: ! DateVal
                        }
                     deriving (Eq, Show)

-- ------------------------------------------------------------

emptyText       :: StringFct
emptyText       = id

mkText          :: String -> StringFct
mkText          = (++)

concText        :: StringFct -> StringFct -> StringFct
concText        = (.)

textToString    :: StringFct -> String
textToString    = ($ [])

emptyDateVal    :: DateVal
emptyDateVal    = DT { _year   = -1
                     , _month  = -1
                     , _day    = -1
                     , _hour   = -1
                     , _min    = -1
                     }

emptyDateParse  :: DateParse
emptyDateParse  = DP { _pre = emptyText
                     , _rep = emptyText
                     , _dat = emptyDateVal
                     }

appPre          :: String -> DateParse -> DateParse
appPre s d      = d { _pre = _pre d `concText` mkText s }

appRep          :: String -> DateParse -> DateParse
appRep s d      = d { _rep = _rep d `concText` mkText s }

setDay          :: Int -> Int -> Int -> DateParse -> DateParse
setDay j m t d  = d { _dat = setDateVal j m t (-1) (-1) (_dat d) }

setHour         :: Int -> Int -> DateParse -> DateParse
setHour h m d   = d { _dat = setDateVal (-1) (-1) (-1) h m (_dat d) }

setDateVal      :: Int -> Int -> Int -> Int -> Int -> DateVal -> DateVal
setDateVal j m t s i (DT j' m' t' s' i' )
                = DT j'' m'' t'' s'' i''
    where
      j'' | j < 0     = j'              -- year not there
          | j < 100   = j + 2000        -- 2 digit year
          | otherwise = j               -- 4 digit year
      m''             = m `max` m'
      t''             = t `max` t'
      s''             = s `max` s'
      i''             = i `max` i'

datePToDateRep  :: DateParse -> DateRep
datePToDateRep dp
                = DR { _p = textToString $ _pre dp
                     , _r = textToString $ _rep dp
                     , _d =                _dat dp
                     }

-- ------------------------------------------------------------

-- a simple helper for showing the results

dateSearch'     :: TokenStream -> [DateRep]
dateSearch'     = map datePToDateRep .
                  dateSearch

-- look for a sequence of date specs, the last entry in the list
-- does not contain a valid date, but just the context behind the last real date

dateSearch      :: TokenStream -> [DateParse]
dateSearch      = either (const []) id .
                  parse (many (dateParser emptyDateParse)) ""

-- all date parsers thread a state the subparsers to accumulate
-- the parts of a date, the context, the external representation and
-- the pure data, year, month, day, ...

dateParser      :: DateParse -> DateParser DateParse
dateParser d    = ( do
                    s <- fillTok
                    dateParser0 (appPre s d)
                  )
                  <|>
                  parseDate d                   -- here is the hook for the real date parser
                  <|>
                  ( do
                    s <- textTok                -- the default case: if parseDate fails
                    dateParser0 (appPre s d)    -- the token is handled like a normal word
                  )

dateParser0     :: DateParse -> DateParser DateParse
dateParser0 d   = dateParser d <|> return d


parseDate       :: DateParse -> DateParser DateParse
parseDate d     = parseDate0 d
                  <|>
                  try
                  ( do
                    d1 <- parseWeekDay d
                    lookAheadN 3 parseDate0 d1  -- Freitag, den 13.
                  )

-- parse a date optionally followed by a time
parseDate0      :: DateParse -> DateParser DateParse
parseDate0 d    = ( do
                    d1 <- parseDay d
                    option d1 (parseFollowingHour d1)
                  )

-- parse a simple token for a day
parseDay        :: DateParse -> DateParser DateParse
parseDay d      = ( do
                    (s, d') <- parseDateTok "ddmmyyyy" d
                    let [t, m, j] = tokenize num s
                    return $ setDay (read j) (read m) (read t) d'
                  )
                  <|>
                  ( do
                    (s, d') <- parseDateTok "ddMonthyyyy" d
                    let s' = sed ((++ ".") . monthToM) monthN s
                    let [t, m, j] = tokenize num s'
                    return $ setDay (read j) (read m) (read t) d'
                  )
                  <|>
                  ( do
                    (s, d') <- parseDateTok "ddmm" d
                    let [t, m] = tokenize num s
                    return $ setDay (-1) (read m) (read t) d'
                  )
                  <|>
                  ( do
                    (s, d') <- parseDateTok "ddMonth" d
                    let s'     = sed ((++ ".") . monthToM) monthN s
                    let [t, m] = tokenize num s'
                    return $ setDay (-1) (read m) (read t) d'
                  )
                  <|>
                  ( do
                    (s, d') <- parseDateTok "yyyymmdd" d
                    let [j, m, t] = tokenize num s
                    return $ setDay (read j) (read m) (read t) d'
                  )

parseYear       :: DateParse -> DateParser DateParse
parseYear d     = ( do
                    (s, d') <- parseDateTok "yyyy" d
                    let [j] = tokenize num s
                    return $ setDay (read j) (-1) (-1) d'
                  )

-- parse a weekday and add it to the external rep.

parseWeekDay    :: DateParse -> DateParser DateParse
parseWeekDay d  = ( do
                    (_s, d') <- parseDateTok "weekday" d
                    return d'
                  )

-- parse a following hour spec, 5 fill tokens, words or delimiters are possible

parseFollowingHour      :: DateParse -> DateParser DateParse
parseFollowingHour
                = try .                         -- backtracking becomes neccessary
                  lookAheadN 5 parseHour        -- max 2 words and 3 delimiters

-- parse the simple time formats
parseHour       :: DateParse -> DateParser DateParse
parseHour d     = ( do
                    (s, d') <- parseDateTok "HHMM" d
                    let [h, m] = tokenize num s
                    return $ setHour (read h) (read m) d'
                  )
                  <|>
                  ( do
                    (s, d') <- parseDateTok "HH" d
                    let [h] = tokenize num s
                    return $ setHour (read h) 0 d'
                  )

-- ------------------------------------------------------------
--
-- auxiliary parser combinators

-- parse a token of a given type and add the text to the external rep.

parseDateTok    :: String -> DateParse -> DateParser (String, DateParse)
parseDateTok tty d
                = dateTok (isTokType (== tty)) d

dateTok         :: DateParser String -> DateParse -> DateParser (String, DateParse)
dateTok t d     = ( do
                    s <- t
                    return (s, appRep s d)
                  )

-- try to apply a parser, but first skip a given # of fill tokens

lookAheadN      :: Int -> (DateParse -> DateParser DateParse) -> DateParse -> DateParser DateParse
lookAheadN n p d
    | n <= 0    = p d
    | otherwise = do
                  (_, d1) <- dateTok fillTok d
                  ( lookAheadN (n - 1) p d1 <|> p d1 )

-- ------------------------------------------------------------
--
-- basic token parsers

-- the interface to the primitive parsec token parser
tok             :: (Token -> Bool) -> DateParser Token
tok prd         = tokenPrim showTok nextPos testTok
    where
      showTok               = show . fst
      nextPos pos _tok _ts  = incSourceColumn pos 1
      testTok tk            = if prd tk then Just tk else Nothing

-- check for specific token type and in case of success return the text value
isTokType       :: (String -> Bool) -> DateParser String
isTokType isT   = tok (isT . fst) >>= return . snd

-- parse an arbitrary token and return the text value
textTok         :: DateParser String
textTok         = isTokType (const True)

-- a word
wordTok         :: DateParser String
wordTok         = isTokType (== "word")

-- a delimiter, whitespace is normalized, sequences are reduced to a single space char
delTok          :: DateParser String
delTok          = isTokType (== "del")
                  >>=
                  return . sed (const " ") ws1

-- tokens that don't contain date info

fillTok         :: DateParser String
fillTok         = delTok <|> wordTok

-- semester tokens, not yet interpreted
semTok'         :: String -> DateParser (String, Int, Bool)
semTok' sem'     = do v <- isTokType (== sem')
                      return (v, read . head . tokenizeExt year $ v, sem' == "ssem")

semTok          :: DateParser (String, Int, Bool)
semTok          = semTok' "ssem" <|> semTok' "wsem"

-- ------------------------------------------------------------

-- conversion from month names to 1..12
monthToM        :: String -> String
monthToM m
    = show .
      (\ l -> if null l then 99 else head l) .
      map fst .
      filter ((== True) . snd) .
      map (second (`isPrefixOf` map toLower m)) $
      monthAbr

-- ------------------------------------------------------------

ts :: String
ts = "Am Sonntag, dem 17. Februar '03 findet um 9 Uhr ein wichtiger Termin für das Sommersemester 2000 statt. "
    ++ "Dieser wird allerdings auf Montag verschoben. Und zwar auf den ersten Montag im Wintersemester 11/12, 12:30. "
    ++ "Ein wichtiger Termin findet im SoSe 2011 statt. Im Jahr '12 gibt es Termine, aber auch in WS 2010/11. "
    ++ "Ein weiterer Termin ist  am 2.4.11 um 12 Uhr. Oder war es doch Di. der 3.4.? Egal. "
    ++ "Ein weiterer wichtiger Termin findet am 2001-3-4 statt bzw. generell zwischen 01/3/4 - 01/6/4 um 13 Uhr. "
    ++ "Am kommenden Mittwoch findet Changemanagement in HS5 statt. Dies gilt dann auch für den 7. Juni "
    ++ "des Jahres 2011. Noch ein wichtiger Termin findet um 16:15 Uhr am Do., 1.2.03 statt. "
    ++ "Freitag, der 13. Juli ist kein Glückstag"
    ++ "und Freitag, der 13. Juli um 11:55 Uhr ist es zu spät."

rrr :: [String]
rrr = map _r . dateSearch' . tokenizeSubex tokenRE $ ts

ddd :: [DateVal]
ddd = map _d . dateSearch' . tokenizeSubex tokenRE $ ts

aaa :: [DateRep]
aaa =          dateSearch' . tokenizeSubex tokenRE $ ts

tt :: String -> [(String, String)]
tt = tokenizeSubex tokenRE

dd :: String -> [DateVal]
dd = map _d . dateSearch' . tt

rr :: String -> [String]
rr = map _r . dateSearch' . tt

pp :: String -> [String]
pp = map _p . dateSearch' . tt

-- ------------------------------------------------------------

testDate :: forall a . StringLike a => Test' a
testDate
  = Test' $
    TestLabel "date and time extraction from free text" $
    TestList $
    zipWith parseT toks exx
  where
    parseT res ok
      = TestCase $
        assertEqual (show res ++ " == " ++ show ok) res ok
        
    toks :: [(a, a)]
    toks = tokenizeSubex (fromString tokenRE) (fromString ts)

    exx :: [(a, a)]
    exx = map (fromString *** fromString) $
          [("word","Am"),("del"," "),("weekday","Sonntag"),("del",", "),("word","dem"),("del"," ")
          ,("ddMonthyyyy","17. Februar '03"),("del"," "),("word","findet"),("del"," "),("word","um")
          ,("del"," "),("HH","9 Uhr"),("del"," "),("word","ein"),("del"," "),("word","wichtiger")
          ,("del"," "),("word","Termin"),("del"," "),("word","f\252r"),("del"," "),("word","das")
          ,("del"," "),("ssem","Sommersemester 2000"),("del"," "),("word","statt"),("del",". ")
          ,("word","Dieser"),("del"," "),("word","wird"),("del"," "),("word","allerdings")
          ,("del"," "),("word","auf"),("del"," "),("weekday","Montag"),("del"," ")
          ,("word","verschoben"),("del",". "),("word","Und"),("del"," "),("word","zwar")
          ,("del"," "),("word","auf"),("del"," "),("word","den"),("del"," "),("word","ersten")
          ,("del"," "),("weekday","Montag"),("del"," "),("word","im"),("del"," ")
          ,("wsem","Wintersemester 11/12"),("del",", "),("HHMM","12:30"),("del",". ")
          ,("word","Ein"),("del"," "),("word","wichtiger"),("del"," "),("word","Termin")
          ,("del"," "),("word","findet"),("del"," "),("word","im"),("del"," "),("ssem","SoSe 2011")
          ,("del"," "),("word","statt"),("del",". "),("word","Im"),("del"," "),("word","Jahr")
          ,("del"," '"),("word","12"),("del"," "),("word","gibt"),("del"," "),("word","es")
          ,("del"," "),("word","Termine"),("del",", "),("word","aber"),("del"," "),("word","auch")
          ,("del"," "),("word","in"),("del"," "),("wsem","WS 2010/11"),("del",". "),("word","Ein")
          ,("del"," "),("word","weiterer"),("del"," "),("word","Termin"),("del"," "),("word","ist")
          ,("del","  "),("word","am"),("del"," "),("ddmmyyyy","2.4.11"),("del"," "),("word","um")
          ,("del"," "),("HH","12 Uhr"),("del",". "),("word","Oder"),("del"," "),("word","war")
          ,("del"," "),("word","es"),("del"," "),("word","doch"),("del"," "),("weekday","Di.")
          ,("del"," "),("word","der"),("del"," "),("ddmm","3.4."),("del","? "),("word","Egal")
          ,("del",". "),("word","Ein"),("del"," "),("word","weiterer"),("del"," ")
          ,("word","wichtiger"),("del"," "),("word","Termin"),("del"," "),("word","findet")
          ,("del"," "),("word","am"),("del"," "),("yyyymmdd","2001-3-4"),("del"," ")
          ,("word","statt"),("del"," "),("word","bzw"),("del",". "),("word","generell")
          ,("del"," "),("word","zwischen"),("del"," "),("yyyymmdd","01/3/4"),("del"," - ")
          ,("yyyymmdd","01/6/4"),("del"," "),("word","um"),("del"," "),("HH","13 Uhr")
          ,("del",". "),("word","Am"),("del"," "),("word","kommenden"),("del"," ")
          ,("weekday","Mittwoch"),("del"," "),("word","findet"),("del"," ")
          ,("word","Changemanagement"),("del"," "),("word","in"),("del"," "),("word","HS5")
          ,("del"," "),("word","statt"),("del",". "),("word","Dies"),("del"," "),("word","gilt")
          ,("del"," "),("word","dann"),("del"," "),("word","auch"),("del"," "),("word","f\252r")
          ,("del"," "),("word","den"),("del"," "),("ddMonth","7. Juni"),("del"," "),("word","des")
          ,("del"," "),("word","Jahres"),("del"," "),("yyyy","2011"),("del",". "),("word","Noch")
          ,("del"," "),("word","ein"),("del"," "),("word","wichtiger"),("del"," "),("word","Termin")
          ,("del"," "),("word","findet"),("del"," "),("word","um"),("del"," "),("HHMM","16:15 Uhr")
          ,("del"," "),("word","am"),("del"," "),("weekday","Do."),("del",", "),("ddmmyyyy","1.2.03")
          ,("del"," "),("word","statt"),("del",". "),("weekday","Freitag"),("del",", ")
          ,("word","der"),("del"," "),("ddMonth","13. Juli"),("del"," "),("word","ist"),("del"," ")
          ,("word","kein"),("del"," "),("word","Gl\252ckstagund"),("del"," "),("weekday","Freitag")
          ,("del",", "),("word","der"),("del"," "),("ddMonth","13. Juli"),("del"," "),("word","um")
          ,("del"," "),("HHMM","11:55 Uhr"),("del"," "),("word","ist"),("del"," "),("word","es")
          ,("del"," "),("word","zu"),("del"," "),("word","sp\228t"),("del",".")
          ]

    
-- ------------------------------------------------------------

genericTest :: (forall a . StringLike a => Test' a) -> Test
genericTest t
    = TestList $
      [ TestLabel "Test with 'String'"          $ unTest' (t :: Test' String)
      , TestLabel "Test with 'Text'"            $ unTest' (t :: Test' Text)
      , TestLabel "Test with 'Text.Lazy'"       $ unTest' (t :: Test' TextL)
      , TestLabel "Test with 'ByteString'"      $ unTest' (t :: Test' BS)
      , TestLabel "Test with 'ByteString.Lazy'" $ unTest' (t :: Test' BL)
      ]

allTests        :: Test
allTests
    = TestList
      [ genericTest testDate ]

main    :: IO ()
main
    = do
      c <- runTestTT allTests
      putStrLn $ show c
      let errs = errors c
          fails = failures c
      exitWith (codeGet errs fails)

codeGet :: Int -> Int -> ExitCode
codeGet errs fails
    | fails > 0       = ExitFailure 2
    | errs > 0        = ExitFailure 1
    | otherwise       = ExitSuccess

-- ------------------------------------------------------------