13892
+ − 1
{-# LANGUAGE OverloadedStrings #-}
+ − 2
module Main where
+ − 3
+ − 4
import Control.Monad
+ − 5
import Data.Maybe
+ − 6
import qualified Data.Yaml as YAML
+ − 7
import Data.Yaml ((.=))
+ − 8
import Data.List
+ − 9
import qualified Data.ByteString.Char8 as B
+ − 10
import qualified Data.Text as Text
+ − 11
+ − 12
import PascalUnitSyntaxTree
+ − 13
+ − 14
+ − 15
fixName :: String -> String
+ − 16
fixName "MaxHedgeHogs" = "max_hedgehogs"
+ − 17
fixName"canFlip" = "can_flip"
+ − 18
fixName"canInvert" = "can_invert"
+ − 19
fixName"canMirror" = "can_mirror"
+ − 20
fixName"TemplateWidth" = "width"
+ − 21
fixName"TemplateHeight" = "height"
+ − 22
fixName"RandPassesCount" = "rand_passes"
+ − 23
fixName"BezierizeCount" = "bezie_passes"
+ − 24
fixName"hasGirders" = "put_girders"
+ − 25
fixName"isNegative" = "is_negative"
+ − 26
fixName a = a
+ − 27
+ − 28
instance YAML.ToJSON InitExpression where
+ − 29
toJSON (InitArray ar) = YAML.toJSON ar
+ − 30
toJSON (InitRecord ar) = YAML.object $ map (\(Identifier i _, iref) -> Text.pack (fixName i) .= iref) $ filter isRelevant ar
+ − 31
where
+ − 32
isRelevant (Identifier i _, _) | i `elem` ["BasePoints", "FillPoints", "BasePointsCount", "FillPointsCount"] = False
+ − 33
isRelevant _ = True
+ − 34
toJSON (InitTypeCast {}) = YAML.object []
+ − 35
toJSON (BuiltInFunction {}) = YAML.object []
+ − 36
toJSON (InitNumber n) = YAML.toJSON (read n :: Int)
+ − 37
toJSON (InitReference (Identifier "true" _)) = YAML.toJSON True
+ − 38
toJSON (InitReference (Identifier "false" _)) = YAML.toJSON False
+ − 39
toJSON a = error $ show a
+ − 40
+ − 41
instance YAML.ToJSON Identifier where
+ − 42
toJSON (Identifier i _) = YAML.toJSON i
+ − 43
+ − 44
data Template = Template InitExpression ([InitExpression], InitExpression)
+ − 45
deriving Show
+ − 46
+ − 47
instance YAML.ToJSON Template where
+ − 48
toJSON (Template (InitRecord ri) (points, fpoints)) = YAML.toJSON $ InitRecord $ ri ++ [(Identifier "outline_points" BTUnknown, InitArray points), (Identifier "fill_points" BTUnknown, fpoints)]
+ − 49
+ − 50
takeLast i = reverse . take i . reverse
+ − 51
+ − 52
extractDeclarations :: PascalUnit -> [TypeVarDeclaration]
+ − 53
extractDeclarations (Unit (Identifier "uLandTemplates" _) (Interface _ (TypesAndVars decls)) _ _ _) = decls
+ − 54
extractDeclarations _ = error "Unexpected file structure"
+ − 55
+ − 56
extractTemplatePoints :: Int -> [TypeVarDeclaration] -> ([InitExpression], InitExpression)
+ − 57
extractTemplatePoints templateNumber decls = (breakNTPX . head . catMaybes $ map (toTemplatePointInit "Points") decls, head . catMaybes $ map (toTemplatePointInit "FPoints") decls)
+ − 58
where
+ − 59
toTemplatePointInit suffix (VarDeclaration False False ([Identifier i _], _) ie)
+ − 60
| (i == "Template" ++ show templateNumber ++ suffix) = ie
+ − 61
| otherwise = Nothing
+ − 62
toTemplatePointInit _ _ = Nothing
+ − 63
+ − 64
breakNTPX :: InitExpression -> [InitExpression]
13903
+ − 65
breakNTPX (InitArray ia) = map InitArray . filter ((<) 0 . length) . map (filter (not . isNtpx)) $ groupBy (\a b -> isNtpx a == isNtpx b) ia
13892
+ − 66
breakNTPX a = error $ show a
+ − 67
isNtpx :: InitExpression -> Bool
+ − 68
isNtpx (InitRecord ((Identifier "x" _, InitReference (Identifier "NTPX" _)):_)) = True
+ − 69
isNtpx _ = False
+ − 70
+ − 71
extractTemplates :: [TypeVarDeclaration] -> [Template]
+ − 72
extractTemplates decls = map toFull $ zip (head . catMaybes $ map toTemplateInit decls) [0..]
+ − 73
where
+ − 74
toTemplateInit (VarDeclaration False False ([Identifier "EdgeTemplates" _], _) (Just (InitArray ia))) = Just ia
+ − 75
toTemplateInit _ = Nothing
+ − 76
+ − 77
toFull (ie, num) = let ps = extractTemplatePoints num decls in if "NTPX" `isInfixOf` show ps then error $ show num ++ " " ++ show ps else Template ie ps
+ − 78
+ − 79
convert :: PascalUnit -> B.ByteString
+ − 80
convert pu = YAML.encode . extractTemplates . extractDeclarations $ pu
+ − 81
+ − 82
main = do
+ − 83
f <- liftM read $ readFile "uLandTemplates.dump"
+ − 84
B.putStrLn $ convert f