quox/tests/TypingImpls.idr

module TypingImpls

import TAP
import public Quox.Typing
import public Quox.Pretty
import public TermImpls

import Derive.Prelude
%language ElabReflection


%runElab derive "Reduce.WhnfError" [Show]

%runElab deriveIndexed "DimEq" [Show]

export %hint
showTyContext : (PrettyHL q, Show q) => Show (TyContext q d n)
showTyContext = deriveShow

export %hint
showEqContext : (PrettyHL q, Show q) => Show (EqContext q n)
showEqContext = deriveShow

export %hint
showTypingError : (PrettyHL q, Show q) => Show (Error q)
showTypingError = deriveShow

export
ToInfo WhnfError where
  toInfo (MissingEnumArm t ts) =
    [("type", "MissingEnumArm"),
     ("tag", show t),
     ("list", show ts)]

export
PrettyHL q => ToInfo (Error q) where
  toInfo (NotInScope x) =
    [("type", "NotInScope"),
     ("name", show x)]
  toInfo (ExpectedTYPE _ t) =
    [("type", "ExpectedTYPE"),
     ("got",  prettyStr True t)]
  toInfo (ExpectedPi _ t) =
    [("type", "ExpectedPi"),
     ("got",  prettyStr True t)]
  toInfo (ExpectedSig _ t) =
    [("type", "ExpectedSig"),
     ("got",  prettyStr True t)]
  toInfo (ExpectedEnum _ t) =
    [("type", "ExpectedEnum"),
     ("got",  prettyStr True t)]
  toInfo (ExpectedEq _ t) =
    [("type", "ExpectedEq"),
     ("got",  prettyStr True t)]
  toInfo (BadUniverse k l) =
    [("type", "BadUniverse"),
     ("low",  show k),
     ("high", show l)]
  toInfo (TagNotIn t ts) =
    [("type", "TagNotIn"),
     ("tag", show t),
     ("set", show $ SortedSet.toList ts)]
  toInfo (BadCaseQtys _ qouts) =
    ("type", "BadCaseQtys") ::
    [(show i, prettyStr True q) | (i, _, _, q) <- zip [1 .. length qouts] qouts]

  toInfo (ClashT _ mode ty s t) =
    [("type",  "ClashT"),
     ("mode",  show mode),
     ("ty",    prettyStr True ty),
     ("left",  prettyStr True s),
     ("right", prettyStr True t)]
  toInfo (ClashTy _ mode s t) =
    [("type",  "ClashTy"),
     ("mode",  show mode),
     ("left",  prettyStr True s),
     ("right", prettyStr True t)]
  toInfo (ClashE _ mode e f) =
    [("type",  "ClashE"),
     ("mode",  show mode),
     ("left",  prettyStr True e),
     ("right", prettyStr True f)]
  toInfo (ClashU mode k l) =
    [("type",  "ClashU"),
     ("mode",  show mode),
     ("left",  show k),
     ("right", show l)]
  toInfo (ClashQ pi rh) =
    [("type",  "ClashQ"),
     ("left",  prettyStr True pi),
     ("right", prettyStr True rh)]
  toInfo (NotType _ ty) =
    [("type", "NotType"),
     ("got",  prettyStr True ty)]
  toInfo (WrongType _ ty s t) =
    [("type",  "WrongType"),
     ("ty",    prettyStr True ty),
     ("left",  prettyStr True s),
     ("right", prettyStr True t)]

  -- [todo] add nested yamls to TAP and include context here
  toInfo (WhileChecking   _ _ _ _   err) = toInfo err
  toInfo (WhileCheckingTy _ _ _     err) = toInfo err
  toInfo (WhileInferring  _ _ _     err) = toInfo err
  toInfo (WhileComparingT _ _ _ _ _ err) = toInfo err
  toInfo (WhileComparingE _ _ _ _   err) = toInfo err

  toInfo (WhnfError err) = toInfo err