Please Explain

module Main where
import Base
import System

data Tree a = Node {rootLabel :: a, subForest :: [Tree a]} deriving Show

-- Pasted from the spec, with some regex substitutions.
primTypes =
  [ (0x7f,"null")
  , (0x7e,"bool")
  , (0x7d,"nat")
  , (0x7c,"int")
  , (0x7b,"nat8")
  , (0x7a,"nat16")
  , (0x79,"nat32")
  , (0x78,"nat64")
  , (0x77,"int8")
  , (0x76,"int16")
  , (0x75,"int32")
  , (0x74,"int64")
  , (0x73,"float32")
  , (0x72,"float64")
  , (0x71,"text")
  , (0x70,"reserved")
  , (0x6f,"empty")
  , (0x68,"principal")
  ]

-- Parser combinators.
data Lexer a = Lexer (String -> Either String (a, String))
instance Functor Lexer where fmap f (Lexer x) = Lexer $ fmap (first f) . x
instance Applicative Lexer where
  pure x = Lexer \inp -> Right (x, inp)
  f <*> x = Lexer \inp -> case lexer f inp of
    Left e -> Left e
    Right (fun, t) -> case lexer x t of
      Left e -> Left e
      Right (arg, u) -> Right (fun arg, u)
instance Monad Lexer where
  return = pure
  x >>= f = Lexer \inp -> case lexer x inp of
    Left e -> Left e
    Right (a, t) -> lexer (f a) t
instance Alternative Lexer where
  empty = Lexer \_ -> Left ""
  (<|>) x y = Lexer \inp -> either (const $ lexer y inp) Right $ lexer x inp

lexer (Lexer f) inp = f inp
sat f = Lexer \s -> case s of
  [] -> Left "EOF"
  h:t -> if f h then Right (h, t) else Left "unsat"
char c = sat (c ==)
anyChar = sat (const True)
bad s = Lexer $ const $ Left s

-- Parser.
isDigit c = '0' <= c && c <= '9'

leb128 = leb128With 0 1 id
leb128With n b f = do
  c <- anyChar
  let d = ord c
  if d <= 127
    then pure (n + b*d, f [c])
    else leb128With (n + b*(d - 128)) (b*128) (f . (c:))

sleb128 = leb128  -- TODO: Fix this!

magic = mapM id $ char <$> "DIDL"

typeStar = do
  (n, s) <- leb128
  Node s <$> replicateM n typeLone

typeLone = do
  c <- anyChar
  let t = ord c
  if t <= 127 then
    case t of
      0x6e -> Node [c] . (:[]) <$> typeLone
      0x6d -> Node [c] . (:[]) <$> typeLone
      0x6c -> Node [c] . (:[]) <$> fieldStar
      0x6b -> Node [c] . (:[]) <$> fieldStar
      0x6a -> do
        ins <- typeStar
        outs <- typeStar
        anns <- do
          (n, s) <- leb128
          as <- replicateM n anyChar
          pure $ Node s [Node as []]
        pure $ Node [c] [ins, outs, anns]
      _ -> pure $ Node [c] []
    else bad "want type opcode <= 127"

fieldStar = do
  (n, s) <- leb128
  Node s <$> replicateM n fieldLone

fieldLone = do
  (n, s) <- leb128
  Node s . (Node (show $ wordFromInt n) []:) . (:[]) <$> typeLone

readInt = foldl (\n c -> 10*n + ord c - 48) 0

value ts t = case getType t ts of
  Left e -> bad e
  Right (Node [c] kids) -> case ord c of
    0x7f -> pure $ Node "" []
    0x7e -> flip Node [] <$> replicateM 1 anyChar
    0x7d -> do
      (n, s) <- leb128
      pure $ Node s [Node (show n) []]
    0x7c -> do
      (n, s) <- sleb128
      pure $ Node s [Node (show n) []]
    0x71 -> do
      (n, s) <- leb128
      txt <- replicateM n anyChar
      pure $ Node s [Node txt []]
    0x70 -> pure $ Node "" []
    0x6e -> do
      c <- anyChar
      case ord c of
        0 -> pure $ Node [c] []
        1 -> Node [c] . (:[]) <$> value ts (head kids)
        _ -> bad "invalid opt"
    0x6d -> do
      (n, s) <- leb128
      Node s <$> replicateM n (value ts $ head kids)
    0x6c -> Node "" <$> mapM (value ts . (!!1) . subForest) (subForest $ head kids)
    0x6b -> do
      (n, s) <- leb128
      let vTypes = subForest (head kids)
      if n >= length vTypes then bad $ "bad index: " ++ show n else
        Node s . (Node (show n) []:) . (:[]) <$> value ts (subForest (vTypes!!n)!!1)
    0x68 -> do
      b <- anyChar
      if ord b == 0
       then pure $ Node [b] []
       else do
         (n, s) <- leb128
         txt <- replicateM n anyChar
         pure $ Node [b] [Node s [Node txt []]]
    _ -> case lookup (ord c) primTypes of
      Just name -> let b = readInt (filter isDigit name) `div` 8 in if b > 0
        then flip Node [] <$> replicateM b anyChar
        else bad $ "TODO: " ++ name
      _ -> bad $ "TODO: " ++ xxd [c]

getType t@(Node [c] kids) ts = if i < 0x68
  then if i < length ts then Right $ ts!!i else Left $ "bad index: " ++ show i
  else Right t
  where i = ord c

-- Explainer.
hexit n | n < 10 = chr $ n + ord '0'
        | True = chr $ n + ord 'a' - 10
