1%include polycode.fmt
2
3%if false
4  Error: DSL for error definition
5   
6  Copyright (c) 2009 ETH Zurich.
7  All rights reserved.
8  
9  This file is distributed under the terms in the attached LICENSE file.
10  If you do not find this file, copies can be found by writing to:
11  ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group.
12%endif
13
14%if false
15
16> {-# LANGUAGE BangPatterns #-}
17
18> module HamletAst where
19
20> import Debug.Trace
21> import Text.PrettyPrint.HughesPJ as Pprinter 
22> import Data.List
23
24%endif
25
26
27> class Pretty a where
28>     pretty :: a -> Doc
29
30> data Capabilities = Capabilities { defines :: ![Define],
31>                                    capabilities :: ![Capability],
32>                                    abstractCapabilities :: ![Capability] }
33>                   deriving Show
34
35> vcat' :: [Doc] -> Doc
36> vcat' = foldr ($+$) empty 
37
38
39> instance Pretty Capabilities where
40>     pretty (Capabilities defs caps absCaps) =
41>         text "Capabilities:" $+$
42>         nest 4 ( text "Defines:" $+$
43>                  nest 4 (vcat' $ map pretty defs) $+$
44>                  text "Caps:" $+$
45>                  nest 4 (vcat' $ map pretty caps) $+$
46>                  text "Abstract Caps:" $+$
47>                  nest 4 (vcat' $ map pretty absCaps))
48                 
49
50> data Define = Define !String !Int
51>             deriving Show
52
53> instance Pretty Define where
54>     pretty (Define name val) = text name <+> char '=' <+> int val
55
56> mkDefineList :: [Define] -> [(String, Int)]
57> mkDefineList = map (\(Define s i) -> (s, i))
58
59> data Capability = Capability { name :: !CapName,
60>                                generalEquality :: !(Maybe Bool),
61>                                from :: !(Maybe CapName),
62>                                fromSelf :: Bool,
63>                                multiRetype :: Bool,
64>                                fields :: ![CapField],
65>                                rangeExpr :: !(Maybe (AddressExpr, SizeExpr)),
66>                                eqFields :: ![NameField],
67>                                abstract :: Bool,
68>                                needsType :: Bool,
69>                                inherit :: !(Maybe CapName) }
70>                 deriving Show
71
72> instance Pretty Capability where
73>     pretty (Capability (CapName name)
74>                        genEq 
75>                        from
76>                        fromSelf
77>                        multiRetype
78>                        fields
79>                        rangeExpr
80>                        eqFields
81>                        abstract
82>                        needsType
83>                        inherit) =
84>        text name $+$
85>        nest 4 (text "General Equality:" <+> text (show genEq) $+$
86>                case from of
87>                    Nothing -> text $ if fromSelf then "From self" else "From nothing"
88>                    Just (CapName fromName) ->
89>                        text "From:" <+> text fromName <> text (if fromSelf then " and self" else "")
90>                $+$
91>                case abstract of
92>                    True -> text " abstract "
93>                    False -> text ""
94>                $+$
95>                case needsType of
96>                    True -> text " needsType "
97>                    False -> text ""
98>                $+$
99>                case inherit of
100>                    Nothing -> text ""
101>                    Just (CapName inheritName) ->
102>                        text "inherit " <+> text inheritName
103>                $+$
104>                text "Fields:" <> text (if null fields then " None" else "") $+$
105>                text (if multiRetype then "Can be retyped multiple times." else "") $+$
106>                nest 4 (vcat' (map pretty fields)) $+$
107>                (case rangeExpr of
108>                     Nothing -> text "Not addressable"
109>                     Just (addressExpr, sizeExprE) ->
110>                         (text "Address expr:" <+> pretty addressExpr $+$
111>                          text "Size expr:" <+> (pretty sizeExprE)))
112>                $+$
113>                text "Equality fields:" <+> (text $ intercalate ", " $ map (\(NameField n) -> n) eqFields))
114
115> data CapName = CapName !String
116>              deriving (Show, Eq)
117
118> data CapField = CapField !Type !NameField 
119>               deriving Show
120> instance Pretty CapField where
121>     pretty (CapField typ (NameField name)) = 
122>         text (show typ) <+> text name
123
124> data NameField = NameField !String
125>                deriving Show
126
127> data Type = UInt8
128>           | UInt16
129>           | UInt32
130>           | UInt64
131>           | Int
132>           | GenPAddr
133>           | GenSize
134>           | LPAddr
135>           | GenVAddr
136>           | LVAddr
137>           | CAddr
138>           | Pointer String
139>           | CapRights
140>           | CoreId
141>           | PasId
142>             deriving Show
143
144> instance Read Type where
145>     readsPrec _ s 
146>         | s == "uint8" = [(UInt8, "")]
147>         | s == "uint16" = [(UInt16, "")]
148>         | s == "uint32" = [(UInt32, "")]
149>         | s == "uint64" = [(UInt64, "")]
150>         | s == "int" = [(Int, "")]
151>         | s == "genpaddr" = [(GenPAddr, "")]
152>         | s == "gensize" = [(GenSize, "")]
153>         | s == "lpaddr" = [(LPAddr, "")]
154>         | s == "genvaddr" = [(GenVAddr, "")]
155>         | s == "lvaddr" = [(LVAddr, "")]
156>         | s == "caddr" = [(CAddr, "")]
157>         | s == "caprights" = [(CapRights, "")]
158>         | s == "coreid" = [(CoreId, "")]
159>         | s == "pasid" = [(PasId, "")]
160>         | otherwise = [(Pointer s, "")]
161
162> data AddressExpr = AddressExpr Expr | MemToPhysOp Expr | GetAddrOp Expr
163>                  deriving Show
164> instance Pretty AddressExpr where
165>     pretty (AddressExpr e) = pretty e
166>     pretty (MemToPhysOp e) = text "mem_to_phys(" <> pretty e <> text ")"
167>     pretty (GetAddrOp e)   = text "get_address(" <> pretty e <> text ")"
168
169> data SizeExpr = ZeroSize | SizeExpr Expr | SizeBitsExpr Expr
170>               deriving Show
171> instance Pretty SizeExpr where
172>     pretty (ZeroSize) = text "0"
173>     pretty (SizeExpr e) = pretty e
174>     pretty (SizeBitsExpr e) = text "2^(" <> pretty e <> char ')'
175
176> data Expr = AddExpr String String | NameExpr String
177>           deriving Show
178> instance Pretty Expr where
179>     pretty (AddExpr l r) = text $ concat ["(", l, " + ", r, ")"]
180>     pretty (NameExpr n) = text n
181
182