module CSPM.Evaluator.Values (
Value(..), Proc(..), ProcOperator(..), Event(..),
compareValues,
procId,
valueEventToEvent,
combineDots,
extensions, oneFieldExtensions,
productions,
) where
import Control.Monad
import Data.Foldable (foldrM)
import CSPM.Compiler.Events
import CSPM.Compiler.Processes
import CSPM.DataStructures.Names
import CSPM.DataStructures.Syntax
import CSPM.Evaluator.Monad
import CSPM.Evaluator.ValueSet hiding (cartesianProduct)
import CSPM.PrettyPrinter
import Util.Exception
import Util.List
import Util.Prelude
import Util.PrettyPrint
data Value =
VInt Int
| VBool Bool
| VTuple [Value]
| VDot [Value]
| VChannel Name
| VDataType Name
| VList [Value]
| VSet ValueSet
| VFunction ([Value] -> EvaluationMonad Value)
| VProc Proc
instance Eq Value where
VInt i1 == VInt i2 = i1 == i2
VBool b1 == VBool b2 = b1 == b2
VTuple vs1 == VTuple vs2 = vs1 == vs2
VDot vs1 == VDot vs2 = vs1 == vs2
VChannel n1 == VChannel n2 = n1 == n2
VDataType n1 == VDataType n2 = n1 == n2
VList vs1 == VList vs2 = vs1 == vs2
VSet s1 == VSet s2 = s1 == s2
v1 == v2 = False
compareValues :: Value -> Value -> Maybe Ordering
compareValues (VInt i1) (VInt i2) = Just (compare i1 i2)
compareValues (VBool b1) (VBool b2) = Just (compare b1 b2)
compareValues (VTuple vs1) (VTuple vs2) =
let
cmp [] [] = EQ
cmp (x:xs) (y:ys) = compare x y `thenCmp` cmp xs ys
in Just (cmp vs1 vs2)
compareValues (VList vs1) (VList vs2) =
let
cmp [] [] = Just EQ
cmp [] (y:ys) = Just LT
cmp (x:xs) [] = Just GT
cmp (x:xs) (y:ys) | x == y = cmp xs ys
cmp (x:xs) (y:ys) =
Nothing
in cmp vs1 vs2
compareValues (VSet s1) (VSet s2) = compareValueSets s1 s2
compareValues (VChannel n1) (VChannel n2) =
if n1 == n2 then Just EQ else Nothing
compareValues (VDataType n1) (VDataType n2) =
if n1 == n2 then Just EQ else Nothing
compareValues (VDot vs1) (VDot vs2) =
if vs1 == vs2 then Just EQ else Nothing
compareValues v1 v2 = panic $
"Cannot compare "++show v1++" "++show v2
instance Ord Value where
compare (VInt i1) (VInt i2) = compare i1 i2
compare (VBool b1) (VBool b2) = compare b1 b2
compare (VTuple vs1) (VTuple vs2) = compare vs1 vs2
compare (VList vs1) (VList vs2) = compare vs1 vs2
compare (VSet s1) (VSet s2) = compare s1 s2
compare (VDot vs1) (VDot vs2) = compare vs1 vs2
compare (VChannel n) (VChannel n') = compare n n'
compare (VDataType n) (VDataType n') = compare n n'
compare v1 v2 = panic $
"Internal sets - cannot order "++show v1++" "++show v2
instance PrettyPrintable Value where
prettyPrint (VInt i) = int i
prettyPrint (VBool True) = text "true"
prettyPrint (VBool False) = text "false"
prettyPrint (VTuple vs) = parens (list $ map prettyPrint vs)
prettyPrint (VDot vs) = dotSep (map prettyPrint vs)
prettyPrint (VChannel n) = prettyPrint n
prettyPrint (VDataType n) = prettyPrint n
prettyPrint (VList vs) = angles (list $ map prettyPrint vs)
prettyPrint (VSet s) = prettyPrint s
prettyPrint (VFunction _) = text "<function>"
prettyPrint (VProc p) = prettyPrint p
instance Show Value where
show v = show (prettyPrint v)
arityOfDataTypeClause :: Name -> EvaluationMonad Int
arityOfDataTypeClause n = do
VTuple [_, VInt a,_] <- lookupVar n
return a
combineDots :: Value -> Value -> EvaluationMonad Value
combineDots v1 v2 =
let
maybeDotFieldOn :: Value -> Value -> EvaluationMonad (Maybe Value)
maybeDotFieldOn (VDot (nd:vs)) v = do
let
mn = case nd of
VDataType n -> Just n
VChannel n -> Just n
_ -> Nothing
case mn of
Nothing -> return Nothing
Just n -> do
a <- arityOfDataTypeClause n
let fieldCount = length vs
if a == 0 then return Nothing
else if length vs == 0 then
return $ Just (VDot [nd, v])
else do
mv <- maybeDotFieldOn (last vs) v
case mv of
Just vLast ->
return $ Just (VDot (nd:replaceLast vs vLast))
Nothing | fieldCount < a ->
return $ Just (VDot (nd:vs++[v]))
Nothing | fieldCount == a -> return Nothing
Nothing | fieldCount > a -> panic "Malformed dot encountered."
maybeDotFieldOn vbase v = return Nothing
dotAndReduce :: Value -> Value -> Value
dotAndReduce (VDot (VDataType n1:vs1)) (VDot (VDataType n2:vs2)) =
VDot [VDot (VDataType n1:vs1), VDot (VDataType n2:vs2)]
dotAndReduce (VDot (VDataType n1:vs1)) (VDot vs2) =
VDot (VDot (VDataType n1:vs1) : vs2)
dotAndReduce (VDot vs1) (VDot (VDataType n2:vs2)) =
VDot (vs1 ++ [VDot (VDataType n2:vs2)])
dotAndReduce v1 v2 = VDot [v1, v2]
dotFieldOn :: Value -> Value -> EvaluationMonad Value
dotFieldOn vBase vField = do
mv <- maybeDotFieldOn vBase vField
case mv of
Just v -> return v
Nothing -> return $ dotAndReduce vBase vField
splitIntoFields :: Value -> [Value]
splitIntoFields (v@(VDot (VDataType n:_))) = [v]
splitIntoFields (VDot vs) = vs
splitIntoFields v = [v]
dotManyFieldsOn :: Value -> [Value] -> EvaluationMonad Value
dotManyFieldsOn v [] = return v
dotManyFieldsOn vBase (v:vs) = do
vBase' <- dotFieldOn vBase v
dotManyFieldsOn vBase' vs
in
dotManyFieldsOn v1 (splitIntoFields v2)
procId :: Name -> [[Value]] -> ProcName
procId n vss = ProcName n vss
valueEventToEvent :: Value -> Event
valueEventToEvent v = UserEvent (show (prettyPrint v))
oneFieldExtensions :: Value -> EvaluationMonad [Value]
oneFieldExtensions (VDot (dn:vs)) = do
let
mn = case dn of
VChannel n -> Just n
VDataType n -> Just n
_ -> Nothing
case mn of
Nothing -> return [VDot []]
Just n -> do
let fieldCount = length vs
VTuple [_, VInt arity, VList fieldSets] <- lookupVar n
mexs <-
if fieldCount > 0 then do
exs <- oneFieldExtensions (last vs)
if exs /= [VDot []] then return $ Just exs
else return Nothing
else return Nothing
return $ case mexs of
Just exs -> exs
Nothing ->
if arity == fieldCount then [VDot []]
else
map (\ v -> VDot [v])
(head [s | VList s <- drop (length vs) fieldSets])
oneFieldExtensions _ = return [VDot []]
extensions :: Value -> EvaluationMonad [Value]
extensions (VDot (dn:vs)) = do
let
mn = case dn of
VChannel n -> Just n
VDataType n -> Just n
_ -> Nothing
case mn of
Nothing -> return [VDot []]
Just n -> do
let fieldCount = length vs
VTuple [_, VInt arity, VList fieldSets] <- lookupVar n
exsLast <-
if fieldCount == 0 then return [VDot []]
else extensions (last vs)
if arity == fieldCount then return exsLast
else
let
remainingFields = [s | VList s <- drop (length vs) fieldSets]
combineDots ((VDot vs1):vs2) = VDot (vs1++vs2)
fields = exsLast:remainingFields
in return $ map combineDots (cartesianProduct fields)
extensions v = return [VDot []]
productions :: Value -> EvaluationMonad [Value]
productions v = do
pss <- extensions v
mapM (combineDots v) pss