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