df-actors/app/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Monad
import Data.Function
import Data.Map as M
import Data.Maybe
import Data.Text (Text)
import System.FilePath
import System.Directory
import Text.EscapeArtist

import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.List as L
import qualified Debug.Trace as D

type Language = Text
type Dictionary = Map Text Text

main :: IO ()
main = do
  dicts <- getLanguageData
  mainLoop dicts

mainLoop :: Map Language Dictionary -> IO ()
mainLoop d = do
  putStrLn "Name to look up (q to quit)?"
  T.getLine >>= \case
    "q" -> return ()
    name -> do
      forM_ (keys d) $ \language -> do
        putEscLn $ Default ("Results in language: "::Text) <> colorLang language language
        mapM_ (putEscLn . colorLang language) $ search (d!language) name
      mainLoop d

colorLang :: Text -> Text -> Escapable
colorLang "dwarf"  = FgGreen
colorLang "elf"    = FgRed
colorLang "goblin" = FgYellow
colorLang "human"  = FgBlue
colorLang _        = Default

search :: Dictionary -> Text -> [Text]
search _ ""   = [""]
search d name = let prefixes = L.filter (`T.isPrefixOf` name) $ keys d
                in if L.null prefixes then
                    [" - NO PERFECT MACTH ('"<>name<>"' left over from input)"]
                  else
                    [(d!p) <> s | p <- prefixes, s <- search d (T.drop (T.length p) name)]

getLanguageData :: IO (Map Language Dictionary)
getLanguageData = do
  files <- listDirectory "data"
  dicts <- forM files $ \fn ->
    case takeExtension fn of
      ".raw" -> do
        words <- fmap extractWord . L.filter ("T_WORD" `T.isInfixOf`) . T.lines <$> T.readFile ("data" </> fn)
        return $ Just (T.pack $ takeBaseName fn, fromList words)
      _      -> return   Nothing
  return $ fromList $ catMaybes dicts

extractWord :: Text -> (Text, Text)
extractWord = (\x -> (T.toLower $ x!!1,x!!2))
            . T.splitOn ":"
            . T.dropEnd 1
            . T.dropWhileEnd (/=']')
            . T.drop 1
            . T.dropWhile (/='[')