1-- @LICENSE(NICTA_CORE) 2 3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE DeriveGeneric #-} 5 6module Cogent.Common.Syntax where 7 8import Cogent.Compiler 9 10import Data.Binary (Binary) 11import Data.Data hiding (Prefix) 12#if __GLASGOW_HASKELL__ < 709 13import Data.Monoid 14#endif 15import Data.Word 16import GHC.Generics (Generic) 17import Text.PrettyPrint.ANSI.Leijen 18 19type RepName = String 20type DataLayoutName = RepName -- For gradual transition to eliminate Rep from the compiler 21type FieldName = String 22type TagName = String 23type FunName = String 24type ConstName = String 25type VarName = String 26type TyVarName = String 27type RecParName = String 28type TypeName = String 29type DLVarName = String 30 31newtype CoreFunName = CoreFunName { unCoreFunName :: String } 32 deriving (Eq, Show, Ord, Generic) 33 34instance Binary CoreFunName 35 36funNameToCoreFunName :: FunName -> CoreFunName 37funNameToCoreFunName = CoreFunName 38 39unsafeNameToCoreFunName :: String -> CoreFunName 40unsafeNameToCoreFunName = CoreFunName 41 42unsafeCoreFunName :: String -> CoreFunName 43unsafeCoreFunName = CoreFunName 44 45type FieldIndex = Int 46type ArrayIndex = Word32 -- It actually can be large on 64-bit machines, but for now we just leave them Word32 for simplicity / zilinc 47type ArraySize = Word32 48 49type Size = Integer -- Not sure why quickcheck tests infinite loop if Size = Word32. 50 51type OpName = String 52 53data Op 54 = Plus | Minus | Times | Divide | Mod 55 | Not | And | Or 56 | Gt | Lt | Le | Ge | Eq | NEq 57 | BitAnd | BitOr | BitXor | LShift | RShift | Complement 58 deriving (Data, Eq, Ord, Show, Generic) 59 60instance Binary Op 61 62data Pragma = InlinePragma FunName 63 | CInlinePragma FunName 64 | FnMacroPragma FunName 65 | UnrecPragma String 66 deriving (Data, Eq, Show) 67 68data Associativity = LeftAssoc Int 69 | RightAssoc Int 70 | NoAssoc Int 71 | Prefix 72 deriving Eq 73 74associativity :: Op -> Associativity 75associativity x | x `elem` [Times, Divide, Mod] = LeftAssoc 11 76 | x `elem` [Plus, Minus] = LeftAssoc 12 77 | x `elem` [Gt, Lt, Le, Ge, Eq, NEq] = NoAssoc 13 78 | x `elem` [BitAnd] = LeftAssoc 14 79 | x `elem` [BitXor] = LeftAssoc 15 80 | x `elem` [BitOr] = LeftAssoc 16 81 | x `elem` [LShift, RShift] = LeftAssoc 17 82 | x `elem` [And] = RightAssoc 18 83 | x `elem` [Or] = RightAssoc 19 84 | otherwise = Prefix 85 86symbolOp :: OpName -> Op 87symbolOp "+" = Plus 88symbolOp "-" = Minus 89symbolOp "*" = Times 90symbolOp "/" = Divide 91symbolOp "%" = Mod 92symbolOp "not" = Not 93symbolOp "&&" = And 94symbolOp "||" = Or 95symbolOp ">=" = Ge 96symbolOp "<=" = Le 97symbolOp "<" = Lt 98symbolOp ">" = Gt 99symbolOp "==" = Eq 100symbolOp "/=" = NEq 101symbolOp ".&." = BitAnd 102symbolOp ".|." = BitOr 103symbolOp ".^." = BitXor 104symbolOp ">>" = RShift 105symbolOp "<<" = LShift 106symbolOp "complement" = Complement 107symbolOp x = __impossible "symbolOp" 108 109opSymbol :: Op -> String 110opSymbol Plus = "+" 111opSymbol Minus = "-" 112opSymbol Times = "*" 113opSymbol Divide = "/" 114opSymbol Mod = "%" 115opSymbol Not = "not" 116opSymbol And = "&&" 117opSymbol Or = "||" 118opSymbol Gt = ">" 119opSymbol Lt = "<" 120opSymbol Le = "<=" 121opSymbol Ge = ">=" 122opSymbol Eq = "==" 123opSymbol NEq = "/=" 124opSymbol BitAnd = ".&." 125opSymbol BitOr = ".|." 126opSymbol BitXor = ".^." 127opSymbol LShift = "<<" 128opSymbol RShift = ">>" 129opSymbol Complement = "complement" 130 131instance Pretty Op where 132 pretty = string . opSymbol 133 134data Likelihood = Unlikely | Regular | Likely deriving (Show, Data, Eq, Ord) 135 136#if __GLASGOW_HASKELL__ < 803 137instance Monoid Likelihood where 138 mempty = Regular 139 mappend Unlikely Likely = Regular 140 mappend Unlikely _ = Unlikely 141 mappend Likely Unlikely = Regular 142 mappend Likely _ = Likely 143 mappend Regular l = l 144#else 145instance Semigroup Likelihood where 146 (<>) Unlikely Likely = Regular 147 (<>) Unlikely _ = Unlikely 148 (<>) Likely Unlikely = Regular 149 (<>) Likely _ = Likely 150 (<>) Regular l = l 151instance Monoid Likelihood where 152 mempty = Regular 153#endif 154 155tagSuccess = "Success" :: TagName 156tagFail = "Fail" :: TagName 157 158 159-- ---------------------------------------------------------------------------- 160-- custTyGen 161 162data CustTyGenInfo = CTGI deriving (Show, Generic) -- TODO: info like field mapping, etc. 163 164instance Binary CustTyGenInfo 165 166-- ex1 :: M.Map (Type 'Zero) (String, CustTypeGenInfo) 167-- ex1 = M.singleton (TRecord [("f1", (TCon "A" [] Unboxed, False)), 168-- ("f2", (TCon "B" [] Unboxed, False)), 169-- ("f3", (TCon "C" [] Writable, False))] Writable) ("T_c_t", CTGI) 170 171 172