content: {-# LANGUAGE ViewPatterns #-}
  
  -- | a dynamic value type for imperative or functional interpretation
  -- of ABC (but not so great for reactive). By 'dynamic' I mean that
  -- values here are unityped (just 'V') and operations handle cases.
  --
  -- I've had difficulty expressing ABC's ad-hoc structural types
  -- within Haskell's type system, so it is likely we'll be using
  -- dynamic values indefinitely (until we bootstrap, anyway).
  module ABC.Imperative.Value
      ( V(..), Prog, Block(..)
      , copyable, droppable
      , valToText, textToVal
      , valToBinary, binaryToVal
      , listToVal, valToList
      , simplEQ, assertEQ
      , isSum, isInL, isInR
      ) where
  
  import Control.Applicative
  import Control.Monad ((>=>))
  import Data.Word
  import Data.Ord
  import Data.Monoid
  import Data.Ratio
  import qualified Data.List as L
  import qualified Data.Sequence as S
  import qualified Data.Foldable as S
  import qualified Data.Decimal  as Dec
  import qualified Data.ByteString as B
  
  import ABC.Operators
  import ABC.Simplify
  import ABC.Quote
  import qualified ABC.Base16 as B16
  
  -- | a value in imperative context cx
  data V cx
      = N {-# UNPACK #-} !Rational -- numbers
      | P (V cx) (V cx) -- product
      | R (V cx) -- in right
      | L (V cx) -- in left
      | U -- unit
      | B (Block cx)  -- block
      | S String (V cx) -- sealed value
      deriving (Eq, Ord)
  
  -- NOTE: Sealed values can also be used as a special class of token
  -- for value encapsulation. Essentially, the sealer token can support
  -- an 'unforgeable' lookup when used in an invocation. It could also
  -- be used together with the value, of course.
  --
  -- Different uses of sealers may be distinguished by a prefix on the
  -- sealer token. For example, discretionary sealers start with ':'.
  -- This prefix is not stripped.
  
  -- | an imperative program with context 'cx' 
  -- 'cx' should be Monadic and Applicative
  type Prog cx = (V cx) -> cx (V cx)
  
  -- | A block is simply a finite sequence of ABC code. However, for
  -- performance reasons, the block includes a 'b_prog' field that
  -- should be equivalent to the code.
  --
  -- Unfortunately, this AO library does not enforce equivalence. A
  -- client must be careful and disciplined when working with the 
  -- b_prog field, otherwise the program may behave unexpectedly in
  -- contexts such as JIT or distribution.
  --
  data Block cx = Block
      { b_aff  :: Bool     -- ^ is this block affine (no copy)?
      , b_rel  :: Bool     -- ^ is this block relevant (no drop)?
      , b_code :: S.Seq Op -- ^ raw operations, in sequence for cheap compose.
      , b_prog :: Prog cx  -- ^ be careful! must behave equivalently to b_code.
      } 
  
  -- structural equality for blocks
  -- implies behavioral equality (but not vice versa)
  instance Eq (Block cx) where
      (==) b1 b2 = (b_code b1 == b_code b2)
                && (b_rel b1 == b_rel b2)
                && (b_aff b1 == b_aff b2)
  
  -- structural comparison for blocks... 
  -- not very semantic, but useful for memoization, maps, etc. 
  instance Ord (Block cx) where
      compare b1 b2 = 
          comparing b_code b1 b2 `mappend`
          comparing b_rel  b1 b2 `mappend`
          comparing b_aff  b1 b2
  
  instance (Monad cx) => Monoid (Block cx) where
      mempty = Block { b_aff = False, b_rel = False, b_code = S.empty, b_prog = return }
      mappend xy yz = xz where
          xz = Block { b_aff = aff', b_rel = rel', b_code = code', b_prog = prog' }
          aff' = b_aff xy || b_aff yz
          rel' = b_rel xy || b_rel yz
          code' = b_code xy S.>< b_code yz
          prog' = b_prog xy >=> b_prog yz
  
  valToList :: (V cx -> Maybe a) -> V cx -> Maybe [a]
  valToList f (L (P a as)) = (:) <$> f a <*> valToList f as
  valToList _ (R U) = Just []
  valToList _ _ = Nothing
  
  listToVal :: (a -> V cx) -> [a] -> V cx
  listToVal f (a:as) = (L (P (f a) (listToVal f as)))
  listToVal _ [] = (R U)
  
  valToText :: V cx -> Maybe String
  valToText = valToList valToChar
  
  textToVal :: String -> V cx
  textToVal = listToVal (N . fromIntegral . fromEnum)
  
  valToChar :: V cx -> Maybe Char
  valToChar (N r) | (validChar r) = (Just . toEnum . fromInteger . numerator) r
  valToChar _ = Nothing
  
  validChar :: Rational -> Bool
  validChar r =
      let n = numerator r in
      let d = denominator r in
      (1 == d) && (0 <= n) && (n <= 0x10ffff)
  
  -- | Convert a bytestring to an ABC.Base16 text.
  binaryToVal :: B.ByteString -> V cx
  binaryToVal = listToVal (N . fromIntegral) . B16.encode . B.unpack 
  
  -- | Convert an ABC.Base16 text into a binary.
  valToBinary :: V cx -> Maybe B.ByteString
  valToBinary (valToList vByte -> Just allBytes) = 
      let (goodBytes,badBytes) = B16.decode allBytes in
      if null badBytes then Just (B.pack goodBytes)
                       else Nothing
  valToBinary _ = Nothing
  
  vByte :: V cx -> Maybe Word8
  vByte (N r) | ok = Just (fromIntegral n) where
      d = denominator r
      n = numerator r
      ok = (1 == d) && (0x00 <= n) && (n <= 0xFF)
  vByte _ = Nothing
  
  
  instance Show (V cx) where
      showsPrec _ (N r) = showNumber r
      showsPrec _ (L U) = showString "false"
      showsPrec _ (R U) = showString "true"
      showsPrec _ U = showString "unit"
      showsPrec _ (valToText -> Just txt) | isShortText txt = shows txt
                                          | otherwise = shows (TL txt)
      showsPrec _ (valToList pure -> Just vs) = showString "List " . shows vs
      showsPrec _ (P a b) = showChar '(' . shows a . showChar '*' . shows b . showChar ')'
      showsPrec _ (L a) = showChar '(' . shows a . showString "+_)"
      showsPrec _ (R b) = showString "(_+" . shows b . showChar ')'
      showsPrec _ b@(B _) = (shows . quote) b -- show as block literal + kf
      showsPrec _ (S seal v) = shows v . shows tok where
          tok = Tok (seal)
  
  -- true for relatively short, single line texts
  isShortText :: String -> Bool
  isShortText txt = short && oneLine where
      maxLen = 24
      (hd,tl) = L.splitAt maxLen txt
      short = null tl
      oneLine = L.notElem '\n' hd
  
  -- show number as exact decimal or as fractional
  showNumber :: Rational -> ShowS
  -- showNumber r | (1 == denominator r) = shows (numerator r)
  showNumber (toDecimal -> Just dec) = shows dec
  showNumber r = shows (numerator r) . showChar '/' . shows (denominator r)
  
  toDecimal :: Rational -> Maybe Dec.Decimal
  toDecimal = e2mb . Dec.eitherFromRational where
      e2mb = either (const Nothing) Just
  
  instance Quotable (V cx) where
      quotes (valToText -> Just txt) = quotes (TL txt)
      quotes (N r) = quotes r
      quotes (P a b) = quotes a . quotes b . quotes Op_w . quotes Op_l
      quotes (R b) = quotes b . qinR where
          qinR = concatQuotes [Op_V, Op_V, Op_R, Op_W, Op_L, Op_C]
      quotes (L a) = quotes a . qinL where
          qinL = quotes Op_V
      quotes U = quotes Op_v . qswap where
          qswap = concatQuotes [Op_v, Op_w, Op_r, Op_l, Op_c]
      quotes (B b) = code b . k . f where
          code = quotes . BL . S.toList . b_code 
          k = if (b_rel b) then quotes Op_rel else id
          f = if (b_aff b) then quotes Op_aff else id
      quotes (S s v) = quotes v . quotes sealer where
          sealer = Tok s
  
  copyable :: V cx -> Bool
  copyable (N _) = True
  copyable (P a b) = copyable a && copyable b
  copyable (R b) = copyable b
  copyable (L a) = copyable a
  copyable U = True
  copyable (B b) = not (b_aff b)
  copyable (S _ v) = copyable v
  
  droppable :: V cx -> Bool
  droppable (N _) = True
  droppable (P a b) = droppable a && droppable b
  droppable (R b) = droppable b
  droppable (L a) = droppable a
  droppable U = True
  droppable (B b) = not (b_rel b)
  droppable (S _ v) = droppable v
  
  -- default impl for `{&≡}` annotation
  assertEQ :: (Monad cx) => Prog cx
  assertEQ v@(P a (P a' _e)) | simplEQ a a' = return v
  assertEQ v = fail $ "{&≡} (assertEQ) @ " ++ show v
  
  -- block-simplifying equality test
  simplEQ :: V a -> V b -> Bool
  simplEQ (N a) (N b) = (a == b)
  simplEQ (P a1 a2) (P b1 b2) = simplEQ a1 b1 && simplEQ a2 b2
  simplEQ (L a) (L b) = (simplEQ a b)
  simplEQ (R a) (R b) = (simplEQ a b)
  simplEQ U U = True
  simplEQ (B a) (B b) =
      -- compare simplified code
      let codeA = simplify (S.toList (b_code a)) in
      let codeB = simplify (S.toList (b_code b)) in
      (codeA == codeB) &&
      (b_aff a == b_aff b) &&
      (b_rel a == b_rel b)
  simplEQ (S sa va) (S sb vb) = (sa == sb) && (simplEQ va vb)
  simplEQ _ _ = False
  
  -- to support code generation, I need a lot of utility functions.
  isSum, isInL, isInR :: V a -> Bool
  isSum (L _a) = True
  isSum (R _b) = True
  isSum _ = False
  isInL (L _a) = True
  isInL _ = False
  isInR (R _b) = True
  isInR _ = False
  
  