content: {-# 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
  
  -- ------------------------------------------------------------
  