Tuples.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Operations.Tuples where

import Funcons.Operations.Internal

library :: HasValues t => Library t
library = libFromList [
    ("tuples", NaryExpr tuples_)
  , ("tuple", NaryExpr tuple_)
  , ("tuple-index", BinaryExpr tuple_index)
  , ("empty-tuple", NullaryExpr  empty_tuple)
  , ("tuple-prepend", BinaryExpr tuple_prepend)
  ]

tuples_ :: HasValues t => [OpExpr t] -> OpExpr t
tuples_ = NaryOp "tuples" (Normal . injectT . ADT "tuples")

empty_tuple_, tuple_prepend_ :: HasValues t => [OpExpr t] -> OpExpr t
empty_tuple_ = nullaryOp empty_tuple
tuple_prepend_ = binaryOp tuple_prepend

empty_tuple :: HasValues t => OpExpr t
empty_tuple = vNullaryOp "empty-tuple" (Normal $ inject (tuple []))

tuple_prepend :: HasValues t => OpExpr t -> OpExpr t -> OpExpr t
tuple_prepend = vBinaryOp "tuple-prepend" op
  where op v (ADTVal "tuple" vs) = Normal $ inject (ADTVal "tuple" (inject v : vs))
        op _ _ = SortErr "tuple-prepend not applied to a value and a tuple"

tuple_ :: HasValues t => [OpExpr t] -> OpExpr t
tuple_ = vNaryOp "tuple" op
  where op ys = Normal $ inject (tuple ys)

tuple_index_ :: HasValues t => [OpExpr t] -> OpExpr t
tuple_index_ = binaryOp tuple_index
tuple_index :: HasValues t => OpExpr t -> OpExpr t -> OpExpr t
tuple_index = vBinaryOp "tuple-index" op
  where op (ADTVal "tuple" ts) v 
          | Nat n' <- upcastNaturals v, let n :: Int; n = fromInteger n'
            = case () of 
               () | n >= 1 && n <= length ts -> Normal $ ts !! (n - 1)
               _ -> SortErr "tuple-index not in range"
          | otherwise = SortErr ("tuple-index not applied to a natural number: " ++ ppValues (const "_") v)
        op _ _ = SortErr "tuple-index not applied to a tuple"