{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Monad

import Data.Maybe

import qualified Data.Yaml as YAML

import Data.Yaml ((.=))

import Data.List

import qualified Data.ByteString.Char8 as B

import qualified Data.Text as Text

import PascalUnitSyntaxTree

fixName :: String -> String

fixName "MaxHedgeHogs" = "max_hedgehogs"

fixName"canFlip" = "can_flip"

fixName"canInvert" = "can_invert"

fixName"canMirror" = "can_mirror"

fixName"TemplateWidth" = "width"

fixName"TemplateHeight" = "height"

fixName"RandPassesCount" = "rand_passes"

fixName"BezierizeCount" = "bezie_passes"

fixName"hasGirders" = "put_girders"

fixName"isNegative" = "is_negative"

fixName a = a

instance YAML.ToJSON InitExpression where

  toJSON (InitArray ar) = YAML.toJSON ar

  toJSON (InitRecord ar) = YAML.object $ map (\(Identifier i _, iref) ->  Text.pack (fixName i) .= iref) $ filter isRelevant ar

    where

        isRelevant (Identifier i _, _) | i `elem` ["BasePoints", "FillPoints", "BasePointsCount", "FillPointsCount"] = False

        isRelevant _ = True

  toJSON (InitTypeCast {}) = YAML.object []

  toJSON (BuiltInFunction {}) = YAML.object []

  toJSON (InitNumber n) = YAML.toJSON (read n :: Int)

  toJSON (InitReference (Identifier "true" _)) = YAML.toJSON True

  toJSON (InitReference (Identifier "false" _)) = YAML.toJSON False

  toJSON a = error $ show a

instance YAML.ToJSON Identifier where

    toJSON (Identifier i _) = YAML.toJSON i

data Template = Template InitExpression ([InitExpression], InitExpression)

    deriving Show

instance YAML.ToJSON Template where

    toJSON (Template (InitRecord ri) (points, fpoints)) = YAML.toJSON $ InitRecord $ ri ++ [(Identifier "outline_points" BTUnknown, InitArray points), (Identifier "fill_points" BTUnknown, fpoints)]

takeLast i = reverse . take i . reverse

extractDeclarations  :: PascalUnit -> [TypeVarDeclaration]

extractDeclarations (Unit (Identifier "uLandTemplates" _) (Interface _ (TypesAndVars decls)) _ _ _) = decls

extractDeclarations _ = error "Unexpected file structure"

extractTemplatePoints :: Int -> [TypeVarDeclaration] -> ([InitExpression], InitExpression)

extractTemplatePoints templateNumber decls = (breakNTPX . head . catMaybes $ map (toTemplatePointInit "Points") decls, head . catMaybes $ map (toTemplatePointInit "FPoints") decls)

    where

        toTemplatePointInit suffix (VarDeclaration False False ([Identifier i _], _) ie)

            | (i == "Template" ++ show templateNumber ++ suffix) = ie

            | otherwise = Nothing

        toTemplatePointInit _ _ = Nothing

        breakNTPX :: InitExpression -> [InitExpression]

        breakNTPX (InitArray ia) = map (InitArray . filter (not . isNtpx)) $ groupBy (\a _ -> not $ isNtpx a) ia

        breakNTPX a = error $ show a

        isNtpx :: InitExpression -> Bool

        isNtpx (InitRecord ((Identifier "x" _, InitReference (Identifier "NTPX" _)):_)) = True

        isNtpx _ = False

extractTemplates :: [TypeVarDeclaration] -> [Template]

extractTemplates decls = map toFull $ zip (head . catMaybes $ map toTemplateInit decls) [0..]

    where

        toTemplateInit (VarDeclaration False False ([Identifier "EdgeTemplates" _], _) (Just (InitArray ia))) = Just ia

        toTemplateInit _ = Nothing

        toFull (ie, num) = let ps = extractTemplatePoints num decls in if "NTPX" `isInfixOf` show ps then error $ show num ++ " " ++ show ps else Template ie ps

convert :: PascalUnit -> B.ByteString

convert pu = YAML.encode . extractTemplates . extractDeclarations $ pu

main = do

    f <- liftM read $ readFile "uLandTemplates.dump"

    B.putStrLn $ convert f