Syntax.hs

-- |
-- Module      :  $Header$
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
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

-- | Built-in types.
data TFun

  = TCAdd                 -- ^ @ : Num -> Num -> Num @
  | TCSub                 -- ^ @ : Num -> Num -> Num @
  | TCMul                 -- ^ @ : Num -> Num -> Num @
  | TCDiv                 -- ^ @ : Num -> Num -> Num @
  | TCMod                 -- ^ @ : Num -> Num -> Num @
  | TCExp                 -- ^ @ : Num -> Num -> Num @
  | TCWidth               -- ^ @ : Num -> Num @
  | TCMin                 -- ^ @ : Num -> Num -> Num @
  | TCMax                 -- ^ @ : Num -> Num -> Num @

  -- Computing the lengths of explicit enumerations
  | TCLenFromThen         -- ^ @ : Num -> Num -> Num -> Num@
    -- Example: @[ 1, 5 .. ] :: [lengthFromThen 1 5 b][b]@

  | TCLenFromThenTo       -- ^ @ : Num -> Num -> Num -> Num@
    -- Example: @[ 1, 5 .. 9 ] :: [lengthFromThenTo 1 5 9][b]@

    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 ]

  -- lowest to highest
  t_table =
    [ (LeftAssoc,   [ TCAdd, TCSub ])
    , (LeftAssoc,   [ TCMul, TCDiv, TCMod ])
    , (RightAssoc,  [ TCExp ])
    ]

-- | Type functions, with their arity and function constructor.
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"