{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
{-#LANGUAGE OverloadedLabels #-}
{-#LANGUAGE StandaloneDeriving#-}
{-#LANGUAGE QuasiQuotes #-}
{-#LANGUAGE TemplateHaskell, DataKinds #-}
module Network.SC2.Internal.ConstantGenerator where
import Prelude hiding ((.))
import Control.Category((.))
import Data.Aeson
import System.FilePath
import System.Directory (getHomeDirectory, doesFileExist)
import Network.SC2.Internal.Directories
import Language.Haskell.TH.Syntax
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import qualified Data.Text as T (pack, unpack, Text, append, words, toTitle,toUpper, concat, isSuffixOf)
import Network.SC2.Internal.Types
import Data.Char (toUpper)
import Lens.Labels hiding ((^.), (.~))
import Lens.Labels.Unwrapped
import Data.Maybe
import Control.Lens
readStableIDjson :: IO (FilePath, IDs)
readStableIDjson = do
home <- getHomeDirectory
let path' = home </> userSC2SubDirectory </> "stableid.json"
exists <- doesFileExist path'
let path = if exists then path' else "backupStableID.json"
contents' <- decodeFileStrict' path :: IO (Maybe IDs)
let contents = fromMaybe (error "Error parsing stableid.json") contents'
return (home, contents)
stableIDjsonContents :: Q IDs
stableIDjsonContents = do
(path, contents) <- runIO readStableIDjson
return contents
scAbilitiesDeclarations :: Q [Dec]
scAbilitiesDeclarations = do
contents <- stableIDjsonContents
let (ha:ra) = filter (\a -> not (Data.Maybe.isJust (remapID a) || abilityButtonName a == "") ) $ abilities contents
let abilities' = (ha & #canonicalName .~ "NullAbility" ) : ra
scEntityEnumGen "ability" abilities'
scBuffsDeclarations :: Q [Dec]
scBuffsDeclarations = do
contents <- stableIDjsonContents
let (hb:rb) = buffs contents
let buffs' = (hb & #canonicalName .~ "NullBuff" ) : rb
scEntityEnumGen "buff" buffs'
scEffectsDeclarations :: Q [Dec]
scEffectsDeclarations = do
contents <- stableIDjsonContents
let (he:re) = effects contents
let effects' = (he & #canonicalName .~ "NullEffect" ) : re
scEntityEnumGen "effect" effects'
scUpgradesDeclarations :: Q [Dec]
scUpgradesDeclarations = do
contents <- stableIDjsonContents
let (hu:ru) = upgrades contents
let upgrades' = (hu & #canonicalName .~ "NullUpgrade" ) : ru
scEntityEnumGen "upgrade" upgrades'
scUnitsDeclarations :: Q [Dec]
scUnitsDeclarations = do
contents <- stableIDjsonContents
let units' = units contents
scEntityEnumGen "unit" units'
sanitiseName :: T.Text -> String
sanitiseName name = let titled = T.unpack name in
case titled of
('1':'0':rest) -> "Ten" ++ rest
('1':'2':rest) -> "Twelve" ++ rest
('1':'4':rest) -> "Fourteen" ++ rest
('1':'6':rest) -> "Sixteen" ++ rest
('1':'8':rest) -> "Eighteen" ++ rest
('2':'0':rest) -> "Twenty" ++ rest
('2':'2':rest) -> "TwentyTwo" ++ rest
('2':'4':rest) -> "TwentyFour" ++ rest
('2':'5':'0':rest) -> "TwoFifty" ++ rest
('3':'3':'0':rest) -> "ThreeThirty" ++ rest
('1':rest) -> "One" ++ rest
('2':rest) -> "Two" ++ rest
('3':rest) -> "Three" ++ rest
('4':rest) -> "Four" ++ rest
('5':rest) -> "Five" ++ rest
('6':rest) -> "Six" ++ rest
('7':rest) -> "Seven" ++ rest
('8':rest) -> "Eight" ++ rest
('9':rest) -> "Nine" ++ rest
('0':rest) -> "Zero" ++ rest
(t:rest) -> toUpper t : rest
instance HasLens' Ability "canonicalName" T.Text where
lensOf' _ = lens theName (\a n -> a{abilityName = n}) where
theName (Ability _ "TerranBuild" "Cancel" Nothing _ Nothing) = "HaltTerranBuild"
theName (Ability _ "ProtossBuild" "Cancel" Nothing _ Nothing) = "HaltProtossBuild"
theName (Ability _ "ZergBuild" "Cancel" Nothing _ Nothing) = "HaltZergBuild"
theName (Ability _ "TerranBuild" bName Nothing _ Nothing) = "Build" `T.append` bName
theName (Ability _ "ProtossBuild" bName Nothing _ Nothing) = "Build" `T.append` bName
theName (Ability _ "ZergBuild" bName Nothing _ Nothing) = "Build" `T.append` bName
theName (Ability _ "WarpGateTrain" bName Nothing _ Nothing) = "WarpGateTrain" `T.append` bName
theName (Ability _ "SuperWarpGateTrain" bName Nothing _ Nothing) = "SuperWarpGateTrain" `T.append` bName
theName (Ability _ name bName Nothing 0 Nothing) = (if "Train" `T.isSuffixOf` name then "Train" else name) `T.append` bName
theName (Ability _ name bName _ _ _ ) | T.toUpper name == T.toUpper bName = (T.concat . fmap T.toTitle . T.words) name
theName (Ability _ name bName Nothing idx Nothing) = if "Train" `T.isSuffixOf` name
then "Train" `T.append` bName
else name `T.append` bName`T.append` (T.pack . show $ idx)
theName (Ability _ name bName (Just fName) idx Nothing) = T.concat . fmap T.toTitle . T.words $ fName
theName a = error (show a)
data EntityDecls = EntityDecls {constructor :: Con, fromClause :: Clause, toClause :: Clause}
scEntityEnumGen :: RawIDMappable a => String -> [a] -> Q [Dec]
scEntityEnumGen nameLower@(firstLetter:restName) entities = go where
nameUpper = toUpper firstLetter : restName
typeName = mkName (nameUpper ++ "Type")
typeDecl = DataD [] typeName [] Nothing cons []
vals = map con entities
cons = map constructor vals
con entity = let
name = entity ^. #canonicalName . to sanitiseName . to mkName
rawid = entity ^. #id
conC = NormalC name []
fromClause = Clause [LitP (IntegerL rawid)] (NormalB (ConE name)) []
toClause' = Clause [ConP name []] (NormalB (LitE (IntegerL rawid))) []
in EntityDecls {constructor = conC, fromClause = fromClause, toClause = toClause'}
entityFromIntName = mkName "fromInt"
entityFromIntDefault = Clause [WildP] (NormalB (AppE (VarE entityFromIntName) (LitE(IntegerL 0)))) []
fromIntDecl = FunD entityFromIntName (map fromClause vals ++ [entityFromIntDefault])
entityToIntName = mkName "toInt"
entityToIntDefault = Clause [WildP] (NormalB ((LitE(IntegerL 0)))) []
toIntDecl = FunD entityToIntName (map toClause vals ++ [entityToIntDefault])
instances' = let name = conT typeName in [d|
deriving instance Eq $name
deriving instance Show $name
deriving instance Enum $name
deriving instance Bounded $name
|]
go = do
instances <- instances'
return ([typeDecl, fromIntDecl, toIntDecl] ++ instances)