hex2 n = hexit <$> [div n 16, mod n 16]
xxd ns = intercalate " " $ hex2 . ord <$> ns

data Line = Line { margin :: Int, lhs :: String, rhs :: String }
instance Show Line where
  show (Line m l r) = concat [replicate m ' ', xxd l, if null l then "" else ": ", r, "\n"]
indent = map \line -> line { margin = margin line + 2 }
bytes >-< desc = Line 0 bytes desc

explainStar idxF msgF kidder (Node s kids) = s >-< msgF (show $ length kids)
  : indent (zeroIndex idxF $ kidder <$> kids)

zeroIndex idxF xss = concat $ zipWith go [0..] xss where
  go n (line1:rest) = line1 { rhs = idxF (show n) ++ rhs line1 } : rest

explainType (Node [c] kids) = case lookup t primTypes of
  Nothing -> case t of
    0x6e -> [c] >-< "opt" : indent (explainType kid)
    0x6d -> [c] >-< "vec" : indent (explainType kid)
    0x6c -> (c:s) >-< ("record of size " ++ show (length grandkids))
      : indent (concat $ explainField <$> grandkids)
    0x6b -> (c:s) >-< ("variant of size " ++ show (length grandkids))
      : indent (concat $ explainField <$> grandkids)
    0x6a -> [c] >-< "function" : case kids of
      [Node insCount ins, Node outsCount outs, Node annsCount [Node anns []]] -> indent $ concat
        [ insCount >-< concat [show $ length ins, " inputs"] : (concatMap explainType ins)
        , outsCount >-< concat [show $ length outs, " outputs"] : (concatMap explainType outs)
        , [annsCount >-< concat [show $ length anns, " annotations: ", show $ ord <$> anns]]
        ]
    _ -> [[c] >-< ("type #" ++ show t)]
  Just name -> [[c] >-< name]
  where
  t = ord c
  kid@(Node s grandkids) = head kids

explainField (Node hash [Node n [], ty]) = hash >-< ("field with hash " ++ n)
  : indent (explainType ty)

chain lexFun s f = case lexer lexFun s of
  Left e -> ["" >-< ("ERROR: " ++ e)]
  Right (x, rest) -> f x rest

explainCandid s = chain magic s \x rest -> x >-< "magic header" : explainTypeList rest

explainTypeList s = chain typeStar s \typeList@(Node _ ts) rest ->
  explainStar (\idx -> concat ["[type #", idx, "] "]) ("type table of size "++) explainType typeList
  ++ explainArgList ts rest

explainArgList ts s = chain typeStar s \argList@(Node _ as) rest ->
  explainStar (\idx -> concat ["[arg #", idx, "] "]) ("arg count of "++) explainType argList
  ++ explainValues ts as rest

explainValues ts as s = chain (mapM (value ts) as) s \vs rest ->
  concat (zipWith (:) argHds (zipWith (explainValue ts) as vs))
  ++ if rest /= "" then [rest >-< "TRAILING BYTES"] else []
  where argHds = map (\i -> "" >-< (concat ["arg #", show i, ":"])) [0..]

explainValue ts a (Node v kids) = case getType a ts of
  Left e -> error "unreachable"
  Right (Node [c] tKids) -> case ord c of
    0x7f -> ["" >-< "(null)"]
    0x71 -> let [Node txt []] = kids in v >-< ("utf8 text of length " ++ show (length txt)) : indent [txt >-< show txt]
    0x70 -> ["" >-< "(reserved)"]
    0x6e -> case ord $ head v of
      0 -> [v >-< "Nothing"]
      1 -> v >-< "Just" : indent (explainValue ts (head tKids) (head kids))
    0x6d -> v >-< ("vec of length " ++ show (length kids)) : indent (concatMap (explainValue ts $ head tKids) kids)
    0x6c -> "" >-< "record:" : indent (concat $ zipWith (explainValue ts) ((!!1) . subForest <$> subForest (head tKids)) kids)
    0x6b -> v >-< ("variant field " ++ show n) : indent (explainValue ts (subForest (subForest (head tKids)!!n)!!1) $ kids!!1) where n = readInt $ rootLabel $ head kids
    0x68 -> case ord $ head v of
      0 -> [v >-< "principal ref"]
      1 -> let [Node s [Node txt []]] = kids in (v ++ s) >-< ("principal of length " ++ show (length txt)) : indent [txt >-< ""]
    _ -> case lookup (ord c) primTypes of
      Just name -> [v >-< name]
      _ -> [[c] >-< "TODO"]

unhexit c
  | isDigit c            = Right $ ord c - ord '0'
  | 'a' <= c && c <= 'f' = Right $ ord c - ord 'a' + 10
  | 'A' <= c && c <= 'F' = Right $ ord c - ord 'A' + 10
  | True = Left "bad hex digit"
unxxd "" = Right ""
unxxd (c:d:rest) = do
  h1 <- unhexit c
  h0 <- unhexit d
  (:) (chr $ h1*16 + h0) <$> unxxd rest
unxxd s = Left $ "odd byte " ++ s

pleaseExplain = either ((:[]) . ("" >-<) . ("Error: "++)) explainCandid . unxxd . filter (not . (`elem` " \n"))

foreign export ccall "canister_query go" main
foreign export ccall "go" main
main = interact $ concatMap show . pleaseExplain

{-# LANGUAGE BlockArguments #-}
import Control.Applicative
import Control.Arrow
import Data.List
import Data.Char