{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}

module Main where

import Data.Map (Map, (!?))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Maybe (isJust, mapMaybe)
import qualified Data.Aeson as Aeson
import Data.Vector (Vector)
import Data.Set (Set, fromList)
import qualified Data.Vector as V
import Control.Monad.Writer
import Control.Monad.Trans.Maybe

import Tiled2

data Level = Warning | Suggestion | Info | Forbidden | Error
  deriving Show

data Hint = Hint
  { hintLevel :: Level
  , hintMsg :: Text }
  deriving Show

-- shorter constructors
suggestion msg = Hint { hintLevel = Suggestion, hintMsg = msg }
warning msg = Hint { hintLevel = Warning, hintMsg = msg }
forbidden msg = Hint { hintLevel = Forbidden, hintMsg = msg }


-- | converts a Maybe to an Either, with a default value for Left
unwrap :: b -> Maybe a  -> Either b a
unwrap hint maybe = case maybe of
  Just a -> Right a
  Nothing -> Left hint

-- | unwrap and produce a warning if the value was Nothing
unwrapWarn :: Text -> Maybe a -> Either Hint a
unwrapWarn msg = unwrap $ warning msg

-- | get an attribute from a map
getAttr :: Map Text Aeson.Value -> Text -> Either Hint Aeson.Value
getAttr props name = unwrapWarn msg $ props !? name
  where msg = "field " <> name <> "does not exist"

-- | same as unwrapWarn, but for booleans
assertWarn :: Text -> Bool -> Either Hint ()
assertWarn msg cond = if cond then Right () else Left $ warning msg

-- | haskell's many string types are FUN …
showText :: Show a => a -> Text
showText = T.pack . show

-- | same as showText, but without the "String"-prefix for strings
-- TODO: serialise back into json for printing? People may get
-- confused by the type annotations if they only know json …
showAeson :: Aeson.Value -> Text
showAeson (Aeson.String s) = showText s
showAeson v = showText v

-- | the given property should have the given value. Otherwise, warning.
propEqual :: Map Text Aeson.Value -> Text -> Aeson.Value -> Either Hint ()
propEqual props name value = do
  value' <- getAttr props name
  assertWarn ("field "<>name<>" has unexpected value "<>showAeson value'
              <>", should be "<>showAeson value)
    $ value' == value

-- |
-- This type may require some explanation.
-- Essentially, it's a monad that can short-curcuit (i.e. abort),
-- and also collect hints as it goes. Currently, both aborts and
-- hints are the same type (Hint); if the monad ends up returning
-- Left Hint, then something went entirely wrong; if it returns
-- Right (a, [Hint]), then it ran through, calculated a, and collected
-- a list of linter hints along the way.
type MaybeWriter a = WriterT [Hint] (Either Hint) a


-- | type juggling to get a single warning into MaybeWriter a
maybeWriterHint :: (Text -> Hint) -> Text -> MaybeWriter ()
maybeWriterHint constructor = tell . (: []) . constructor

warn = maybeWriterHint warning
info = maybeWriterHint (\t -> Hint { hintLevel = Info, hintMsg = t })
forbid = maybeWriterHint forbidden
suggest = maybeWriterHint suggestion
complain = maybeWriterHint (\t -> Hint { hintLevel = Error, hintMsg = t })

-- | adds quotes (but does not escape, for now!)
quote :: Text -> Text
quote text = "\"" <> text <> "\""

-- | does this layer have the given property?
hasProperty :: Text -> Layer -> Bool
hasProperty name = any
  (\prop -> prop !? "name" == Just (Aeson.String name))
  . layerProperties



-- | The main thing
--
-- given a property, check if it is valid. It gets a reference
-- to its own layer since sometimes the presense of one property
-- implies the presence or absense of another.
--
-- The tests in here are meant to comply with the informal spec
-- at https://workadventu.re/map-building
checkProperty :: Layer -> Map Text Aeson.Value -> MaybeWriter ()
checkProperty layer prop = do
  tyObj <- lift $ getAttr prop "name"
  ty <- lift $ case tyObj of
    Aeson.String str -> Right str
    _ -> Left (suggestion "wtf")
  checkTyped ty
  where checkTyped ty = case ty of
          "jitsiRoom" -> do
            lift $ propEqual prop "type" "string"
            urlValue <- lift $ getAttr prop "value"
            info $ "found jitsi room: " <> showAeson urlValue
            suggestPropertyValue "jitsiTrigger" "onaction"
          "jitsiTrigger" -> requireProperty "jitsiRoom"
          "jitsiUrl" -> isForbidden
          "jitsiConfig" -> isForbidden
          "jitsiClientConfig" -> isForbidden
          "jitsiRoomAdminTag" -> isForbidden
          "playAudio" -> do
            -- TODO: check for url validity?
            lift $ propEqual prop "type" "string"
          "audioLoop" -> requireProperty "playAudio"
          "audioVolume" -> requireProperty "playAudio"
          "openWebsite" -> suggestPropertyValue "openWebsiteTrigger" "onaction"
          "openWebsiteTrigger" -> requireProperty "openWebsite"
          "openWebsitePolicy" -> requireProperty "openWebsite"
          "exitUrl" -> return ()
          "startLayer" -> return ()
           -- could also make this a "hard error" (i.e. Left), but then it
           -- stops checking other properties as checkLayer short-circuits.
          _ -> warn $ "unknown property type " <> quote ty
          where
            -- | require some property in this layer
            requireProperty name = unless (hasProperty name layer)
              $ complain $ "property "<>quote name<>" requires property "<>quote ty
            -- | forbid some property in this layer
            forbidProperty name = when (hasProperty name layer)
              $ forbid $ "property " <> quote name <> " should not be used"
            -- | This property is forbidden and should not be used
            isForbidden = forbid $ "property " <> quote ty <> " should not be used"
            -- TODO: check if the property has the correct value
            suggestPropertyValue name value = unless (hasProperty name layer)
              $ suggest $ "set property " <> quote name <> " to " <> quote value

checkLayer :: Layer -> MaybeWriter ()
checkLayer layer =
  mapM_ (checkProperty layer) (layerProperties layer)

-- TODO: possibly expand this to something more detailed?
showContext :: Text -> Text
showContext ctxt = " (in layer " <> ctxt <> ")\n"

-- | pretty-printer for a result of WriterMaybe (currently only for errors/hints)
showResult :: Show a => Text -> Either Hint (a, [Hint]) -> Maybe Text
showResult ctxt (Left hint) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
showResult _ (Right (a, [])) = Nothing
showResult ctxt (Right (a, hints)) = Just $ showHints hints
  where
    showHints hints = T.concat (mapMaybe showHint hints)
    -- TODO: make the "log level" configurable
    showHint Hint { hintMsg, hintLevel } = case hintLevel of
      Info -> Nothing
      _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
    ctxtHint = showContext ctxt



main :: IO ()
main = do
  Right map <- loadTiledmap "example.json"
  --print $ mapJitsiUrls map
  --print $ fmap layerJitsiUrls (tiledmapLayers map)
  -- TODO: print the layer each hint originates from
  let lines = V.mapMaybe (\layer ->
                            (showResult (T.pack $ layerName layer)
                              . runWriterT
                              . checkLayer)
                            layer)
              (tiledmapLayers map)
  mapM_ T.putStr lines