module Cryptol.Prims.Syntax
( TFun(..), tBinOpPrec, tfunNames
) where
import Cryptol.Parser.Name (PName,mkUnqual)
import Cryptol.Utils.Ident (packIdent,packInfix)
import Cryptol.Utils.PP
import qualified Data.Map as Map
import GHC.Generics (Generic)
import Control.DeepSeq
data TFun
= TCAdd
| TCSub
| TCMul
| TCDiv
| TCMod
| TCExp
| TCWidth
| TCMin
| TCMax
| TCLenFromThen
| TCLenFromThenTo
deriving (Show, Eq, Ord, Bounded, Enum, Generic, NFData)
tBinOpPrec :: Map.Map TFun (Assoc,Int)
tBinOpPrec = mkMap t_table
where
mkMap t = Map.fromList [ (op,(a,n)) | ((a,ops),n) <- zip t [1..] , op <- ops ]
t_table =
[ (LeftAssoc, [ TCAdd, TCSub ])
, (LeftAssoc, [ TCMul, TCDiv, TCMod ])
, (RightAssoc, [ TCExp ])
]
tfunNames :: Map.Map PName (Int,TFun)
tfunNames = Map.fromList
[ tinfix "+" 2 TCAdd
, tinfix "-" 2 TCSub
, tinfix "*" 2 TCMul
, tinfix "/" 2 TCDiv
, tinfix "%" 2 TCMod
, tinfix "^^" 2 TCExp
, tprefix "width" 1 TCWidth
, tprefix "min" 2 TCMin
, tprefix "max" 2 TCMax
, tprefix "lengthFromThen" 3 TCLenFromThen
, tprefix "lengthFromThenTo" 3 TCLenFromThenTo
]
where
tprefix n a p = (mkUnqual (packIdent n), (a,p))
tinfix n a p = (mkUnqual (packInfix n), (a,p))
instance PPName TFun where
ppNameFixity f = Map.lookup f tBinOpPrec
ppPrefixName TCAdd = text "(+)"
ppPrefixName TCSub = text "(-)"
ppPrefixName TCMul = text "(*)"
ppPrefixName TCDiv = text "(/)"
ppPrefixName TCMod = text "(%)"
ppPrefixName TCExp = text "(^^)"
ppPrefixName f = pp f
ppInfixName TCAdd = text "+"
ppInfixName TCSub = text "-"
ppInfixName TCMul = text "*"
ppInfixName TCDiv = text "/"
ppInfixName TCMod = text "%"
ppInfixName TCExp = text "^^"
ppInfixName f = error $ "Not a prefix type function: " ++ show (pp f)
instance PP TFun where
ppPrec _ tcon =
case tcon of
TCAdd -> text "+"
TCSub -> text "-"
TCMul -> text "*"
TCDiv -> text "/"
TCMod -> text "%"
TCExp -> text "^^"
TCWidth -> text "width"
TCMin -> text "min"
TCMax -> text "max"
TCLenFromThen -> text "lengthFromThen"
TCLenFromThenTo -> text "lengthFromThenTo"