|
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] |
|
65 breakNTPX (InitArray ia) = map (InitArray . filter (not . isNtpx)) $ groupBy (\a _ -> not $ isNtpx a) ia |
|
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 |