-- expressions

data SourcePos = SP String Nat Nat
Show SourcePos where
  show (SP x k j) = x ++ ":" ++ (show k) ++ "," ++ (show j)

one : Nat
one = unsafePerformIO $ do putStrLn "ALEX"
                           pure 3

data Name = Name' String

Show Name where
  show (Name' x) = x

Eq Name where
  (==) (Name' x) (Name' y) = x == y

data Expr
  = Var Name   -- x
  | Pi Name Expr Expr -- (Π ((x A)) B)
  | Lambda Name Expr -- (λ (x) b)
  | App Expr Expr -- (rator rand)
  | Sigma Name Expr Expr -- (Σ ((x A)) D)
  | Cons Expr Expr -- (cons a d)
  | Car Expr -- (car e)
  | Cdr Expr -- (cdr e)
  | Nat -- Nat
  | Zero -- zero
  | Add1 Expr -- (add1 e)
  | IndNat Expr Expr Expr Expr -- (ind-nat tgt mot base step)
  | Equal Expr Expr Expr -- (= A from to)
  | Same -- Same
  | Replace Expr Expr Expr -- (replace tgt mot base)
  | Trivial -- Trivial
  | Sole -- sole
  | Absurd -- Absurd
  | IndAbsurd Expr Expr -- (ind-Absurd tgt mot)
  | Atom -- Atom
  | Tick String -- 'a
  | U -- U
  | The Expr Expr -- (the t e)
  | SrcPos SourcePos Expr

Show Expr where
Eq Expr where

Namespace : Type
Namespace = List (Name, Integer)
%name Namespace ns1, ns2, ns3

-- alpha equivalence
aEquivHelper : (i : Integer) ->
               Namespace -> Expr ->
               Namespace -> Expr ->
               Bool
aEquivHelper i ns1 (Var x) ns2 (Var y) =
  case (lookup x ns1, lookup y ns2) of
       (Nothing, Nothing) => x == y
       (Just j, Just k) => i == j
       _ => False

aEquivHelper i ns1 (Pi x a1 r1) ns2 (Pi y a2 r2) =
  aEquivHelper i ns1 a1 ns2 a2 &&
  aEquivHelper (i+1) ((x, i) :: ns1) r1 ((y, i) :: ns2) r2

aEquivHelper i ns1 (Lambda x body1) ns2 (Lambda y body2) =
  aEquivHelper (i+1) ((x, i) :: ns1) body1 ((y, i) :: ns2) body2

aEquivHelper i ns1 (App rator1 rand1) ns2 (App rator2 rand2) =
  aEquivHelper i ns1 rator1 ns2 rator2 &&
  aEquivHelper i ns1 rand1 ns2 rand2

aEquivHelper i ns1 (Sigma x a1 d1) ns2 (Sigma y a2 d2) =
  aEquivHelper i ns1 a1 ns2 a2 &&
  aEquivHelper (i+1) ((x, i) :: ns1) d1 ((y, i) :: ns2) d2

aEquivHelper i ns1 (Cons car1 cdr1) ns2 (Cons car2 cdr2) =
  aEquivHelper i ns1 car1 ns2 car2 &&
  aEquivHelper i ns1 cdr1 ns2 cdr2

aEquivHelper i ns1 (Car pair1) ns2 (Car pair2) =
  aEquivHelper i ns1 pair1 ns2 pair2
aEquivHelper i ns1 (Cdr pair1) ns2 (Cdr pair2) =
  aEquivHelper i ns1 pair1 ns2 pair2

aEquivHelper _ _ Nat _ Nat = True
aEquivHelper _ _ Zero _ Zero = True

aEquivHelper i ns1 (Add1 e1) ns2 (Add1 e2) =
  aEquivHelper i ns1 e1 ns2 e2

aEquivHelper i ns1 (IndNat tgt1 mot1 base1 step1) ns2 (IndNat tgt2 mot2 base2 step2) =
  aEquivHelper i ns1 tgt1 ns2 tgt2 &&
  aEquivHelper i ns1 mot1 ns2 mot2 &&
  aEquivHelper i ns1 base1 ns2 base2 &&
  aEquivHelper i ns1 step1 ns2 step2

aEquivHelper i ns1 (Equal ty1 from1 to1) ns2 (Equal ty2 from2 to2) =
  aEquivHelper i ns1 ty1 ns2 ty2 &&
  aEquivHelper i ns1 from1 ns2 from2 &&
  aEquivHelper i ns1 to1 ns2 to2

aEquivHelper _ _ Same _ Same = True

aEquivHelper i ns1 (Replace tgt1 mot1 base1) ns2 (Replace tgt2 mot2 base2) =
  aEquivHelper i ns1 tgt1 ns2 tgt2 &&
  aEquivHelper i ns1 mot1 ns2 mot2 &&
  aEquivHelper i ns1 base1 ns2 base2

aEquivHelper _ _ Trivial _ Trivial = True
aEquivHelper _ _ Sole _ Sole = True
aEquivHelper _ _ Absurd _ Absurd = True
aEquivHelper _ _ Atom _ Atom = True
aEquivHelper _ _ U _ Atom = True

aEquivHelper i ns1 (IndAbsurd tgt1 mot1) ns2 (IndAbsurd tgt2 mot2) =
  aEquivHelper i ns1 tgt1 ns2 tgt2 &&
  aEquivHelper i ns1 mot1 ns2 mot2

aEquivHelper i ns1 (Tick a1) ns2 (Tick a2) = a1 == a2

aEquivHelper _ _ (The Absurd _) _ (The Absurd _) = True
aEquivHelper i ns1 (The t1 e1) ns2 (The t2 e2) =
  aEquivHelper i ns1 t1 ns2 t2 &&
  aEquivHelper i ns1 e1 ns2 e2

aEquivHelper i ns1 (SrcPos str1 e1) ns2 (SrcPos str2 e2) =
  aEquivHelper i ns1 e1 ns2 e2

aEquivHelper _ _ _ _ _ = False

aEquiv : Expr -> Expr -> Bool
aEquiv e1 e2 = aEquivHelper 0 [] e1 [] e2

mutual
  data Neutral
    = NVar Name
    | NApp Neutral Normal
    | NCar Neutral
    | NCdr Neutral
    | NIndNat Neutral Normal Normal Normal
    | NReplace Neutral Normal Normal
    | NIndAbsurd Neutral Normal

  data Normal = Normal' Ty Value

  Env : Type -- Now a type alias
  Env = List (Name,Value)
  %name Env env, env1, env2

  record Closure where
    constructor MkClosure
    closureEnv : Env
    closureName : Name
    closureBody : Expr

  Ty : Type
  Ty = Value

  -- Values
  data Value
    = VPi Ty Closure
    | VLambda Closure
    | VSigma Ty Closure
    | VPair Value Value
    | VNat
    | VZero
    | VAdd1 Value
    | VEq Ty Value Value
    | VSame
    | VTrivial
    | VSole
    | VAbsurd
    | VAtom
    | VTick String
    | VU
    | VNeutral Ty Neutral

extendEnv : Env -> Name -> Value -> Env
extendEnv env x v = ((x, v) :: env)

-- definitions and dependent types
data CtxEntry = Def Ty Value | IsA Ty

Ctx : Type
Ctx = List (Name, CtxEntry)
%name Ctx ctx, ctx1, ctx2

initCtx : Ctx
initCtx = []

ctxNames : Ctx -> List Name
ctxNames ctx = map fst ctx

extendCtx : Ctx -> Name -> Ty -> Ctx
extendCtx ctx x t = (x, (IsA t)) :: ctx

define : Ctx -> Name -> Ty -> Value -> Ctx
define ctx x t v = (x, Def t v) :: ctx

mkEnv : Ctx -> Env
mkEnv [] = []
mkEnv ((x, e) :: ctx) =
  let env = mkEnv ctx in
  (case e of
        (Def _ v) => (x, v) :: env
        (IsA t) => let v = VNeutral t (NVar x) in
                       (x, v) :: env)
-- evaluator
mutual
  data Error
    = MissingValue String
    | CarError
    | CdrError
    | ApplyError
    | IndAbsurdError
    | DoReplaceError
    | DoIndNatError
    | ReadBackTypedError
    | ErrorMessage String

  partial
  evalClosure : Closure -> Value -> Either Error Value
  evalClosure (MkClosure env x e) v =
    eval (extendEnv env x v) e

  evalVar : Env -> Name -> Either Error Value
  evalVar [] x = Left (MissingValue (show x ++ " not found in env"))
  evalVar ((y, v) :: env) x = case x == y of
                                    True => Right v
                                    False => evalVar env x

  partial
  eval : Env -> Expr -> Either Error Value
  eval env (Var x) = evalVar env x
  eval env (Pi x dom ran) =
    do dom' <- eval env dom
       Right (VPi dom' (MkClosure env x ran))
  eval env (Lambda x body) = Right (VLambda (MkClosure env x body))
  eval env (App rator rand) =
    do rator' <- eval env rator
       rand' <- eval env rand
       doApply rator' rand'
  eval env (Sigma x carType cdrType) =
    do carType' <- eval env carType
       Right (VSigma carType' (MkClosure env x cdrType))
  eval env (Cons a d) =
    do a' <- eval env a
       d' <- eval env d
       Right (VPair a' d')
  eval env (Car e) =
    do e' <- eval env e
       doCar e'
  eval env (Cdr e) =
    do e' <- eval env e
       doCdr e'
  eval env Nat = Right VNat
  eval env Zero = Right VZero
  eval env (Add1 e) =
    do e' <- eval env e
       Right (VAdd1 e')
  eval env (IndNat tgt mot base step) =
    do tgt' <- eval env tgt
       mot' <- eval env mot
       base' <- eval env base
       step' <- eval env step
       doIndNat tgt' mot' base' step'
  eval env (Equal ty from to) =
    do ty' <- eval env ty
       from' <- eval env from
       to' <- eval env to
       Right (VEq ty' from' to')
  eval env Same = Right VSame
  eval env (Replace tgt mot base) =
    do tgt' <- eval env tgt
       mot' <- eval env mot
       base' <- eval env base
       doReplace tgt' mot' base'
  eval env Trivial = Right VTrivial
  eval env Sole = Right VSole
  eval env Absurd = Right VAbsurd
  eval env (IndAbsurd tgt mot) =
    do tgt' <- eval env tgt
       mot' <- eval env mot
       doIndAbsurd tgt' mot'
  eval env Atom = Right VAtom
  eval env (Tick x) = Right (VTick x)
  eval env U = Right VU
  eval env (The ty e) = eval env e
  eval env (SrcPos _ e) = eval env e

  -- eliminators
  doCar : Value -> Either Error Value
  doCar (VPair v1 v2) = Right v1
  doCar (VNeutral (VSigma aT dT) neu) =
    Right (VNeutral aT (NCar neu))
  doCar _ = Left CarError

  partial
  doCdr : Value -> Either Error Value
  doCdr (VPair v1 v2) = Right v2
  doCdr v@(VNeutral (VSigma aT dT) neu) =
    do v' <- doCar v
       cl' <- evalClosure dT v'
       Right (VNeutral cl' (NCdr neu))
  doCdr _ = Left CdrError

  partial
  doApply : Value -> Value -> Either Error Value
  doApply (VLambda closure) arg =
    evalClosure closure arg
  doApply (VNeutral (VPi dom ran) neu) arg =
    do arg' <- evalClosure ran arg
       Right (VNeutral arg' (NApp neu (Normal' dom arg)))
  doApply _ _ = Left ApplyError

  doIndAbsurd : Value -> Value -> Either Error Value
  doIndAbsurd (VNeutral VAbsurd neu) mot =
    Right (VNeutral mot (NIndAbsurd neu (Normal' VU mot)))
  doIndAbsurd _ _ = Left IndAbsurdError

  partial
  doReplace : Value -> Value -> Value -> Either Error Value
  doReplace VSame mot base =
    Right base
  doReplace (VNeutral (VEq ty from to) neu) mot base =
    do v' <- doApply mot to
       baseT' <- doApply mot from
       Right (VNeutral v'
         (NReplace neu (Normal' motT mot) (Normal' baseT' base)))
    where
      motT = VPi ty (MkClosure ([]) (Name' "x") U)
  doReplace _ _ _ = Left DoReplaceError

  partial
  indNatStepType : Value -> Either Error Value
  indNatStepType mot =
    eval [(Name' "mot", mot)]
      (Pi (Name' "n-1") Nat
        (Pi (Name' "almost") (App (Var (Name' "mot")) (Var (Name' "n-1")))
          (App (Var (Name' "mot"))
            (Add1 (Var (Name' "n-1"))))))

  partial
  doIndNat : Value -> Value -> Value -> Value -> Either Error Value
  doIndNat VZero mot base step =
    Right base
  doIndNat (VAdd1 v) mot base step =
    do rator' <- (doApply step v)
       rand' <- (doIndNat v mot base step)
       doApply rator' rand'
  doIndNat tgt@(VNeutral VNat neu) mot base step =
    do a' <- (doApply mot tgt)
       b' <- (doApply mot VZero)
       c' <- (indNatStepType mot)
       Right (VNeutral a' (NIndNat neu
         (Normal' (VPi VNat (MkClosure [] (Name' "k") U)) mot) (Normal' b' base)
           (Normal' c' step)))
  doIndNat _ _ _ _ = Left DoIndNatError

-- fresh names

nextName : Name -> Name
nextName (Name' x) = Name' ((show x) ++ "'")

-- could possibly fail for a list like [n', n'', n']
freshen : List Name -> Name -> Name
freshen [] n = n
freshen (x :: used) n = case x == n of
                             False => freshen used n
                             True => freshen used (nextName n)

-- reading back
mutual
  partial
  readBackNeutral : Ctx -> Neutral -> Either Error Expr
  readBackNeutral ctx (NVar x) = Right (Var x)
  readBackNeutral ctx (NApp neu arg) =
    do neu' <- readBackNeutral ctx neu
       arg' <- readBackNormal ctx arg
       Right (App neu' arg')
  readBackNeutral ctx (NCar neu) =
    do car <- readBackNeutral ctx neu
       Right (Car car)
  readBackNeutral ctx (NCdr neu) =
    do cdr <- readBackNeutral ctx neu
       Right (Cdr cdr)
  readBackNeutral ctx (NIndNat neu mot base step) =
    do neu' <- readBackNeutral ctx neu
       mot' <- readBackNormal ctx mot
       base' <- readBackNormal ctx base
       step' <- readBackNormal ctx step
       Right (IndNat neu' mot' base' step')
  readBackNeutral ctx (NReplace neu mot base) =
    do neu' <- readBackNeutral ctx neu
       mot' <- readBackNormal ctx mot
       base' <- readBackNormal ctx base
       Right (Replace neu' mot' base')
  readBackNeutral ctx (NIndAbsurd neu mot) =
    do neu' <- readBackNeutral ctx neu
       mot' <- readBackNormal ctx mot
       Right (IndAbsurd (The Absurd neu') mot')

  partial
  readBackTyped : Ctx -> Ty -> Value -> Either Error Expr
  readBackTyped ctx VNat VZero = Right Zero
  readBackTyped ctx VNat (VAdd1 v) =
    do n <- (readBackTyped ctx VNat v)
       Right (Add1 n)
  readBackTyped ctx (VPi dom ran) fun =
    let x = freshen (ctxNames ctx) (closureName ran)
        xVal = VNeutral dom (NVar x)
        ctx' = extendCtx ctx x dom in
    do ty' <- evalClosure ran xVal
       v' <- doApply fun xVal
       body <- readBackTyped ctx' ty' ty'
       Right (Lambda x body)
  readBackTyped ctx (VSigma aT dT) pair =
    do carVal <- doCar pair
       car <- readBackTyped ctx aT carVal
       cdrT <- evalClosure dT carVal
       cdrVal <- doCdr pair
       cdr <- readBackTyped ctx cdrT cdrVal
       Right (Cons car cdr)
  readBackTyped ctx VAbsurd (VNeutral VAbsurd neu) =
    do a <- readBackNeutral ctx neu
       Right (The Absurd a)
  readBackTyped ctx (VEq _ _ _) VSame = Right Same
  readBackTyped ctx VAtom (VTick x) = Right (Tick x)
  readBackTyped ctx VU VNat = Right Nat
  readBackTyped ctx VU VAtom = Right Atom
  readBackTyped ctx VU VTrivial = Right Trivial
  readBackTyped ctx VU VAbsurd = Right Absurd
  readBackTyped ctx VU (VEq t from to) =
    do a <- readBackTyped ctx VU t
       b <- readBackTyped ctx t from
       c <- readBackTyped ctx t to
       Right (Equal a b c)
  readBackTyped ctx VU (VSigma aT dT) =
    let x = freshen (ctxNames ctx) (closureName dT) in
        do a <- readBackTyped ctx VU aT
           body <- evalClosure dT (VNeutral aT (NVar x))
           d <- readBackTyped (extendCtx ctx x aT) VU body
           Right (Sigma x a d)
  readBackTyped ctx VU (VPi aT bT) =
    let x = freshen (ctxNames ctx) (closureName bT) in
        do a <- readBackTyped ctx VU aT
           body <- evalClosure bT (VNeutral aT (NVar x))
           b <- readBackTyped (extendCtx ctx x aT) VU body
           Right (Pi x a b)
  readBackTyped ctx VU VU = Right U
  readBackTyped ctx t (VNeutral t' neu) = readBackNeutral ctx neu
  readBackTyped _ otherT otherE = Left ReadBackTypedError

  partial
  readBackNormal : Ctx -> Normal -> Either Error Expr
  readBackNormal ctx (Normal' t v) = readBackTyped ctx t v

-- helpers
lookupType : Ctx -> Name -> Either Error Ty -- didn't use message type
lookupType [] x = Left (ErrorMessage "unbound variable: ") -- TODO ++ show x
lookupType ((y, e) :: ctx) x =
  (case x == y of
        False => lookupType ctx x
        True => (case e of
                      (Def t _) => Right t
                      (IsA t) => Right t))

unexpected : Ctx -> String -> Value -> Either Error a

isPi : Ctx -> Value -> Either Error (Ty, Closure)
isPi _ (VPi a b) = Right (a, b)
isPi ctx other = unexpected ctx "Not a Pi type" other

isSigma : Ctx -> Value -> Either Error (Ty, Closure)
isSigma _ (VSigma a b) = Right (a, b)
isSigma ctx other = unexpected ctx "Not a Sigma type" other

isNat : Ctx -> Value -> Either Error ()
isNat _ VNat = Right ()
isNat ctx other = unexpected ctx "Not Nat" other

isEqual : Ctx -> Value -> Either Error (Ty, Value, Value)
isEqual _ (VEq ty from to) = Right (ty, from, to)
isEqual ctx other = unexpected ctx "Not an equality type" other

isAbsurd : Ctx -> Value -> Either Error ()
isAbsurd _ VAbsurd = Right ()
isAbsurd ctx other = unexpected ctx "Not Absurd: " other

isTrivial : Ctx -> Value -> Either Error ()
isTrivial _ VTrivial = Right ()
isTrivial ctx other = unexpected ctx "Not Trivial" other

isAtom : Ctx -> Value -> Either Error ()
isAtom _ VAtom = Right ()
isAtom ctx other = unexpected ctx "Not Atom" other

-- checking/synthesis
mutual
  partial
  check : Ctx -> Expr -> Ty -> Either Error ()
  check ctx (Lambda x body) t = ?check_rhs_3
  check ctx (Cons a d) t = ?check_rhs_6
  check ctx Zero t = isNat ctx t
  check ctx (Add1 n) t = do
    isNat ctx t
    check ctx n VNat
  check ctx Same t = do
    (t, from, to) <- isEqual ctx t
    convert ctx t from to
  check ctx Sole t = isTrivial ctx t
  check ctx (Tick x) t = isAtom ctx t
  check ctx other t = do
    t' <- synth ctx other
    convert ctx VU t' t

  convert : Ctx -> Ty -> Value -> Value -> Either Error ()

  partial
  synth : Ctx -> Expr -> Either Error Ty
  synth ctx (Var x) = lookupType ctx x
  synth ctx (Pi x a b) =
    do check ctx a VU
       v <- eval (mkEnv ctx) a
       check (extendCtx ctx x v) b VU
       Right VU
  synth ctx (App rator rand) =
    do funTy <- synth ctx rator
       (a, b) <- isPi ctx funTy
       check ctx rand a
       body <- eval (mkEnv ctx) rand
       evalClosure b body
  synth ctx (Sigma x a b)
    = do check ctx a VU
         a' <- eval (mkEnv ctx) a
         check (extendCtx ctx x a') b VU
         Right VU
  synth ctx (Car e) =
    do t <- synth ctx e
       (aT, dT) <- isSigma ctx t
       Right aT
  synth ctx (Cdr e) =
    do t <- synth ctx e
       (aT, dT) <- isSigma ctx t
       e' <- eval (mkEnv ctx) e
       body <- doCar e'
       evalClosure dT body
  synth ctx Nat = Right VU
  synth ctx (IndNat tgt mot base step)
    = do t <- synth ctx tgt
         tgtV <- eval (mkEnv ctx) tgt
         motTy <- eval (mkEnv []) (Pi (Name' "x") Nat U)
         check ctx mot motTy
         motV <- eval (mkEnv ctx) mot
         z' <- doApply motV VZero
         check ctx base z'
         m' <- indNatStepType motV
         check ctx step m'
         doApply motV tgtV
  synth ctx (Equal ty from to)
    = do check ctx ty VU
         tyV <- eval (mkEnv ctx) ty
         check ctx from tyV
         check ctx to tyV
         Right VU
  synth ctx (Replace tgt mot base)
    = do t <- synth ctx tgt
         (ty, from, to) <- isEqual ctx t
         motTy <- eval ([(Name' "ty", ty)]) (Pi (Name' "x") (Var (Name' "ty")) U)
         check ctx mot motTy
         motV <- eval (mkEnv ctx) mot
         fromV <- doApply motV from
         check ctx base fromV
         doApply motV to
  synth ctx Trivial = Right VU
  synth ctx Absurd = Right VU
  synth ctx (IndAbsurd tgt mot)
    = do t <- synth ctx tgt
         isAbsurd ctx t
         check ctx mot VU
         eval (mkEnv ctx) mot
  synth ctx Atom = Right VU
  synth ctx U = Right VU
  synth ctx (The ty expr)
    = do check ctx ty VU
         tyV <- eval (mkEnv ctx) ty
         check ctx expr tyV
         Right tyV
  synth ctx other = Left (ErrorMessage "Unable to synthesize a type for ") -- ++ show other


module Machine

import Syntax as S
import Effects
import Effect.Exception
import Data.List

public export
MName : Type
MName = S.Name

mutual
  export
  data MValue
    = MInt Integer
    | MBool Bool
    | MClosure MName Frame Env

  export
  implementation Show MValue where
    show (MInt n)         = show n
    show (MBool b)        = show b
    show (MClosure _ _ _) = "<fun>"

  public export
  data Instr
    = IMult
    | IAdd
    | ISub
    | IEqual
    | ILess
    | IVar MName
    | IInt Integer
    | IBool Bool
    | IClosure MName MName Frame
    | IBranch Frame Frame
    | ICall
    | IPopEnv

  ||| A stack of instructions.
  public export
  Frame : Type
  Frame = List Instr

  public export
  Env : Type
  Env = List (MName, Lazy MValue)

  Stack : Type
  Stack = List MValue

public export
MachineError : Type
MachineError = String

public export
MEff : Type -> Type
--MEff a = Eff a [EXCEPTION MachineError]
MEff a = Either MachineError a

error : String -> MEff b
--error msg = raise (MkMachineError msg)
error msg = Left msg

Environs : Type
Environs = List Env

lookup : MName -> Environs -> MEff MValue
lookup x envs = case head' envs of
  Just env => case lookup x env of
                Just v  => pure v
                Nothing => error $ "Unknown " ++ x
  Nothing  => error $ "No environment in which to lookup " ++ x

pop : Stack -> MEff (MValue, Stack)
pop [] = error "Empty stack"
pop (v :: vs) = pure $ (v, vs)

popBool : Stack -> MEff (Bool, Stack)
popBool (MBool b :: vs) = pure (b, vs)
popBool _               = error "Bool expected"

||| Pop a value and a closure from a stack
popApp : Stack -> MEff (MName, Frame, Env, MValue, Stack)
popApp (v :: MClosure n fr env :: vs) = pure (n, fr, env, v, vs)
popApp _                           = error "Value and closure expected"

mult : Stack -> MEff Stack
mult (MInt i2 :: MInt i1 :: vs) = pure $ MInt (i1 * i2) :: vs
mult _                          = error "int and int expected in mult"

add : Stack -> MEff Stack
add (MInt i2 :: MInt i1 :: vs) = pure $ MInt (i1 + i2) :: vs
add _                          = error "int and int expected in add"

sub : Stack -> MEff Stack
sub (MInt i2 :: MInt i1 :: vs) = pure $ MInt (i1 - i2) :: vs
sub _                          = error "int and int expected in sub"

equal : Stack -> MEff Stack
equal (MInt i2 :: MInt i1 :: vs) = pure $ MBool (i1 == i2) :: vs
equal _                          = error "int and int expected in equal"

less : Stack -> MEff Stack
less (MInt i2 :: MInt i1 :: vs) = pure $ MBool (i1 < i2) :: vs
less _                          = error "int and int expected in less"

Frames : Type
Frames = List Frame

buildClosure : Frames -> Stack -> Environs -> Env -> MName -> MName -> Frame -> (Frames, Stack, Environs)
buildClosure frames stack envs env fnm nm frame =
  (frames, c :: stack, envs)
    where c = MClosure nm frame ((fnm, c) :: env)

exec : Instr -> Frames -> Stack -> Environs -> MEff (Frames, Stack, Environs)
exec instr frames stack envs = case instr of
  -- Arithmetic operations.
  IMult => do stack' <- mult stack
              pure (frames, stack', envs)
  IAdd  => do stack' <- add stack
              pure (frames, stack', envs)
  ISub  => do stack' <- sub stack
              pure (frames, stack', envs)
  IEqual=> do stack' <- equal stack
              pure (frames, stack', envs)
  ILess => do stack' <- less stack
              pure (frames, stack', envs)
  -- Pushing values onto the stack.
  IVar nm  => do v <- lookup nm envs
                 pure $ (frames, v :: stack, envs)
  IInt n   => pure $ (frames, MInt n :: stack, envs)
  IBool b  => pure $ (frames, MBool b :: stack, envs)

  IClosure f nm frame =>
    case head' envs of
      Just env => pure $ buildClosure frames stack envs env f nm frame
      Nothing  => error "No environment for a closure"

  -- Control instructions.
  IBranch f1 f2 => do (b, stack') <- popBool stack
                      pure $ ((if b then f1 else f2) :: frames, stack', envs)

  ICall => do (nm, frame, env, v, stack') <- popApp stack
              pure $ (frame :: frames, stack', ((nm, v) :: env) :: envs)

  IPopEnv => case envs of
    _ :: envs' => pure (frames, stack, envs')
    _          => error "No environment to pop"

export
mrun : Frame -> Env -> MEff (MValue, Env)
mrun frame env = loop ([frame], [], [env])
  where
    loop : (Frames, Stack, Environs) -> MEff (MValue, Env)
    loop ([], [v], [env]) = pure (v, env)
    loop ((i::is) :: frames, stack, envs) = do r <- exec i (is::frames) stack envs
                                               loop r
    loop ([] :: frames, stack, envs) = loop (frames, stack, envs)


module Dot

import Graph.Core
import Graph.API

-- %default total

data Kind = Undirected | Directed

data Attribute : Type where
  Color : String -> Attribute
  Label : String -> Attribute

data EdgeDef : (kind : Kind) -> Type where
  SimpleEdge : (target : String) -> (source : String) -> EdgeDef kind
  (::) : String -> EdgeDef kind -> EdgeDef kind

data Statement : (kind : Kind) -> Type where
  Node : String -> List Attribute -> Statement kind
  Edge : EdgeDef kind -> List Attribute -> Statement kind

record Dot (kind : Kind) where
  constructor MkDot
  strict : Bool
  id : Maybe String
  body : List (Statement kind)

Show Kind where
  show Undirected = "graph"
  show Directed = "digraph"

Show Attribute where
  show (Color col) = "color=" ++ col
  show (Label lab) = "label=" ++ lab

edgeConnector : Kind -> String
edgeConnector Undirected = "--"
edgeConnector Directed = "->"

Show (EdgeDef kind) where
  show (SimpleEdge target source) = unwords [source, edgeConnector kind, target]
  show (target :: def) = unwords [show def, edgeConnector kind, target]

appendAttrs : List Attribute -> String -> String
appendAttrs [] str = str
appendAttrs attrs str = str ++ (" [" ++ tags ++ "]") where
  tags = unwords (map show attrs)

Show (Statement kind) where
  show (Node node attrs) = appendAttrs attrs (node)
  show (Edge def attrs) = appendAttrs attrs (show def)

showDeclaration : Dot kind -> String
showDeclaration dot = unwords . putStrict . putKind . putId $ [] where
  putKind : List String -> List String
  putKind ws = (show kind) :: ws
  putId : List String -> List String
  putId ws = case id dot of
                  Nothing => ws
                  Just identifier => identifier :: ws
  putStrict : List String -> List String
  putStrict ws = if strict dot then "strict" :: ws else ws

showBody : Dot kind -> String
showBody dot = unlines (map show (body dot))

Show (Dot kind) where
  show dot = showDeclaration dot ++ " {\n" ++ showBody dot ++ "\n}"

test : Dot Directed
test = MkDot True (Just "yo") [
  Node "a" [],
  Node "b" [],
  Edge (SimpleEdge "a" "b") []
  ]

fromGraph : (Show a, Show b) => Graph a b -> Dot Directed
fromGraph graph = MkDot False Nothing (nodes ++ edges) where
  nodes : List (Statement Directed)
  nodes = map (\(id, l) => Node (show id) [Label (show l)]) (labNodes graph)
  edges : List (Statement Directed)
  edges = map f (labEdges graph) where
    f : Show b => (Int, Int, b) -> Statement Directed
    f (source, target, l)
      = Edge (SimpleEdge (show target) (show source)) [Label (show l)]

export
graphToDot : (Show a, Show b) => Graph a b -> String
graphToDot = show . fromGraph


||| How to rename things
|||
||| Module    : Renaming.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
module Toolkit.DeBruijn.Renaming

import Decidable.Equality
import Data.DPair

import Toolkit.Decidable.Informative

import Toolkit.Data.List.AtIndex
import Toolkit.Data.DList
import Toolkit.Data.DList.AtIndex

import Toolkit.DeBruijn.Context.Item
import Toolkit.DeBruijn.Context

%default total

public export
data IsVar : (ctxt : List kind)
          -> (type :      kind)
                  -> Type
  where
    V : (  pos : Nat)
     -> (0 prf : AtIndex type ctxt pos)
              -> IsVar   ctxt type

public export
%inline
shift : IsVar ctxt type -> IsVar (ctxt += a) type
shift (V pos prf) = V (S pos) (There prf)

public export
%inline
weaken : (func : IsVar old type
              -> IsVar new type)
      -> (IsVar (old += type') type
       -> IsVar (new += type') type)
weaken f (V Z Here)
  = V Z Here
weaken f (V (S idx) (There later)) with (f (V idx later))
  weaken f (V (S idx) (There later)) | (V pos prf)
    = V (S pos) (There prf)

public export
interface Rename (type : Type) (term : List type -> type -> Type) | term where
  rename : {old, new : List type}
        -> (f : {ty : type} -> IsVar old ty
                            -> IsVar new ty)
        -> ({ty : type} -> term old ty
                        -> term new ty)

  %inline
  embed : {ty   : type}
       -> {ctxt : List type}
               -> IsVar ctxt ty
               -> term  ctxt ty

public export
%inline
weakens : {type : Type}
       -> {term : List type -> type -> Type}
       -> Rename type term
       => {old, new : List type}
       -> (f : {ty  : type}
                   -> IsVar old ty
                   -> term  new ty)
       -> ({ty,type' : type}
              -> IsVar (old += type') ty
              -> term  (new += type') ty)

weakens f (V 0 Here)
  = embed (V Z Here)
weakens f (V (S idx) (There later))
  = rename shift (f (V idx later))

-- [ EOF ]


-- --------------------------------------------------------------- [ DList.idr ]
-- Module    : DList.idr
-- Copyright : (c) 2015,2016,2017, 2020 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]

||| A `list` construct to create lists of dependent types.
|||
||| One of the problems with using dependent types is that types
||| depend on values. This affects the ability to construct lists of
||| values that have a dependent type. The existing `List` type cannot
||| be used as it requires all elements to have the same type.
module Toolkit.Data.DList

import        Data.String
import public Data.List
import public Data.List.Elem

||| A list construct for dependent types.
|||
||| @aTy    The type of the value contained within the list element type.
||| @elemTy The type of the elements within the list
||| @as     The List used to contain the different values within the type.
public export
data DList : (aTy : Type)
          -> (elemTy : aTy -> Type)
          -> (as : List aTy)
          -> Type where
  ||| Create an empty List
  Nil  : DList aTy elemTy Nil
  ||| Cons
  |||
  ||| @elem The element to add
  ||| @rest The list for `elem` to be added to.
  (::) : {x : aTy}
      -> (elem : elemTy x)
      -> (rest : DList aTy elemTy xs)
      -> DList aTy elemTy (x::xs)

public export
mapToList : (forall x . e x -> b)
         -> DList a e xs
         -> List b
mapToList _ Nil = Nil
mapToList f (x::xs) = f x :: mapToList f xs

||| Function to show a `DList`.
|||
||| Due to limitations in idris wrt to class instances on dependent
||| types a generic show instance cannot be defined for
||| sigmalist. This will cause minor annoyances in its use.
|||
||| @showFunc A function to show the elements
||| @l       The list to be Shown.
public export
showDList : (showFunc : forall a . elemTy a -> String)
         -> (l : DList aTy elemTy as)
         -> String
showDList f xs = "[" ++ unwords (intersperse "," (mapToList f xs)) ++ "]"

namespace Alt
  public export
  index : (xs  : DList iTy eTy is)
       -> (idx : Elem i is)
       -> eTy i
  index (ex :: rest) Here = ex
  index (ex :: rest) (There later) = index rest later

  public export
  update : (vs  : DList iTy eTy is)
        -> (idx : Elem i is)
        -> (new : eTy i)
        -> DList iTy eTy is
  update (ex :: rest) Here new = new :: rest
  update (ex :: rest) (There later) new = ex :: update rest later new

  public export
  updateWith : DList iTy eTy is
            -> Elem i is
            -> (eTy i -> eTy i)
            -> DList iTy eTy is
  updateWith (ex :: rest) Here f = f ex :: rest
  updateWith (ex :: rest) (There later) f = ex :: updateWith rest later f

-- --------------------------------------------------------------------- [ EOF ]


import Data.Vect
import Data.Vect.Elem

data Typ : Type where
    TLam : Typ -> Typ -> Typ
    TNat : Typ

data Term : Typ -> Vect len Typ -> Type where
    Var : Elem a ctx -> Term a ctx
    Lam : Term b (a :: ctx) -> Term (TLam a b) ctx
    Fix : Term a (a :: ctx) -> Term a ctx

lookup : Vect len Typ -> Fin len -> Typ
lookup (a :: ctx) FZ = a
lookup (_ :: ctx) (FS n) = lookup ctx n

count : {ctx : Vect len Typ} -> (n : Fin len) -> Elem (lookup ctx n) ctx
count {ctx = _ :: ctx} FZ = Here
count {ctx = _ :: ctx} (FS n) = There (count n)

segfaults : {len : _} -> {ctx : Vect len Typ} ->
            Term (TLam TNat TNat) ctx
segfaults = Fix (Lam (Var (count 0)))

cycleDetected : {len : _} -> {ctx : Vect len Typ} ->
                Term (TLam TNat TNat) ctx
cycleDetected = Fix (Var (count 0))


-- examples in "Type-Driven Development with Idris"
-- chapter 11, section 2

import Data.Primitives.Views
import System

-- check that all functions are total
%default total

randoms : Int -> Stream Int
randoms seed = let seed' = 1664525 * seed + 1013904223 in
                (seed' `shiftR` 2) :: randoms seed'

arithInputs : Int -> Stream Int
arithInputs seed = map bound (randoms seed)
  where
    bound : Int -> Int
    bound num with (divides num 12)
      bound ((12 * div) + rem) | (DivBy prf) = rem + 1

data InfIO : Type where
  Do : IO a
       -> (a -> Inf InfIO)
       -> InfIO

loopPrint : String -> InfIO
loopPrint msg = Do (putStrLn msg)
                   (\_ => loopPrint msg)

partial
run : InfIO -> IO ()
run (Do action cont) = do res <- action
                          run (cont res)

data Fuel = Dry | More Fuel

tank : Nat -> Fuel
tank Z = Dry
tank (S k) = More (tank k)

runOnFuel : Fuel -> InfIO -> IO ()
runOnFuel (More fuel) (Do act gen) = do res <- act
                                        runOnFuel fuel (gen res)
runOnFuel Dry ios = putStrLn "Out of fuel"

data LazyFuel = LDry | LMore (Lazy LazyFuel)

partial
forever : LazyFuel
forever = LMore forever

runOnLazyFuel : LazyFuel -> InfIO -> IO ()
runOnLazyFuel (LMore fuel) (Do act gen) = do res <- act
                                             runOnLazyFuel fuel (gen res)
runOnLazyFuel LDry ios = putStrLn "Out of fuel"

(>>=) : IO a -> (a -> Inf InfIO)  -> InfIO
(>>=) = Do

loopPrint' : String -> InfIO
loopPrint' msg = do putStrLn msg
                    loopPrint' msg

quiz' : Stream Int -> (score : Nat) -> InfIO
quiz'  (num1 :: num2 :: nums) score
  = do putStrLn ("Score so far:" ++ show score)
       putStr (show num1 ++ " * " ++ show num2 ++ "? ")
       answer <- getLine
       if cast answer == num1 * num2
         then do putStrLn "Correct!"
                 quiz' nums (score + 1)
         else do putStrLn ("Wrong, the answer is " ++ show (num1 * num2))
                 quiz' nums score

partial
main : IO ()
main = do seed <- time
          runOnLazyFuel forever (quiz' (arithInputs (fromInteger seed)) 0)


module TypeFuns

StringOrInt : Bool -> Type
StringOrInt False = String
StringOrInt True = Int

getStringOrInt : (isInt : Bool) -> StringOrInt isInt
getStringOrInt False = "Ninety Four"
getStringOrInt True = 94

valToString : (isInt : Bool) -> StringOrInt isInt -> String
valToString False x = trim x
valToString True x = cast x


{- Ctrl-Alt-A: Add definition
   Ctrl-Alt-C: Case split
   Ctrl-Alt-D: Documentation
   Ctrl-Alt-L: Lift hole: Lifts a hole to the top level as a new function definition
   Ctrl-Alt-M: Match: Replaces a hole with a case expression that matches on an intermediate result
   Ctrl-Alt-R: Reloads and typechecks the current buffer
   Ctrl-Alt-S: Search
   Ctrl-Alt-T: Type-check: Displays the type under cursor
   Ctrl-Alt-W: Add With View -}
module Main

data InfIO : Type where
  Do : IO a -> (a -> Inf InfIO) -> InfIO

total
loopPrint0 : String -> InfIO
loopPrint0 msg = Do (putStrLn msg) (\_ => loopPrint0 msg)

data Fuel = Dry | More (Lazy Fuel)

tank : Nat -> Fuel
tank Z = Dry
tank (S n) = More (tank n)

forever : Fuel
forever = More forever

run : Fuel -> InfIO -> IO ()
run Dry _ = putStrLn "Out of fuel"
run (More fuel) (Do action cont) = do
  res <- action
  run fuel (cont res)

(>>=) : IO a -> (a -> Inf InfIO) -> InfIO
(>>=) = Do

total
loopPrint1 : String -> InfIO
loopPrint1 msg = do
  putStrLn msg
  loopPrint1 msg

main : IO ()
main = do
  run (tank 5) (loopPrint0 "vroom")
  run (tank 5) (loopPrint1 "broom")


data Usage = Once | Many

data Use : Usage -> (Type -> Type) -> Type -> Type where
     Pure : (1 x : a) -> Use t m a
     BindOnce : (1 act : Use Once m a) -> (1 k : (1 x : a) -> Use t m b) -> Use t m b
     BindMany : (1 act : Use Many m a) -> (1 k : (x : a) -> Use t m b) -> Use t m b

contType : (Type -> Type) -> Usage -> Usage -> Type -> Type -> Type
contType m Once q a b = ((1 x : a) -> Use q m b)
contType m Many q a b = ((x : a) -> Use q m b)

(>>=) : {p : _} -> (1 f : Use p m a) -> (1 k : contType m p q a b) -> Use q m b
(>>=) {p = Once} = BindOnce
(>>=) {p = Many} = BindMany

pure : (1 x : a) -> Use t m a
pure = Pure

One : (Type -> Type) -> Type -> Type
One = Use Once

Any : (Type -> Type) -> Type -> Type
Any = Use Many

data DoorState = Closed | Open

data Door : DoorState -> Type where
     MkDoor : (isOpen : Bool) -> Door (if isOpen then Open else Closed)

newDoor : One m (Door Closed)
newDoor = pure (MkDoor False)

knock : (1 d : Door Closed) -> One m (Door Closed)
openDoor : (1 d : Door Closed) ->
           One m (Res Bool (\r => Door (if r then Open else Closed)))

closeDoor : (1 d : Door Open) -> One m (Door Closed)

deleteDoor : (1 d : Door Closed) -> Any m ()

doorProg : Any m ()
doorProg
    = do d <- newDoor
         r <- openDoor d
         let x = 42
         case r of
              what => ?now

doorProg2 : Any m ()
doorProg2
    = do d <- newDoor
         r <- openDoor d
         let x = 42
         case r of
              (res # d) => ?now_1

doorProg3 : Any m ()
doorProg3
    = do d <- newDoor
         r <- openDoor d
         let x = 42
         case r of
              (True # d) => ?now_2
              (False # d) => ?now_3


module Typing.Unification

import Typing.Common
import Typing.Util
import Typing.Equate

-- oYYYo _YYY_ 0    0   0 8YYYY
-- %___  0   0 0    0   0 8___
-- `"""p 0   0 0    "o o" 8"""
-- YoooY "ooo" 8ooo  "8"  8oooo

solve : List Equation -> TypeChecker Substitution
solve eqs0 = go eqs0 []
where
	go : List Equation -> Substitution -> TypeChecker Substitution

	go [] subs' = pure subs'

	go ((Meta x ~~ Meta y) :: eqs) subs' with (x == y)
		| True = go eqs subs'
		| False = do
			eqs' <- traverse (evalWithSubs ((x, Meta y)::subs')) eqs
			go eqs' ((x, Meta y)::subs')

	go ((Meta x ~~ t2) :: eqs) subs' = do
		unless (not (occurs x t2))
			$ throw $ "Cannot unify because " ++ show (Meta x)
				++ " occurs in " ++ show t2
		eqs' <- traverse (evalWithSubs ((x,t2) :: subs')) eqs
		go eqs' ((x,t2) :: subs')

	go ((t1 ~~ Meta y) :: eqs) subs' = do
		unless (not (occurs y t1))
			$ throw $ "Cannot unify because " ++ show (Meta y)
				++ " occurs in " ++ show t1
		eqs' <- traverse (evalWithSubs ((y,t1) :: subs')) eqs
		go eqs' ((y,t1) :: subs')

	go ((Var x ~~ Var y) :: eqs) subs' = do
		unless (x == y)
			$ throw $ "Cannot unify variables " ++ show (Var x)
				++ " and " ++ show (Var y)
		go eqs subs'

	go ((DottedVar m1 x1 ~~ DottedVar m2 x2) :: eqs) subs' = do
		unless (m1 == m2 && x1 == x2)
			$ throw $ "Cannot unify symbols " ++ show (DottedVar m1 x1)
				++ " and " ++ show (DottedVar m2 x2)
		go eqs subs'

	go ((AbsoluteDottedVar m1 x1 ~~ AbsoluteDottedVar m2 x2) :: eqs) subs' = do
		unless (m1 == m2 && x1 == x2)
			$ throw $ "Cannot unify symbols " ++ show (AbsoluteDottedVar m1 x1)
				++ " and " ++ show (AbsoluteDottedVar m2 x2)
		go eqs subs'
	go ((Ann m1 t1 ~~ Ann m2 t2) :: eqs) subs' = go ((m1 ~~ m2) :: (t1 ~~ t2) :: eqs) subs'

	go ((Star ~~ Star) :: eqs) subs' = go eqs subs'

	go ((Pi plic1 a1 sc1 ~~ Pi plic2 a2 sc2) :: eqs) subs' = do
		unless (plic1 == plic2)
			$ throw $ "Mismatched plicities when trying to unify "
						++ show (Pi plic1 a1 sc1) ++ " with "
						++ show (Pi plic2 a2 sc2)
		i <- newName
		case (head' (names sc1), head' (names sc2)) of
			(Just h1, Just h2) => do
				let b1 = instantiate sc1 [Var (Generated h1 i)]
				let b2 = instantiate sc2 [Var (Generated h2 i)]
				go ((a1 ~~ a2) :: (b1 ~~ b2) :: eqs) subs'
			_ => throw "should not happen"

	go ((Lam plic1 sc1 ~~ Lam plic2 sc2) :: eqs) subs' = do
		unless (plic1 == plic2)
			$ throw $ "Mismatched plicities when trying to unify "
						++ show (Lam plic1 sc1) ++ " with "
						++ show (Lam plic2 sc2)
		i <- newName
		case (head' (names sc1), head' (names sc2)) of
			(Just h1, Just h2) => do
				let b1 = instantiate sc1 [Var (Generated h1 i)]
				let b2 = instantiate sc2 [Var (Generated h2 i)]
				go ((b1 ~~ b2) :: eqs) subs'
			_ => throw "should not happen"

	go ((App plic1 f1 a1 ~~ App plic2 f2 a2) :: eqs) subs' = do
		unless (plic1 == plic2)
			$ throw $ "Mismatched plicities when trying to unify "
						++ show (App plic1 f1 a1) ++ " with "
						++ show (App plic2 f2 a2)
		-- we should not assume all functions are injective
		-- so we will drop this equation simply, and check whether all
		-- holes are filled afterwards
		-- go ((f1 ~~ f2) :: (a1 ~~ a2) :: eqs) subs'
		go eqs subs'

	go ((Con c1 as1 ~~ Con c2 as2) :: eqs) subs' = do
		unless (c1 == c2)
			$ throw $ "Mismatching constructors " ++ show c1 ++ " and " ++ show c2
		unless (length as1 == length as2)
			$ throw $ "Mismatching number of arguments in "
						++ show (Con c1 as1) ++ " and "
						++ show (Con c2 as2)
		eqs' <- zipConArgs as1 as2
		go (eqs' ++ eqs) subs'
	where
		zipConArgs : List (Plict, Term) -> List (Plict, Term) -> TypeChecker (List Equation)
		zipConArgs [] [] = pure []
		zipConArgs ((plic1',a1')::as1') ((plic2',a2')::as2') = if plic1' == plic2'
				then do
					eqs' <- zipConArgs as1' as2'
					pure $ (a1' ~~ a2') :: eqs'
				else
					throw "Mismatching plicity."
		zipConArgs _ _ = throw "Mismatching number of arguments."

	go ((Case as1 mot1 cs1 ~~ Case as2 mot2 cs2) :: eqs) subs' = do
		unless(length as1 == length as2)
			$ throw $ "Mismatching number of case arguments in "
						++ show (Case as1 mot1 cs1) ++ " and "
						++ show (Case as2 mot2 cs2)
		unless (length cs1 == length cs2)
			$ throw $ "Mismatching number of clauses in "
						++ show (Case as1 mot1 cs1) ++ " and "
						++ show (Case as2 mot2 cs2)
		let argEqs = zipWith (~~) as1 as2
		motEqs <- compareCaseMotive mot1 mot2
		clauseEqs <- compareClauses cs1 cs2
		go (argEqs ++ motEqs ++ clauseEqs ++ eqs) subs'

	go ((RecordType tele1 ~~ RecordType tele2) :: eqs) subs' = do
		eqs' <- compareTelescope tele1 tele2
		go (eqs' ++ eqs) subs'

	go ((RecordCon fields1 ~~ RecordCon fields2) :: eqs) subs' = do
		eqs' <- compareFields fields1 fields2
		go (eqs' ++ eqs) subs'

	go ((Project m1 x1 ~~ Project m2 x2) :: eqs) subs' = do
		unless (x1 == x2)
			$ throw $ "Field names not equal: " ++ x1 ++ " and " ++ x2
		go ((m1 ~~ m2) :: eqs) subs'

	go ((m ~~ m') :: _) _ = throw $ "Terms not equal: " ++ show m ++ " and " ++ show m'

export
addSubstitutions : Substitution -> TypeChecker ()
addSubstitutions subs0 = do
	completeSubstitution subs0
	substituteContext
where
	completeSubstitution : Substitution -> TypeChecker ()
	completeSubstitution subs' = do
		subs <- substitution
		let subs2 = subs' ++ subs
		let subs2' = nubBy (\(a,_) => \(b,_) => a == b) (map (\(k,v) => (k, instantiateMetas subs2 v)) subs2)
		putSubstitution subs2'
	substituteContext : TypeChecker ()
	substituteContext = do
		ctx <- context
		subs <- substitution
		let ctx' = map (instCtx subs) ctx
		putContext ctx'
	where
		instCtx : Substitution -> ContextEntry -> ContextEntry
		instCtx subs (i, x, t) = (i, x, instantiateMetas subs t)

-- 0   0 8o  0 Y8Y 8YYYY 0   0
-- 0   0 8Yo 8  0  8___  "o o"
-- 0   0 8 Yo8  0  8"""    0
-- "ooo" 0   8 o8o 0       0

export
unify : Term -> Term -> TypeChecker ()
unify p q = do
	subs <- solve [p ~~ q]
	equate [p ~~ q] subs
	addSubstitutions subs


%default total

test : (f : () -> Bool) -> f === (\x => True) -> f () = True
test (\x => True) Refl = Refl


module Printf

data Format = Number Format
            | Str Format
            | Chr Format
            | Doub Format
            | Lit String Format
            | End

PrintfType : Format -> Type
PrintfType (Number fmt)  = (i : Int) -> PrintfType fmt
PrintfType (Str fmt)     = (str : String) -> PrintfType fmt
-- `str` is ignored here because we are computing types, not values
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType (Chr fmt)     = (c : Char) -> PrintfType fmt
PrintfType (Doub fmt)    = (d : Double) -> PrintfType fmt
PrintfType End           = String

printFmt : (fmt : Format) -> (acc : String) -> PrintfType fmt
printFmt (Number fmt) acc  = \i => printFmt fmt (acc ++ (show i))
printFmt (Str fmt) acc     = \s => printFmt fmt (acc ++ s)
printFmt (Lit str fmt) acc = printFmt fmt (acc ++ str)
printFmt (Chr fmt) acc     = \c => printFmt fmt (acc ++ (singleton c))
printFmt (Doub fmt) acc    = \d => printFmt fmt (acc ++ (show d))
printFmt End acc           = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number $ toFormat chars
toFormat ('%' :: 's' :: chars) = Str $ toFormat chars
toFormat ('%' :: 'c' :: chars) = Chr $ toFormat chars
toFormat ('%' :: 'f' :: chars) = Doub $ toFormat chars
toFormat ('%' :: chars)        = Lit "%" $ toFormat chars
-- Below implementation seems to be of an efficiency concern to me
-- If we didn't do strcons here, these literals would be concatenated by printFmt
toFormat (c :: chars)          = case toFormat chars of
                                     Lit lit chars' => Lit (strCons c lit) chars'
                                     fmt            => Lit (strCons c "") fmt

formatString : String -> Format
formatString = toFormat . unpack

printf : (fmt : String) -> PrintfType (formatString fmt)
printf fmt = printFmt _ ""

main : IO ()
main = do
     putStrLn (printf "%d" 1)


module Generics.SOP

import Decidable.Equality

import public Data.List.Elem
import public Data.SOP

%default total

||| Interface for converting a data type from and to
||| its generic representation as a sum of products.
|||
||| Additional Idris coolness: This comes with proofs
||| that `from . to = id` and `to . from = id` and
||| thus, that `t` and `SOP code` are indeed isomorphic.
public export
interface Generic (0 t : Type) (0 code : List $ List Type) | t where
  constructor MkGeneric
  ||| Converts the data type to its generic representation.
  from : (v : t) -> SOP I code

  ||| Converts the generic representation back to the original
  ||| value.
  to   : (v : SOP I code) -> t

  ||| Proof that `to . from = id`.
  fromToId : (v : t) -> to (from v) = v

  ||| Proof that `from . to = id`.
  toFromId : (v : SOP I code) -> from (to v) = v

export
fromInjective : Generic t code =>
                (0 x : t) -> (0 y : t) -> (from x = from y) -> x = y
fromInjective x y prf = rewrite sym $ fromToId y in lemma2
  where lemma1 : to {t = t} (from x) = to {t = t} (from y)
        lemma1 = cong to prf

        lemma2 : x = to {t = t} (from y)
        lemma2 = rewrite sym $ fromToId x in lemma1

public export
0 Code : (t : Type) -> Generic t code => List $ List Type
Code _ = code

||| Tries to extract the arguments of a single constructor
||| from a value's generic representation.
public export
genExtract :  (0 ts : List Type)
           -> (v : t)
           -> Generic t code
           => {auto prf : Elem ts code}
           -> Maybe (NP I ts)
genExtract ts v = extractSOP ts $ from v

||| Tries to extract the value of a single one argument
||| constructor from a value's generic representation.
public export
genExtract1 :  (0 t' : Type)
            -> (v : t)
            -> Generic t code
            => {auto prf : Elem [t'] code}
            -> Maybe t'
genExtract1 t' v = hd <$> genExtract [t'] v

||| Returns all value from a generic enum type
||| (all nullary constructors) wrapped in homogeneous n-ary product.
public export
valuesNP : Generic t code => (et : EnumType code) =>
           NP_ (List Type) (K t) code
valuesNP = hmap (to . MkSOP) (run et)
  where run :  EnumType kss -> NP_ (List k) (K (NS_ (List k) (NP f) kss)) kss
        run EZ     = []
        run (ES x) = Z [] :: mapNP (\ns => S ns) (run x)

||| Returns all value from a generic enum type
||| (all nullary constructors) wrapped in a list.
public export %inline
values : Generic t code => (et : EnumType code) => List t
values = collapseNP valuesNP

||| Like `valuesNP` but takes the erased value type as an
||| explicit argument to help with type inference.
public export %inline
valuesForNP : (0 t: Type) -> Generic t code => (et : EnumType code) =>
              NP_ (List Type) (K t) code
valuesForNP _ = valuesNP

||| Like `values` but takes the erased value type as an
||| explicit argument to help with type inference.
public export %inline
valuesFor : (0 t : Type) -> Generic t code => (et : EnumType code) => List t
valuesFor _ = values

--------------------------------------------------------------------------------
--          Generic Implementation Functions
--------------------------------------------------------------------------------

||| Default `(==)` implementation for data types with a `Generic`
||| instance.
public export
genEq : Generic t code => POP Eq code => t -> t -> Bool
genEq x y = from x == from y

||| Default `compare` implementation for data types with a `Generic`
||| instance.
public export
genCompare : Generic t code => POP Ord code => t -> t -> Ordering
genCompare x y = compare (from x) (from y)

||| Default `decEq` implementation for data types with a `Generic`
||| instance.
public export
genDecEq :  Generic t code => POP DecEq code
         => (x : t) -> (y : t) -> Dec (x = y)
genDecEq x y = case decEq (from x) (from y) of
                    (Yes prf)   => Yes $ fromInjective x y prf
                    (No contra) => No $ \h => contra (cong from h)

||| Default `(<+>)` implementation for data types with a `Generic`
||| instance.
public export
genAppend :  Generic t [ts]
          => POP Semigroup [ts]
          => t -> t -> t
genAppend x y = to $ from x <+> from y

||| Default `neutral` implementation for data types with a `Generic`
||| instance.
public export
genNeutral :  Generic t [ts] => POP Monoid [ts] => t
genNeutral = to neutral

--------------------------------------------------------------------------------
--          Prelude Implementations
--------------------------------------------------------------------------------

-- I wrote the implementations below manually to get a feel for
-- their general structure before starting with deriving
-- them via elaborator reflection.

public export
Generic () [[]] where
  from () = MkSOP $ Z []

  to (MkSOP $ Z []) = ()
  to (MkSOP $ S _) impossible

  fromToId () = Refl

  toFromId (MkSOP $ Z []) = Refl

public export
Generic (a,b) [[a,b]] where
  from (a,b) = MkSOP $ Z [a,b]

  to (MkSOP $ Z [a,b]) = (a,b)
  to (MkSOP $ S _) impossible

  fromToId (a,b) = Refl

  toFromId (MkSOP $ Z [a,b]) = Refl

public export
Generic (LPair a b) [[a,b]] where
  from (a # b) = MkSOP $ Z [a,b]

  to (MkSOP $ Z [a,b]) = (a # b)
  to (MkSOP $ S _) impossible

  fromToId (a # b) = Refl

  toFromId (MkSOP $ Z [a, b]) = Refl

public export
Generic Void [] where
  from v impossible

  to (MkSOP v) impossible

  fromToId v impossible

  toFromId (MkSOP v) impossible

public export
Generic (Stream a) [[a, Inf (Stream a)]] where
  from (h :: t) = MkSOP $ Z [h,t]

  to (MkSOP $ Z [h,t])  = h :: t

  fromToId (h :: t) = Refl

  toFromId (MkSOP $ Z [h,t]) = Refl


module Toolkit.Data.Vect.Leanings

import Data.Vect

import Toolkit.Data.DVect

namespace Index
  public export
  data Leans : (o,l,c,r : Nat) -> Type where
    Empty : Leans Z Z Z Z

    Left : Leans    os     ls  cs rs
        -> Leans (S os) (S ls) cs rs

    Center : Leans    os  ls    cs  rs
          -> Leans (S os) ls (S cs) rs

    Right : Leans    os  ls cs    rs
         -> Leans (S os) ls cs (S rs)

public export
data IsCenter : (type    : Type)
             -> (goLeft  : type -> Type)
             -> (goRight : type -> Type)
             -> (o       : type)
                        -> Type
  where
    C : (noLeft  : left  o -> Void)
     -> (noRight : right o -> Void)
                -> IsCenter type left right o

public export
data Leaning : (type    : Type)
            -> (goLeft  : type -> Type)
            -> (goRight : type -> Type)
            -> (idx     : Leans o l c r)
            -> (os      : Vect  o        type)
            -> (ls      : Vect    l      type)
            -> (cs      : Vect      c    type)
            -> (rs      : Vect        r  type)
                       -> Type
  where
    Empty : Leaning type left right Empty Nil Nil Nil Nil

    Left : {o : type}
        -> (prf  : left o)
        -> (rest : Leaning type left right       idx      os      ls  cs rs)
                -> Leaning type left right (Left idx) (o::os) (o::ls) cs rs

    Center : {o : type}
          -> (prf  : IsCenter type left right o)
          -> (rest : Leaning  type left right         idx      os  ls     cs  rs)
                  -> Leaning  type left right (Center idx) (o::os) ls (o::cs) rs

    Right : {o : type}
         -> (prf  : right o)
         -> (rest : Leaning type left right        idx      os  ls cs     rs)
                 -> Leaning type left right (Right idx) (o::os) ls cs (o::rs)

public export
data Result : (type    : Type)
           -> (isLeft  : (o : type) -> Type)
           -> (isRight : (o : type) -> Type)
           -> (os      : Vect o type)
                      -> Type
  where
    R : (lefts   : Vect l type)
     -> (centers : Vect c type)
     -> (rights  : Vect r type)
     -> (idx     : Leans o l c r)

     -> (leaning   : Leaning type isLeft isRight idx os lefts centers rights)
     -> (prfLeft   : DVect type isLeft l lefts)
     -> (prfCenter : DVect type (IsCenter type isLeft isRight) c centers)
     -> (prfRight  : DVect type isRight r rights)
                  -> Result type isLeft isRight os

export
leans : {type  : Type}
     -> {left  : type -> Type}
     -> {right : type -> Type}
     -> (isLeft  : (o : type) -> Dec (left  o))
     -> (isRight : (o : type) -> Dec (right o))
     -> (os      : Vect o type)
                -> Result type left right os
leans isLeft isRight []
  = R [] [] [] Empty Empty [] [] []

leans l r (x :: xs) with (l x)
  leans l r (x :: xs) | (Yes prf) with (leans l r xs)
    leans l r (x :: xs) | (Yes prf) | (R lefts centers rights idx lean prfLeft prfCenter prfRight)
      = R (x::lefts) centers rights (Left idx) (Left prf lean) (prf :: prfLeft) prfCenter prfRight

  leans l r (x :: xs) | (No noL) with (r x)
    leans l r (x :: xs) | (No noL) | (Yes prf) with (leans l r xs)
      leans l r (x :: xs) | (No noL) | (Yes prf) | (R ls cs rs idx lean pLs pCs pRs)
        = R ls cs (x::rs) (Right idx) (Right prf lean) pLs pCs (prf :: pRs)

    leans l r (x :: xs) | (No noL) | (No noR) with (leans l r xs)
      leans l r (x :: xs) | (No noL) | (No noR) | (R ls cs rs idx lean pLs pCs pRs)
        = R ls (x::cs) rs (Center idx) (Center (C noL noR) lean) pLs (C noL noR :: pCs) pRs

namespace Poll

  public export
  data LeansLeft : (poll : Leaning type l r i os ls rs cs)
                        -> Type
    where
      EmptyL : LeansLeft Empty

      IsLeft : {rest  : Leaning type l r i os ls cs rs}
            -> {prf   : l o}
            -> (later : LeansLeft           rest)
                     -> LeansLeft (Left prf rest)

  Uninhabited (LeansLeft (Center prf rest)) where
    uninhabited EmptyL impossible
    uninhabited (IsLeft later) impossible

  Uninhabited (LeansLeft (Right prf rest)) where
    uninhabited EmptyL impossible
    uninhabited (IsLeft later) impossible

  export
  leansLeft : (poll : Leaning type l r i os ls cs rs)
                   -> Dec (LeansLeft poll)
  leansLeft Empty
    = Yes EmptyL

  leansLeft (Left prf rest) with (leansLeft rest)
    leansLeft (Left prf rest) | (Yes x)
      = Yes (IsLeft x)

    leansLeft (Left prf rest) | (No contra)
      = No (\(IsLeft later) => contra later)

  leansLeft (Center prf rest)
    = No absurd

  leansLeft (Right prf rest)
    = No absurd

  public export
  data LeansRight : (poll : Leaning type l r i os ls cs rs)
                        -> Type
    where
      EmptyR : LeansRight Empty

      IsRight : {rest  : Leaning type l r i os ls cs rs}
             -> {prf   : r o}
             -> (later : LeansRight rest)
                      -> LeansRight (Right prf rest)

  Uninhabited (LeansRight (Center prf rest)) where
    uninhabited EmptyR impossible
    uninhabited (IsRight later) impossible

  Uninhabited (LeansRight (Left prf rest)) where
    uninhabited EmptyR impossible
    uninhabited (IsRight later) impossible

  export
  leansRight : (poll : Leaning type l r i os ls cs rs)
                    -> Dec (LeansRight poll)
  leansRight Empty
    = Yes EmptyR

  leansRight (Right prf rest) with (leansRight rest)
    leansRight (Right prf rest) | (Yes x)
      = Yes (IsRight x)

    leansRight (Right prf rest) | (No contra)
      = No (\(IsRight later) => contra later)

  leansRight (Center prf rest)
    = No absurd

  leansRight (Left prf rest)
    = No absurd

  public export
  data LeansCenter : (poll : Leaning type l r i os ls cs rs)
                        -> Type
    where
      EmptyC : LeansCenter Empty

      IsCenter : {rest  : Leaning type l r i os ls cs rs}
              -> {prf   : IsCenter type l r o}
              -> (later : LeansCenter rest)
                       -> LeansCenter (Center prf rest)

  Uninhabited (LeansCenter (Right prf rest)) where
    uninhabited EmptyC impossible
    uninhabited (IsCenter later) impossible

  Uninhabited (LeansCenter (Left prf rest)) where
    uninhabited EmptyC impossible
    uninhabited (IsCenter later) impossible

  export
  leansCenter : (poll : Leaning type l r i os ls cs rs)
                     -> Dec (LeansCenter poll)
  leansCenter Empty
    = Yes EmptyC

  leansCenter (Center prf rest) with (leansCenter rest)
    leansCenter (Center prf rest) | (Yes x)
      = Yes (IsCenter x)

    leansCenter (Center prf rest) | (No contra)
      = No (\(IsCenter later) => contra later)

  leansCenter (Right prf rest)
    = No absurd

  leansCenter (Left prf rest)
    = No absurd

public export
data HowLeans : (poll : Leaning type l r i os ls cs rs) -> Type where
  LE : HowLeans Empty
  LL : LeansLeft poll -> HowLeans poll

  LC : (LeansLeft  poll -> Void)
    -> (LeansRight poll -> Void)
    -> HowLeans poll

  LR : LeansRight poll -> HowLeans poll

export
howLeans : (poll : Leaning type l r i os ls cs rs) -> HowLeans poll
howLeans {ls=Nil} {cs=Nil} {rs=Nil} Empty = LE

howLeans {ls} {cs} {rs} poll with (leansLeft poll)
  howLeans {ls = ls} {cs = cs} {rs = rs} poll | (Yes prf)
    = LL prf

  howLeans {ls = ls} {cs = cs} {rs = rs} poll | (No noL) with (leansRight poll)
    howLeans {ls = ls} {cs = cs} {rs = rs} poll | (No noL) | (Yes prf)
      = LR prf

    howLeans {ls = ls} {cs = cs} {rs = rs} poll | (No noL) | (No noR)
      = LC noL noR

-- [ EOF ]