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