{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}

module Pkl
    ( printPklData
    , toPklData
    , printLayoutData
    , toLayoutData
    ) where

import BasePrelude hiding (toList)
import Prelude.Unicode hiding ((∈), (∉))
import Data.Monoid.Unicode ((⊕))
import Data.Foldable.Unicode ((∈), (∉))
import Util (toString, show', ifNonEmpty, (>$>), nubOn, filterOnSnd, filterOnSndM, sequenceTuple, tellMaybeT, versionStr, privateChars)
import qualified WithPlus as WP (fromList, singleton)

import Control.Monad.State (evalState)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Writer (runWriter, tell)
import Data.Foldable (toList)
import Lens.Micro.Platform (view, over)

import Layout.Key (letterToDeadKey, setDeadNullChar, filterKeyOnShiftstatesM, toIndexedCustomDeadKey, addPresetDeadToDead)
import Layout.Layout (addDefaultKeysWith, getDefaultKeys, unifyShiftstates, getLetterByPosAndShiftstate)
import qualified Layout.Modifier as M
import Layout.ModifierEffect (defaultModifierEffect)
import qualified Layout.Pos as P
import Layout.Types
import Lookup.Windows
import PresetLayout (defaultKeys, defaultFullLayout)

data IsExtend = Extend | NotExtend

prepareLayout ∷ Layout → Layout
prepareLayout =
    over (_keys ∘ traverse ∘ _shiftlevels ∘ traverse ∘ traverse) altGrToControlAlt >>>
    addDefaultKeysWith getDefaultKeys' defaultKeys >>>
    over _singletonKeys (filter (not ∘ isAltRToAltGr)) >>>
    over _keys
        (flip evalState 1 ∘ (traverse ∘ _letters ∘ traverse) toIndexedCustomDeadKey >>>
        flip evalState privateChars ∘ (traverse ∘ _letters ∘ traverse) setDeadNullChar) >>>
    over (_keys ∘ traverse ∘ _letters ∘ traverse) addPresetDeadToDead
  where
    getDefaultKeys' keys = getDefaultKeys keys ∘ filterNonExtend
    filterNonExtend = over _keys (filter (any (any supportedNonExtend) ∘ view _shiftlevels))
    supportedNonExtend = fst ∘ runWriter ∘ supportedShiftstate NotExtend

supportedShiftstate ∷ Logger m ⇒ IsExtend → Shiftstate → m Bool
supportedShiftstate NotExtend shiftstate = and <$> traverse supportedModifier (toList shiftstate)
supportedShiftstate Extend shiftstate
  | M.Extend ∉ shiftstate = pure False
  | shiftstate ≡ WP.singleton M.Extend = pure True
  | otherwise = False <$ tell ["extend mappings with other modifiers is not supported in PKL"]

supportedModifier ∷ Logger m ⇒ Modifier → m Bool
supportedModifier M.Extend = pure False
supportedModifier modifier
  | modifier ∈ map fst modifierAndWinShiftstate = pure True
  | otherwise = False <$ tell [show' modifier ⊕ " is not supported in PKL"]


-- PKL DATA

data PklKey
    = PklKey
        { __pklPos ∷ String
        , __pklShortcutPos ∷ String
        , __pklCapslock ∷ Bool
        , __pklLetters ∷ [String]
        , __pklComment ∷ String
        }
    | PklSpecialKey
        { __pklPos ∷ String
        , __pklSpecialString ∷ String
        , __pklComment ∷ String
        }
    deriving (Show, Read)

printPklKey ∷ PklKey → String
printPklKey (PklKey pos shortcutPos caps letters comment) = intercalate "\t" $
    [ pos ⊕ " = " ⊕ shortcutPos
    , show (fromEnum caps)
    ] ⧺ dropWhileEnd (≡ "--") letters ⧺
    [ "; " ⊕ comment | not (null comment) ]
printPklKey (PklSpecialKey pos string comment) = intercalate "\t" $
    [ pos ⊕ " = " ⊕ string ] ⧺
    [ "; " ⊕ comment | not (null comment) ]

pklKeyToSingleString ∷ PklKey → Maybe String
pklKeyToSingleString PklKey{} = Nothing
pklKeyToSingleString (PklSpecialKey _ s _) = Just s

data PklDeadKey = PklDeadKey
    { __pklName ∷ String
    , __pklInt ∷ Int
    , __pklCharMap ∷ [(Char, Either Char String)]
    } deriving (Show, Read)
printPklDeadKey ∷ PklDeadKey → [String]
printPklDeadKey (PklDeadKey name int charMap) =
    "" :
    ("[deadkey" ⊕ show int ⊕ "]\t; " ⊕ name) :
    map (uncurry showPair) charMap
  where
    showPair inC outS = intercalate "\t"
        [ show (ord inC)
        , "="
        , either (show ∘ ord) id outS
        , "; " ⊕ [inC] ⊕ " → " ⊕ either (:[]) id outS
        ]

printPklKeys ∷ [PklKey] → [String]
printPklKeys = map printPklKey ∘ filter ((≢) (Just "--") ∘ pklKeyToSingleString)

printPklDeadKeys ∷ [PklDeadKey] → [String]
printPklDeadKeys [] = []
printPklDeadKeys xs = ("":) (concatMap printPklDeadKey xs)

data LayoutData = LayoutData
    { __pklInformation ∷ Information
    , __pklHomepage ∷ String
    , __pklExtendPos ∷ Maybe String
    , __pklShiftstates ∷ [WinShiftstate]
    , __pklKeys ∷ [PklKey]
    , __pklDeadKeys ∷ [PklDeadKey]
    } deriving (Show, Read)
data PklData = PklData
    { __pklDataName ∷ String
    , __pklExtendKeys ∷ [PklKey]
    } deriving (Show, Read)

printLayoutData ∷ String → LayoutData → String
printLayoutData date (LayoutData info homepage maybeExtendPos shiftstates keys deadKeys) = unlines $
    [ "; Generated by KLFC " ⊕ versionStr
    , "; https://github.com/39aldo39/klfc"
    , ""
    , "[informations]"
    , "layoutname   = " ⊕ view _fullName info
    , "layoutcode   = " ⊕ view _name info ] ⧺
    [ "localeid     = " ⊕ localeId  | localeId  ← maybeToList $ view _localeId  info ] ⧺
    [ "" ] ⧺
    [ "copyright    = " ⊕ copyright | copyright ← maybeToList $ view _copyright info ] ⧺
    [ "company      = " ⊕ company   | company   ← maybeToList $ view _company   info ] ⧺
    [ "homepage     = " ⊕ homepage ] ⧺
    [ "version      = " ⊕ version   | version   ← maybeToList $ view _version   info ] ⧺
    [ ""
    , "generated_at = " ⊕ date
    , ""
    , ""
    , "[global]" ] ⧺
    [ "extend_key = " ⊕ pos | pos ← maybeToList maybeExtendPos ] ⧺
    [ "shiftstates = " ⊕ intercalate ":" (map show shiftstates)
    , ""
    , ""
    , "[layout]"
    ] ⧺ printPklKeys keys
    ⧺ printPklDeadKeys deadKeys

type IsCompact = Bool
printPklData ∷ IsCompact → PklData → String
printPklData isCompact (PklData name extendKeys) = unlines $
    [ "; Generated by KLFC " ⊕ versionStr
    , "; https://github.com/39aldo39/klfc"
    , ""
    , "[pkl]"
    , "layout             = " ⊕ name
    , "language           = auto"
    , "displayHelpImage   = no"
    , "compactMode        = " ⊕ bool "no" "yes" isCompact
    , "altGrEqualsAltCtrl = no"
    , "suspendTimeOut     = 0"
    , "exitTimeOut        = 0"
    ] ⧺ printExtendKeys' (printPklKeys extendKeys)
  where
    printExtendKeys' [] = []
    printExtendKeys' xs = "":"[extend]":xs


-- TO PKL DATA

toLayoutData ∷ Logger m ⇒ Layout → m LayoutData
toLayoutData =
    prepareLayout >>>
    _keys (fmap catMaybes ∘ traverse toSupportedShiftstates) >=>
    toLayoutData'
  where
    toSupportedShiftstates key
      | not (null (view _letters key))
      ∧ all (any (M.Extend ∈)) (view _shiftlevels key)
      = pure Nothing
      | otherwise
      = Just <$> filterKeyOnShiftstatesM (supportedShiftstate NotExtend) key

toLayoutData' ∷ Logger m ⇒ Layout → m LayoutData
toLayoutData' layout =
    LayoutData
      <$> pure (view _info layout)
      <*> pure "http://pkl.sourceforge.net/"
      <*> runMaybeT (MaybeT (pure extendPos) >>= extendPosToPklPos)
      <*> pure (map winShiftstateFromShiftstate states)
      <*> liftA2 (⧺) pklKeys pklModifierKeys
      <*> (nubOn __pklInt <$> traverse (uncurry deadToPkl) (concatMap (mapMaybe fromPklDead ∘ view _letters) keys))
  where
    (keys, states) = unifyShiftstates (view _keys layout)
    pklKeys = catMaybes <$> traverse (keyToPklKey layout) keys
    pklModifierKeys = catMaybes <$> traverse (singletonKeyToPklKey layout) (view _singletonKeys layout)
    extendPos = listToMaybe $ filterOnSnd (≡ Modifiers Shift [M.Extend]) (map (view _sPos &&& view _sLetter) (view _singletonKeys layout))
    extendPosToPklPos P.CapsLock = pure "CapsLock"
    extendPosToPklPos pos = maybe (e pos) pure (lookup pos posAndVkString) <|> toPklPos pos
    fromPklDead (CustomDead (Just i) d) = Just (i, d)
    fromPklDead _ = Nothing
    e ∷ Logger m ⇒ Pos → MaybeT m α
    e pos = tellMaybeT [show' pos ⊕ " is not supported in PKL"]

deadToPkl ∷ Logger m ⇒ Int → DeadKey → m PklDeadKey
deadToPkl i (DeadKey name _ actionMap) = PklDeadKey name i <$> charMap
  where
    charMap = catMaybes <$> traverse (runMaybeT ∘ sequenceTuple ∘ (letterToChar *** outS)) actionMap
    outS ∷ Logger m ⇒ ActionResult → MaybeT m (Either Char String)
    outS (Next _) = tellMaybeT ["chained dead key in dk" ⊕ show i ⊕ " (" ⊕ name ⊕ ") is not supported in PKL"]
    outS (OutString [x]) = pure (Left x)
    outS (OutString "") = pure (Right "0")
    outS (OutString xs)
      | all isDigit xs = tellMaybeT ["the output ‘" ⊕ xs ⊕ "’ is unsupported in dk" ⊕ show i ⊕ " (" ⊕ name ⊕ ") in PKL (all chars are digits)"]
      | otherwise = pure (Right xs)

letterToChar ∷ Logger m ⇒ Letter → MaybeT m Char
letterToChar (Char c) = pure c
letterToChar l = tellMaybeT [show' l ⊕ " as letter for a dead key is not supported in PKL"]

toPklData ∷ Logger m ⇒ Layout → Layout → m PklData
toPklData shortcutLayout =
    prepareLayout >>>
    view _keys >>>
    traverse (extendKeyToPklKey shortcutLayout) >$>
    catMaybes >>>
    PklData (view (_info ∘ _name) shortcutLayout)

keyToPklKey ∷ Logger m ⇒ Layout → Key → m (Maybe PklKey)
keyToPklKey layout key = runMaybeT $
    PklKey
      <$> toPklPos (view _pos key)
      <*> printShortcutPos (view _shortcutPos key)
      <*> pure (view _capslock key)
      <*> lift (traverse (printLetter NotExtend layout) (view _letters key))
      <*> pure (keyComment (view _pos key) (view _letters key))

extendKeyToPklKey ∷ Logger m ⇒ Layout → Key → m (Maybe PklKey)
extendKeyToPklKey layout key = runMaybeT $ do
    letter ← MaybeT $ listToMaybe <$> filterOnSndM supportedLevel lettersWithLevels
    PklSpecialKey
      <$> toPklPos (view _pos key)
      <*> printLetter Extend layout letter
      <*> pure ""
  where
    supportedLevel = fmap or ∘ traverse (supportedShiftstate Extend)
    lettersWithLevels = view _letters key `zip` view _shiftlevels key

singletonKeyToPklKey ∷ Logger m ⇒ Layout → SingletonKey → m (Maybe PklKey)
singletonKeyToPklKey layout (SingletonKey pos action) = runMaybeT $
    PklSpecialKey
      <$> toPklPos pos
      <*> lift (printModifierPosition layout action)
      <*> pure (keyComment pos [action])

toPklPos ∷ Logger m ⇒ Pos → MaybeT m String
toPklPos P.Alt_R = pure "RAlt"
toPklPos P.Menu = pure "AppsKey"
toPklPos pos = maybe e pure $ printf "SC%03x" <$> lookup pos posAndScancode
  where e = tellMaybeT [show' pos ⊕ " is not supported in PKL"]

keyComment ∷ Pos → [Letter] → String
keyComment pos letters =
    "QWERTY " ⊕ toString pos ⊕ ifNonEmpty (": " ⊕) (intercalate ", " letterComments)
  where
    letterComments = mapMaybe letterComment letters

letterComment ∷ Letter → Maybe String
letterComment = fmap __dkName ∘ letterToDeadKey

printShortcutPos ∷ Logger m ⇒ Pos → MaybeT m String
printShortcutPos pos = maybe e pure (lookup pos posAndVkString)
  where e = tellMaybeT [show' pos ⊕ " is not supported in PKL"]

printLetter ∷ Logger m ⇒ IsExtend → Layout → Letter → m String
printLetter isExtend _ (Char ' ') = pure (addBraces isExtend "space")
printLetter _ _ (Char c) = pure [c]
printLetter _ _ (Ligature _ x) = pure x
printLetter isExtend layout (Action a) =
    addBraces isExtend <$> actionToPkl layout a
printLetter _ _ (Modifiers Shift [M.Extend]) = pure "--"
printLetter _ _ (Modifiers effect [modifier])
  | effect ≡ defaultModifierEffect modifier
  = case lookup modifier modifierAndPklAction of
      Just (Simple xs) → pure xs
      _ → "--" <$ tell [show' modifier ⊕ " is not supported in PKL"]
  | otherwise = "--" <$ tell [show' modifier ⊕ " with " ⊕ show' effect ⊕ " is not supported in PKL"]
printLetter _ _ (Modifiers _ _) =
     "--" <$ tell ["Multiple modifiers on one letter is not supported in PKL"]
printLetter _ _ (CustomDead (Just i) _) = pure ("dk" ⊕ show i)
printLetter _ _ l@(CustomDead Nothing _) = "--" <$ tell [show' l ⊕ " does not have an dead key number"]
printLetter isExtend layout l@(Redirect mods pos) =
    case getLetterByPosAndShiftstate pos (WP.fromList mods) defaultFullLayout of
      Just l' → addBraces isExtend <$> printPklAction layout l (RedirectLetter l' mods)
      Nothing → "--" <$ tell ["redirecting to " ⊕ show' pos ⊕ " is not supported"]
printLetter _ _ LNothing = pure "--"
printLetter _ _ letter = "--" <$ tell [show' letter ⊕ " is not supported in pkl"]

printPklAction ∷ Logger m ⇒ Layout → Letter → PklAction → m String
printPklAction _ _ (Simple x) = pure x
printPklAction layout _ (RedirectLetter letter ms) =
    (("}" ⊕ concat (mapMaybe (`lookup` modifierAndString) ms) ⊕ "{") ⊕) <$> printLetter Extend layout letter

actionToPkl ∷ Logger m ⇒ Layout → Action → m String
actionToPkl layout a =
  case lookup a actionAndPklAction of
    Just pklAction → printPklAction layout (Action a) pklAction
    Nothing → "--" <$ tell [show' a ⊕ " is not supported in PKL"]

addBraces ∷ IsExtend → String → String
addBraces _ "--" = "--"
addBraces Extend x = x
addBraces NotExtend x = "={" ⊕ x ⊕ "}"

printModifierPosition ∷ Logger m ⇒ Layout → Letter → m String
printModifierPosition layout letter
  | Modifiers _ _ ← letter
  = s <&> \case
      "--" → "disabled"
      s' → s' ⊕ "\tmodifier"
  | otherwise = s
  where
    s = printLetter NotExtend layout letter
