module DSL.Util where

import Data.Map.Strict (empty, member, insert, toList)

import DSL.Types

tAny :: TypeCheck
tAny = const True

tBool :: TypeCheck
tBool (StackBool _) = True
tBool _             = False

tInt :: TypeCheck
tInt (StackInt _) = True
tInt _            = False

tString :: TypeCheck
tString (StackString _) = True
tString _               = False

runChecks :: [TypeCheck] -> Stack -> Maybe String
runChecks fs s
  | length fs > length s        = Just "stack underflow"
  | not (and $ zipWith id fs s) = Just "type mis-match"
  | otherwise                   = Nothing

hcf :: Machine -> String -> IO Machine
hcf m msg = putStrLn msg >> return m{ ok=False }

appendProcTable :: [ProcSpec] -> ProcTable -> Maybe ProcTable
appendProcTable x y = go x
  where
    go []           = Just y
    go ((n, bs):ps) = go ps >>= f
      where
        f acc
          | member n acc = Nothing
          | otherwise    = Just $ insert n bs acc

mergeProcTables :: ProcTable -> ProcTable -> Maybe ProcTable
mergeProcTables x = appendProcTable $ toList x

buildProcTable :: [ProcSpec] -> Maybe ProcTable
buildProcTable ps = appendProcTable ps empty

unreachable :: a
unreachable = error "this branch should be unreachable"