-
Notifications
You must be signed in to change notification settings - Fork 0
/
PrettyPrint.hs
147 lines (121 loc) · 4.86 KB
/
PrettyPrint.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
module PrettyPrint where
import Data.Char
import Data.List
import Data.List.Split
import Data.Maybe
import Text.Printf
import Control.Arrow
import Control.Applicative
import Debug.Trace
data Entity = Int Int
| Bool Bool
| Char Char
| Maybe (Maybe Entity)
| Ratio Entity Entity
| Tuple [Entity]
| List [Entity]
| Constructor String [Entity]
| Named String Entity
| Unknown
instance Show Entity where
show Unknown = "UNKNOWN"
show (Int i) = show i
show (Bool b) = show b
show (Maybe m) = show m
show (Char c) = show c
show (Ratio n d) = show n ++ " / " ++ show d
show (Tuple t) = "(" ++ intercalate ", " (map show t) ++ ")"
show (Constructor n f) = "(" ++ n ++ " " ++ intercalate " " (map show f) ++ ")"
show (Named n v) = (show n) ++ " = " ++ (show v)
show (List l) | all isChar l = show $ map ofChar l
| otherwise = "[" ++ intercalate ", " (map show l) ++ "]"
where isChar (Char _) = True
isChar _ = False
ofChar (Char c) = c
type Objects = [(Path, String)]
type Path = [Name]
type Name = String
parseInt :: String -> Int
parseInt = read
{-
parseInt ('\\':str) =
sum $ zipWith (*) (map (read . ("0"++)) $ splitOn "\\" str) (map (256 ^ ) [0 ..])
parseInt _ = error "Incorrect format for integer"
-}
parseChar :: String -> Char
parseChar = chr <$> parseInt
parseBool :: String -> Bool
parseBool = (== 1) <$> (`rem` 2) <$> parseInt
names :: Objects -> [Name]
names = nub <$> map ((\a -> if a == [] then error "baz" else head a) . fst)
focus :: Name -> Objects -> Objects
focus name list =
map (first tail) $
filter (\(path, _) -> if path == [] then False else head path == name)
list
isList :: Objects -> Bool
isList = isJust <$> lookup ["BoolVal"] <$> focus "IsNil"
listSegments :: Objects -> [Entity]
listSegments attributes =
case parseBool <$> lookup ["BoolVal"] (focus "IsNil" attributes) of
Just True -> []
Just False -> repr "car" attributes : listSegments (focus "cdr" attributes)
Nothing -> error "Could not find IsNil in list"
listRepr :: Objects -> Entity
listRepr = List . listSegments
isTuple :: Objects -> Bool
isTuple = (&&) <$> ((not . null) <$> focus "1") <*> (not <$> isConstructor)
isConstructor :: Objects -> Bool
isConstructor = (not . null) <$> names <$> focus "Constructor"
tupleSegments :: Int -> Objects -> [Entity]
tupleSegments num attributes =
map (focusedRepr . flip focus attributes . show) [1 .. num]
tupleRepr :: Objects -> Entity
tupleRepr attributes =
Tuple $ tupleSegments len attributes
where len = length $ names attributes
isRatio :: Objects -> Bool
isRatio = (&&) <$> (not . null . focus "Numerator") <*> (not . null . focus "Denominator")
ratioRepr :: Objects -> Entity
ratioRepr = Ratio <$> (focusedRepr . focus "Numerator") <*> (focusedRepr . focus "Denominator")
repr :: Name -> Objects -> Entity
repr name objects = focusedRepr $ focus name objects
constructorFields :: Objects -> [Entity]
constructorFields objects = do
name <- names objects
if name == "Constructor"
then []
else do
let value = focusedRepr $ focus name objects
if isDigit $ head name
then return value
else return $ Named name value
--focusedRepr <$> flip focus objects <$> filter (isDigit . head) (names objects)
constructorRepr :: Objects -> Entity
constructorRepr objects =
case focus "Constructor" objects of
[([constructorList, "IntVal"], index)] ->
let constructors = read constructorList
i = if length constructors == 1 then 0 else parseInt index - 1
in Constructor (constructors !! i) $ constructorFields objects
_ -> error "Could not find constructor name"
focusedRepr :: Objects -> Entity
focusedRepr [] = Unknown
focusedRepr [(["IntVal"], str)] = Int $ parseInt str
focusedRepr [(["BoolVal"], str)] = Bool $ parseBool str
focusedRepr [(["CharVal"], str)] = Char $ parseChar str
focusedRepr attributes | isList attributes = listRepr attributes
| isTuple attributes = tupleRepr attributes
| isConstructor attributes = constructorRepr attributes
| isRatio attributes = ratioRepr attributes
| otherwise = Unknown
fromRawLines :: [String] -> Objects
fromRawLines = map fromRawLine <$> chunksOf packet <$> drop header
where header = 3
packet = 3
fromRawLine :: [String] -> (Path, String)
fromRawLine [name, _, content] = (path, element)
where path = splitOn "%" $ quoted name
element = drop (length "object 0: data: ") content
quoted = takeWhile (/= '\'') <$> tail <$> dropWhile (/= '\'')
fromRawLine _ = error "Fatal error: wrong invocation of internal fromRawLine"