{-# OPTIONS_GHC -fno-warn-orphans #-}
{-| Module      :  HeliumMessages
    License     :  GPL

    Maintainer  :  helium@cs.uu.nl
    Stability   :  experimental
    Portability :  portable
    
    Defines how the (error) messages should be reported by the Helium compiler.
        (For instance, one could define another layout, or produce XML-like output).
-}

module Helium.StaticAnalysis.Messages.HeliumMessages where


import Helium.StaticAnalysis.Messages.Messages 
import Top.Types
import qualified Text.PrettyPrint.Leijen as PPrint
import qualified Helium.Utils.OneLiner as OneLiner
import Data.List
import Helium.StaticAnalysis.Miscellaneous.TypesToAlignedDocs  (qualifiedTypesToAlignedDocs)
import Helium.Syntax.UHA_Range           (isImportRange, showRanges)
import Data.Char                (isSpace)

----------------------------------------------------------
-- message parameters

lineLength :: Int
lineLength = 80

tableWidthLeft :: Int
tableWidthLeft = 16

tablePrefix :: String
tablePrefix = " "

tableSeparator :: String
tableSeparator = " : "

splitStringMargin :: Int
splitStringMargin = 15

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

tableWidthRight :: Int
tableWidthRight = lineLength - tableWidthLeft - length (tablePrefix ++ tableSeparator)

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

instance Show MessageLine where
   show messageLine = 
      case prepareTypesAndTypeSchemes messageLine of
         MessageOneLiner m   -> show m++"\n"
         MessageTable tab    -> showTable tab
         MessageHints pre ms -> showHints pre ms

instance Show MessageBlock where
   show (MessageString s     ) = s
   show (MessageRange r      ) = show r
   show (MessageType tp      ) = show tp
   show (MessagePredicate p  ) = show p
   show (MessageOneLineTree t) = OneLiner.showOneLine tableWidthRight t
   show (MessageCompose ms   ) = concatMap show ms

sortAndShowMessages :: HasMessage a => [a] -> String
sortAndShowMessages = concatMap showMessage . sortMessages  
   
showMessage :: HasMessage message => message -> String
showMessage x =
    let rangePart = 
           case filter (not . isImportRange) (getRanges x) of
              [] -> MessageString ""
              xs -> MessageString (showRanges xs ++ ": ")
        messageWithRange = 
           case getMessage x of
              MessageOneLiner m:rest -> MessageOneLiner (MessageCompose [rangePart, m]) : rest
              xs                     -> MessageOneLiner rangePart : xs
    in concatMap show messageWithRange

showHints :: String -> MessageBlocks -> String
showHints pre ms =
   let firstPrefix = "  " ++ pre ++ ": "
       restPrefix  = replicate (4 + length pre) ' '
       prefixes    = firstPrefix : repeat restPrefix
       width       = lineLength - length firstPrefix
       combine     = intercalate ('\n' : restPrefix)
   in unlines . zipWith (++) prefixes . map (combine . splitString width . show) $ ms

showTable :: [(Bool, MessageBlock, MessageBlock)] -> String
showTable = 
   let showTuple (indentBlock, leftBlock, rightBlock) =
          let -- some helper functions
              leftWidth = tableWidthLeft - (if indentBlock then 2 else 0)
              concatFour a b c d = a ++ b ++ c ++ d
              makeOfLength i s   = take i (s ++ repeat ' ')
              linesOfLength i    = repeat (replicate i ' ')
              -- lines
              leftLines  = splitString leftWidth       (show leftBlock)
              rightLines = splitString tableWidthRight (show rightBlock)
              nrOfLines  = length leftLines `max` length rightLines
              -- the four columns
              indentColumn    = if indentBlock
                                  then               linesOfLength (length tablePrefix + 2)
                                  else tablePrefix : linesOfLength (length tablePrefix)
              leftColumn      = map (makeOfLength leftWidth) leftLines ++ linesOfLength leftWidth 
              seperatorColumn = tableSeparator : linesOfLength (length tableSeparator)
              rightColumn     = rightLines ++ linesOfLength tableWidthRight
          in unlines (take nrOfLines (zipWith4 concatFour indentColumn leftColumn seperatorColumn rightColumn))
   in concatMap showTuple . renderTypesInRight
  
-- if two types or type schemes follow each other in a table (on the right-hand side)
-- then the two types are rendered in a special way.
renderTypesInRight :: [(Bool, MessageBlock, MessageBlock)] -> [(Bool, MessageBlock, MessageBlock)]
renderTypesInRight table =
   case table of
      hd@(q1, l1, r1) : tl@((q2, l2, r2) : rest)
        -> case (maybeQType r1, maybeQType r2) of
              (Just tp1, Just tp2) -> 
                 let [doc1, doc2] = qualifiedTypesToAlignedDocs [tp1, tp2]
                     render = flip PPrint.displayS [] . PPrint.renderPretty 1.0 tableWidthRight
                 in (q1, l1, MessageType (toTpScheme (TCon (render doc1))))
                  : (q2, l2, MessageType (toTpScheme (TCon (render doc2))))
                  : renderTypesInRight rest
              _ -> hd : renderTypesInRight tl
      _ -> table

  where maybeQType :: MessageBlock -> Maybe QType
        maybeQType (MessageType qtype) = Just (unquantify qtype) -- unsafe?
        maybeQType _                   = Nothing

-- make sure that a string does not exceed a certain width.
-- Two extra features:
--   - treat '\n' in the proper way.
--     (Be careful here: an enter in a string or a character does not
--      make a new line)
--   - try not to break words.
splitString :: Int -> String -> [String]
splitString width = concatMap f . lines
   where f string | length string <= width
                    = [string]
                  | otherwise
                    = let lastSpace     = last . (width:) . map fst . filter predicate
                                               . zip [0..] . take width $ string
                          predicate (pos, char) = isSpace char && pos >= width - splitStringMargin
                          (begin, rest) = splitAt lastSpace string
                      in begin : f (dropWhile isSpace rest)
                    
-- Prepare the types and type schemes in a messageline to be shown.
--
-- type schemes:
--   * responsible for their own type variables
--   * monomorphic type variables are frozen, that is, replaced by _1, _2, etc.
-- types: 
--   * use a, b, c for type variables
--   * use the type variables consistent over all types 
--       (for instance, all v5 are mapped to a 'c')
prepareTypesAndTypeSchemes :: MessageLine -> MessageLine
prepareTypesAndTypeSchemes messageLine = newMessageLine
   where 
    (result, _, names) = replaceTypeSchemes messageLine
    newMessageLine     = giveTypeVariableIdentifiers result
   
     --step 1
    replaceTypeSchemes :: MessageLine -> (MessageLine, Int, [String])
    replaceTypeSchemes messageLine' = 
       let unique = nextFTV messageLine'
       in case messageLine' of
             MessageOneLiner mb -> let (r, i, ns) = f_MessageBlock unique mb
                                   in (MessageOneLiner r, i, ns)
             MessageTable tab   -> let (r, i, ns) = f_Table unique tab
                                   in (MessageTable r, i, ns)
             MessageHints s mbs -> let (r, i, ns) = f_MessageBlocks unique mbs
                                   in (MessageHints s r, i, ns)

    --step 2
    giveTypeVariableIdentifiers :: MessageLine -> MessageLine
    giveTypeVariableIdentifiers ml = 
       let sub = listToSubstitution (zip (ftv ml) [ TCon s | s <- variableList, s `notElem` names])
       in sub |-> ml
   
    f_Table :: Int -> [(Bool, MessageBlock, MessageBlock)] -> ([(Bool, MessageBlock, MessageBlock)], Int, [String])
    f_Table i [] = ([], i, [])
    f_Table i ((q, a, b):xs) = let (r1, i1, ns1) = f_MessageBlock i  a
                                   (r2, i2, ns2) = f_MessageBlock i1 b
                                   (r3, i3, ns3) = f_Table        i2 xs
                               in ((q, r1, r2):r3, i3, ns1++ns2++ns3)    
    
    f_MessageBlocks :: Int -> [MessageBlock] -> ([MessageBlock], Int, [String])
    f_MessageBlocks i []     = ([], i, [])
    f_MessageBlocks i (x:xs) = let (r1, i1, ns1) = f_MessageBlock  i  x
                                   (r2, i2, ns2) = f_MessageBlocks i1 xs
                               in (r1:r2, i2, ns1++ns2)

    f_MessageBlock :: Int -> MessageBlock -> (MessageBlock, Int, [String])
    f_MessageBlock unique messageBlock = 
        case messageBlock of
           MessageCompose mbs -> let (r, i, ns) = f_MessageBlocks unique mbs
                                 in (MessageCompose r, i, ns)
           MessageType ts     -> let (unique', ps, its) = instantiateWithNameMap unique ts
                                 in (MessageType (toTpScheme (ps .=>. its)), unique', constantsInType its)                                   
           _                  -> (messageBlock, unique, [])