Vectors.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Core.Values.Composite.Collections.Vectors where

import Funcons.Types
import Funcons.EDSL
import qualified Data.Vector as V

library = libFromList [
        ("vector-repeat", ValueOp stepVector_Repeat)
    ,   ("vector-length", ValueOp vector_length_op)
    ,   ("vector-index", ValueOp stepVector_Index)
    ,   ("vector-append", ValueOp vector_append_op)
    ,   ("vector", ValueOp stepVector)
    ,   ("list-to-vector", ValueOp list_to_vector_op)
    ,   ("vector-to-list", ValueOp stepVector_To_List)
    ]

stepVector_Repeat [m,v]
    | Nat n <- upcastNaturals m = rewriteTo $ FValue $ Vector $ V.replicate (fromInteger n) v
stepVector_Repeat v             = sortErr (applyFuncon "vector-repeat" (fvalues v)) "vector-repeat not applied to a nat and value"

stepVector_To_List [Vector v]   = rewriteTo $ listval $ V.toList v
stepVector_To_List v            = sortErr (applyFuncon "vector-to-list" (fvalues v)) "vector-to-list not applied to a vector"

vector_empty :: Rewrite Rewritten
vector_empty = rewritten (Vector V.empty)

vector_length_op [Vector v] = rewriteTo $ int_ (V.length v)
vector_length_op vs = sortErr (applyFuncon "vector-length" (fvalues vs))
                                "vector-length not applied to vector"

stepVector_Index :: [Values] -> Rewrite Rewritten
stepVector_Index [v,n] = vector_index_op v n
 where
    vector_index_op :: Values -> Values -> Rewrite Rewritten
    vector_index_op (Vector v) vn | Nat n <- upcastNaturals vn =
        case v V.!? (fromInteger n) of
            Nothing -> partialOp (applyFuncon "vector-index" [FValue (Vector v), FValue vn]) "vector-index out of range"
            Just r  -> rewriteTo $ FValue $ r
    vector_index_op v vn = sortErr (applyFuncon "vector-index" [FValue v, FValue vn]) "vector-index not applied to a vector and a natural number"
stepVector_Index vs = sortErr (applyFuncon "vector-index" (fvalues vs)) "vector-index not applied to a vector and a natural number"

vector_append = applyFuncon "vector-append"
vector_append_op :: [Values] -> Rewrite Rewritten
vector_append_op vs
    | all isVec vs = rewriteTo $ FValue $ Vector $ foldr ((V.++) . toVec) V.empty vs
 where toVec (Vector v) = v
       toVec _          = error "vector-append not applied to vectors"
       isVec (Vector v) = True
       isVec _          = False
vector_append_op vs = sortErr (vector_append (fvalues vs))
                                    "vector-append not applied to a sequence of vectors"

stepVector vs = rewriteTo $ FValue (Vector (V.fromList vs))

vector_repeat = applyFuncon "vector-repeat"

list_to_vector = applyFuncon "list-to-vector"
list_to_vector_op :: [Values] -> Rewrite Rewritten
list_to_vector_op [List l] = rewriteTo $ FValue $ Vector $ V.fromList l
list_to_vector_op vs = sortErr (list_to_vector (fvalues vs))
                            "list-to-vector not applied to a list"