{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
module Main where
import OpenAFP
import qualified Data.ByteString.Lazy as L

type Map = [([N1], [N1])]
type Maps = IORef [Map]

main :: IO ()
main = do
    opts    <- getOpts
    fms     <- readMaps opts
    cs      <- readInputAFP opts
    fh      <- openOutputAFP opts
    mapref  <- newIORef []
    scflref <- newIORef []
    sidref  <- newIORef 1
    runReaderT (stateMain fh cs) opts
        { currentMap = mapref
        , scflStack = scflref
        , scflID = sidref } { maps = fms }
    hClose fh

stateMain :: (Binary c, MonadReader Opts m, MonadIO m, Chunk c)
    => Handle -> [c] -> m ()
stateMain fh chunks = forM_ (splitRecords _PGD chunks) $ \cs -> do
    cs' <- pageHandler cs
    io $ L.hPutStr fh (encodeList cs')

pageHandler :: (Chunk t, MonadReader Opts m, MonadIO m)
    => [t] -> m [t]
pageHandler page = do
    ptxList <- sequence [ ptx_Chunks `applyToChunk` c | c <- page, c ~~ _PTX ]
    trnList <- sequence [ ptx_trn `applyToChunk` c | c <- concat ptxList, c ~~ _PTX_TRN ]
    let strList = map fromNStr trnList
    -- check each strList against each map element
    -- if one matches the length, return the munged page, and nix the map from mapList
    fms     <- readVar maps
    case find (matchMap strList) fms of
        Nothing -> return page
        Just fm -> do
            verbose $$ "Matched..."
            currentMap $= mungeMap $ fm
            maps $= delete fm $ fms
            mungePage page

mungeMap :: Map -> Map
mungeMap = concatMap mungePair

mungePair :: ([N1], [N1]) -> Map
mungePair (key, val) = splitChunks key `zip` (val:repeat [])

_pretty :: [[N1]] -> [String]
_pretty = map $ map (chr . fromEnum)

matchMap :: [[N1]] -> Map -> Bool
matchMap strList fm
    -- | trace (unlines $ _pretty matched) True
    -- | trace (show (length matched, length keys)) True
    = (length matched >= length keys)
    where
    matched = filter matchOne strList
    keys = concatMap splitChunks keysList
    keysList = map fst fm
    matchOne str
        | str `elem` keys
        = True
        | length str < 2
        = False
        | last str == 0x40
        , last (init str) == 0xA1
        = matchOne (init (init str))
        | otherwise
--        , trace (map (chr . fromEnum) str) True
        = False

splitChunks :: [N1] -> [[N1]]
splitChunks = foldr joinChunks [] . strChunks

joinChunks :: [N1] -> [[N1]] -> [[N1]]
joinChunks xs [] = [xs]
joinChunks [x] ((y:ys):rest)        | y <= 0x80 = (x:y:ys):rest
joinChunks [x1,x2] ((y:ys):rest)    | y >= 0x80 = (x1:x2:y:ys):rest
joinChunks xs rest = xs:rest

strChunks :: [N1] -> [[N1]]
strChunks [] = []
strChunks (hi:lo:xs) | hi >= 0x80 = ([hi, lo] : strChunks xs)
strChunks (x:xs) = [x] : strChunks xs

mungePage :: (Chunk c, MonadReader Opts t, MonadIO t)
    => [c] -> t [c]
mungePage page = do
    page ==>
        [ _MCF ... mcfHandler
        , _PTX === (`filterChunks`
            [ _PTX_TRN === trnHandler
            , _PTX_SCFL === scflHandler
            ])
        ]

-- | Record font Id to Name mappings in MCF's RLI and FQN chunks.
mcfHandler :: (RecChunk r, MonadIO m, MonadReader Opts m)
    => r -> m ()
mcfHandler r = do
    readChunks r ..>
        [ _MCF_T ... \mcf -> do
            fnt <- asks font
            let cs = readChunks mcf
            ids   <- sequence [ t_rli `applyToChunk` c | c <- cs, c ~~ _T_RLI ]
            fonts <- sequence [ t_fqn `applyToChunk` c | c <- cs, c ~~ _T_FQN ]
            let alist = map fromAStr fonts `zip` ids
            case lookup fnt alist of
                Just sid -> do
                    verbose $$ ("Found font ID for " ++ fnt ++ ": " ++ (show sid))
                    scflID $= id $ sid
                    return ()
                Nothing -> return ()
        ]

scflHandler :: (MonadReader Opts m, MonadIO m)
    => PTX_SCFL -> m ()
scflHandler r = do
    scfls <- readVar scflStack
    scflStack $= id $ (r:scfls)

trnHandler :: (Chunk c, MonadIO m, MonadReader Opts m)
    => PTX_TRN -> WriterT (ChunkQueue c) m ()
trnHandler r = do
    let trnOld = fromNStr $ ptx_trn r
    fm      <- readVar currentMap
    scfls   <- readVar scflStack
    sid     <- readVar scflID
    case fm of
        ((trn, rv):rest) | trn == trnOld -> do
            -- verbose $$ map (chr . fromEnum) trn
            currentMap $= id $ rest
            case scfls of
                []      -> do
                    let rst = (ptx_trn_Type r `mod` 2)
                        typ = (ptx_scfl_Type _PTX_SCFL)
                    push _PTX_SCFL{ ptx_scfl = sid, ptx_scfl_Type = typ + rst }
                    push _PTX_SCFL{ ptx_scfl = sid, ptx_scfl_Type = typ + (1-rst) }
                (s:ss)  -> mapM_ push $ reverse (s{ ptx_scfl = 1 }:ss)
            unless (null rv) $ do
                let trn' = toNStr rv
                verbose $$ ("From:[" ++ map (chr . fromEnum) trnOld ++ "]")
                verbose $$ ("To:  [" ++ map (chr . fromEnum) rv ++ "]")
                push r { ptx_trn = trn' }
                return ()
        _ -> do
            mapM_ push $ reverse scfls
            push r
    scflStack $= id $ []

usage :: String -> IO a
usage = showUsage options showInfo
    where
    showInfo prg = 
        "Usage: " ++ prg ++ " -m map.txt -i input.afp -o output.afp\n"

data Opts = Opts
    { readMaps          :: IO Maps
    , maps              :: Maps
    , currentMap                :: IORef Map
    , readInputAFP      :: IO [AFP_]
    , openOutputAFP     :: IO Handle
    , font              :: String
    , verbose           :: Bool
    , showHelp          :: IO ()
    , scflStack         :: IORef [PTX_SCFL]
    , scflID            :: IORef N1
    } deriving (Typeable)

defaultOpts :: Opts
defaultOpts = Opts
    { readMaps          = requiredOpt usage "map"
        , currentMap            = undefined
    , maps              = requiredOpt usage "map"
    , readInputAFP      = requiredOpt usage "input"
    , openOutputAFP     = requiredOpt usage "output"
    , font              = requiredOpt usage "font"
    , verbose           = True
    , showHelp          = return ()
    , scflStack         = undefined
    , scflID            = undefined
    }

options :: [OptDescr (Opts -> Opts)]
options =
    [ reqArg "m" ["map"]            "FILE"          "Replacement map"
        (\s o -> o { readMaps       = newIORef . makeMaps =<< readFile s })
    , reqArg "i" ["input"]          "FILE"          "Input AFP file"
        (\s o -> o { readInputAFP   = readAFP s })
    , reqArg "o" ["output"]         "FILE"          "Output AFP file"
        (\s o -> o { openOutputAFP  = openBinaryFile s WriteMode })
    , reqArg "f" ["font"]           "NAME"          "Font name"
        (\s o -> o { font = s })
    , noArg  "v" ["verbose"]                        "Print progress information"
        (\o   -> o { verbose        = True })
    , noArg  "h" ["help"]                           "Show help"
        (\o   -> o { showHelp       = usage "" })
    ]

run :: IO ()
-- run = withArgs (split " " "-v -m SC27.add -i SC27.AFP -o output.afp") main
run = runWith "-v -m 1-map.txt -i 1-in.afp -o 1-out.afp -f X0FDB000"

runWith :: String -> IO ()
runWith str = withArgs (words str) main

makeMaps :: String -> [Map]
makeMaps str = entries
    where
    entries :: [Map]
    entries = map (pair . lines) groups
    pair [] = []
    pair (a:b:[]) = [(ordList a, checkDBCS $ ordList b)]
    pair (a:b:[]:rest) = (ordList a, checkDBCS $ ordList b) : pair rest
    pair x = error $ "Bad pair: " ++ (show x)
    groups = split "\n\n--\n--\n\n" str
    ordList :: (Enum a, Enum b) => [a] -> [b]
    ordList = map (toEnum . fromEnum)
    checkDBCS [] = []
    checkDBCS (x:y:xs) | x > 0x7F = (x:y:checkDBCS xs)
    checkDBCS x = error $ "Not DBCS: " ++ ordList x

getOpts :: IO Opts
getOpts = do
    args <- getArgs
    (optsIO, _rest, _errs) <- return . getOpt Permute options $ procArgs args
    return $ foldl (flip ($)) defaultOpts optsIO
    where
    procArgs []     = ["-h"]
    procArgs xs     = xs

-- | Split a list into pieces that were held together by glue.  Example:
--
-- > split ", " "one, two, three" ===> ["one","two","three"]

split :: Eq a => [a] -- ^ Glue that holds pieces together
      -> [a]         -- ^ List to break into pieces
      -> [[a]]       -- ^ Result: list of pieces

split glue xs = split' xs
    where
    split' []  = []
    split' xs' = piece : split' (dropGlue rest)
        where (piece, rest) = breakOnGlue glue xs'
    dropGlue   = drop (length glue)

-- | Break off the first piece of a list held together by glue,
--   leaving the glue attached to the remainder of the list.  Example:
--
-- > breakOnGlue ", " "one, two, three" ===> ("one", ", two, three")

breakOnGlue :: (Eq a) => [a] -- ^ Glue that holds pieces together
            -> [a]           -- ^ List from which to break off a piece
            -> ([a],[a])     -- ^ Result: (first piece, glue ++ rest of list)

breakOnGlue _ [] = ([],[])
breakOnGlue glue rest@(x:xs)
    | glue `isPrefixOf` rest = ([], rest)
    | otherwise = (x:piece, rest') where (piece, rest') = breakOnGlue glue xs