module Data.SortedMap.Dependent

import Data.DPair

import Decidable.Equality

-- TODO: write split

-------------------------------
--- Internal representation ---
-------------------------------

private
data Tree : Nat -> (k : Type) -> (v : k -> Type) -> Ord k -> Type where
  Leaf : (x : k) -> v x -> Tree Z k v o
  Branch2 : Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o
  Branch3 : Tree n k v o -> k -> Tree n k v o -> k -> Tree n k v o -> Tree (S n) k v o

branch4 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch4 a b c d e f g =
  Branch2 (Branch2 a b c) d (Branch2 e f g)

branch5 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch5 a b c d e f g h i =
  Branch2 (Branch2 a b c) d (Branch3 e f g h i)

branch6 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch6 a b c d e f g h i j k =
  Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

branch7 :
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o -> k ->
  Tree n k v o ->
  Tree (S (S n)) k v o
branch7 a b c d e f g h i j k l m =
  Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

merge1 : Tree n k v o -> k -> Tree (S n) k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o
merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i
merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge2 : Tree (S n) k v o -> k -> Tree n k v o -> k -> Tree (S n) k v o -> Tree (S (S n)) k v o
merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i
merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k
merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

merge3 : Tree (S n) k v o -> k -> Tree (S n) k v o -> k -> Tree n k v o -> Tree (S (S n)) k v o
merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i
merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k
merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m

treeLookup : Ord k => (x : k) -> Tree n k v o -> Maybe (y : k ** v y) -- may also return an erased `So (x == y)`
treeLookup k (Leaf k' v) =
  if k == k' then
    Just (k' ** v)
  else
    Nothing
treeLookup k (Branch2 t1 k' t2) =
  if k <= k' then
    treeLookup k t1
  else
    treeLookup k t2
treeLookup k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    treeLookup k t1
  else if k <= k2 then
    treeLookup k t2
  else
    treeLookup k t3

treeInsert' : Ord k => (x : k) -> v x -> Tree n k v o -> Either (Tree n k v o) (Tree n k v o, k, Tree n k v o)
treeInsert' k v (Leaf k' v') =
  case compare k k' of
    LT => Right (Leaf k v, k, Leaf k' v')
    EQ => Left (Leaf k v)
    GT => Right (Leaf k' v', k', Leaf k v)
treeInsert' k v (Branch2 t1 k' t2) =
  if k <= k' then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right (a, b, c) => Left (Branch3 a b c k' t2)
  else
    case treeInsert' k v t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right (a, b, c) => Left (Branch3 t1 k' a b c)
treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeInsert' k v t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)
  else
    if k <= k2 then
      case treeInsert' k v t2 of
        Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
        Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)
    else
      case treeInsert' k v t3 of
        Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
        Right (a, b, c) => Right (Branch2 t1 k1 t2, k2, Branch2 a b c)

treeInsert : Ord k => (x : k) -> v x -> Tree n k v o -> Either (Tree n k v o) (Tree (S n) k v o)
treeInsert k v t =
  case treeInsert' k v t of
    Left t' => Left t'
    Right (a, b, c) => Right (Branch2 a b c)

delType : Nat -> (k : Type) -> (v : k -> Type) -> Ord k -> Type
delType Z k v o = ()
delType (S n) k v o = Tree n k v o

treeDelete : Ord k => (n : Nat) -> k -> Tree n k v o -> Either (Tree n k v o) (delType n k v o)
treeDelete _ k (Leaf k' v) =
  if k == k' then
    Right ()
  else
    Left (Leaf k' v)
treeDelete (S Z) k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete Z k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right () => Right t2
  else
    case treeDelete Z k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right () => Right t1
treeDelete (S Z) k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete Z k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right () => Left (Branch2 t2 k2 t3)
  else if k <= k2 then
    case treeDelete Z k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right () => Left (Branch2 t1 k1 t3)
  else
    case treeDelete Z k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right () => Left (Branch2 t1 k1 t2)
treeDelete (S (S n)) k (Branch2 t1 k' t2) =
  if k <= k' then
    case treeDelete (S n) k t1 of
      Left t1' => Left (Branch2 t1' k' t2)
      Right t1' =>
        case t2 of
          Branch2 a b c => Right (Branch3 t1' k' a b c)
          Branch3 a b c d e => Left (branch4 t1' k' a b c d e)
  else
    case treeDelete (S n) k t2 of
      Left t2' => Left (Branch2 t1 k' t2')
      Right t2' =>
        case t1 of
          Branch2 a b c => Right (Branch3 a b c k' t2')
          Branch3 a b c d e => Left (branch4 a b c d e k' t2')
treeDelete (S (S n)) k (Branch3 t1 k1 t2 k2 t3) =
  if k <= k1 then
    case treeDelete (S n) k t1 of
      Left t1' => Left (Branch3 t1' k1 t2 k2 t3)
      Right t1' => Left (merge1 t1' k1 t2 k2 t3)
  else if k <= k2 then
    case treeDelete (S n) k t2 of
      Left t2' => Left (Branch3 t1 k1 t2' k2 t3)
      Right t2' => Left (merge2 t1 k1 t2' k2 t3)
  else
    case treeDelete (S n) k t3 of
      Left t3' => Left (Branch3 t1 k1 t2 k2 t3')
      Right t3' => Left (merge3 t1 k1 t2 k2 t3')

treeToList : Tree n k v o -> List (x : k ** v x)
treeToList = treeToList' (:: [])
  where
    -- explicit quantification to avoid conflation with {n} from treeToList
    treeToList' : {0 n : Nat} -> ((x : k ** v x) -> List (x : k ** v x)) -> Tree n k v o -> List (x : k ** v x)
    treeToList' cont (Leaf k v) = cont (k ** v)
    treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1
    treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

----------------------
--- User interface ---
----------------------

export
data SortedDMap : (k : Type) -> (v : k -> Type) -> Type where
  Empty : Ord k => SortedDMap k v
  M : (o : Ord k) => (n : Nat) -> Tree n k v o -> SortedDMap k v

export
empty : Ord k => SortedDMap k v
empty = Empty

export
lookup : (x : k) -> SortedDMap k v -> Maybe (y : k ** v y) -- could return also `So (x == y)`
lookup _ Empty = Nothing
lookup k (M _ t) = treeLookup k t

export
lookupPrecise : DecEq k => (x : k) -> SortedDMap k v -> Maybe (v x)
lookupPrecise x = lookup x >=> \(y ** v) =>
  case decEq x y of
    Yes Refl => Just v
    No _     => Nothing

export
insert : (x : k) -> v x -> SortedDMap k v -> SortedDMap k v
insert k v Empty = M Z (Leaf k v)
insert k v (M _ t) =
  case treeInsert k v t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
singleton : Ord k => (x : k) -> v x -> SortedDMap k v
singleton k v = insert k v empty

export
insertFrom : Foldable f => f (x : k ** v x) -> SortedDMap k v -> SortedDMap k v
insertFrom = flip $ foldl $ flip $ uncurry insert

export
delete : k -> SortedDMap k v -> SortedDMap k v
delete _ Empty = Empty
delete k (M Z t) =
  case treeDelete Z k t of
    Left t' => (M _ t')
    Right () => Empty
delete k (M (S n) t) =
  case treeDelete (S n) k t of
    Left t' => (M _ t')
    Right t' => (M _ t')

export
fromList : Ord k => List (x : k ** v x) -> SortedDMap k v
fromList = foldl (flip (uncurry insert)) empty

export
toList : SortedDMap k v -> List (x : k ** v x)
toList Empty = []
toList (M _ t) = treeToList t

||| Gets the keys of the map.
export
keys : SortedDMap k v -> List k
keys = map fst . toList

export
values : SortedDMap k v -> List (x : k ** v x)
values = toList

treeMap : ({x : k} -> a x -> b x) -> Tree n k a o -> Tree n k b o
treeMap f (Leaf k v) = Leaf k (f v)
treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)
treeMap f (Branch3 t1 k1 t2 k2 t3)
    = Branch3 (treeMap f t1) k1 (treeMap f t2) k2 (treeMap f t3)

treeTraverse : Applicative f => ({x : k} -> a x -> f (b x)) -> Tree n k a o -> f (Tree n k b o)
treeTraverse f (Leaf k v) = Leaf k <$> f v
treeTraverse f (Branch2 t1 k t2) =
  Branch2
    <$> treeTraverse f t1
    <*> pure k
    <*> treeTraverse f t2
treeTraverse f (Branch3 t1 k1 t2 k2 t3) =
  Branch3
    <$> treeTraverse f t1
    <*> pure k1
    <*> treeTraverse f t2
    <*> pure k2
    <*> treeTraverse f t3

export
map : ({x : k} -> v x -> w x) -> SortedDMap k v -> SortedDMap k w
map _ Empty = Empty
map f (M _ t) = M _ $ treeMap f t

export
foldl : (acc -> (x : k ** v x) -> acc) -> acc -> SortedDMap k v -> acc
foldl f i = foldl f i . values

export
foldr : ((x : k ** v x) -> acc -> acc) -> acc -> SortedDMap k v -> acc
foldr f i = foldr f i . values

export
foldlM : Monad m => (acc -> (x : k ** v x) -> m acc) -> acc -> SortedDMap k v -> m acc
foldlM f i = foldl (\ma, b => ma >>= flip f b) (pure i)

export
foldMap : Monoid m => (f : (x : k) -> v x -> m) -> SortedDMap k v -> m
foldMap f = foldr ((<+>) . uncurry f) neutral

export
null : SortedDMap k v -> Bool
null Empty   = True
null (M _ _) = False

export
traverse : Applicative f => ({x : k} -> v x -> f (w x)) -> SortedDMap k v -> f (SortedDMap k w)
traverse _ Empty = pure Empty
traverse f (M _ t) = M _ <$> treeTraverse f t

||| Merge two maps. When encountering duplicate keys, using a function to combine the values.
||| Uses the ordering of the first map given.
export
mergeWith : DecEq k => ({x : k} -> v x -> v x -> v x) -> SortedDMap k v -> SortedDMap k v -> SortedDMap k v
mergeWith f x y = insertFrom inserted x where
  inserted : List (x : k ** v x)
  inserted = do
    (k ** v) <- toList y
    let v' = (maybe id f $ lookupPrecise k x) v
    pure (k ** v')

||| Merge two maps using the Semigroup (and by extension, Monoid) operation.
||| Uses mergeWith internally, so the ordering of the left map is kept.
export
merge : DecEq k => ({x : k} -> Semigroup (v x)) => SortedDMap k v -> SortedDMap k v -> SortedDMap k v
merge = mergeWith (<+>)

||| Left-biased merge, also keeps the ordering specified  by the left map.
export
mergeLeft : DecEq k => SortedDMap k v -> SortedDMap k v -> SortedDMap k v
mergeLeft = mergeWith const

treeLeftMost : Tree n k v o -> (x : k ** v x)
treeLeftMost (Leaf x y) = (x ** y)
treeLeftMost (Branch2 x _ _) = treeLeftMost x
treeLeftMost (Branch3 x _ _ _ _) = treeLeftMost x

treeRightMost : Tree n k v o -> (x : k ** v x)
treeRightMost (Leaf x y) = (x ** y)
treeRightMost (Branch2 _ _ x) = treeRightMost x
treeRightMost (Branch3 _ _ _ _ x) = treeRightMost x

treeLookupBetween : Ord k => k -> Tree n k v o -> (Maybe (x : k ** v x), Maybe (x : k ** v x))
treeLookupBetween k (Leaf k' v) with (k < k')
  treeLookupBetween k (Leaf k' v) | True = (Nothing, Just (k' ** v))
  treeLookupBetween k (Leaf k' v) | False = (Just (k' ** v), Nothing)
treeLookupBetween k (Branch2 t1 k' t2) with (k < k')
  treeLookupBetween k (Branch2 t1 k' t2) | True = -- k < k'
    let (lower, upper) = treeLookupBetween k t1 in
    (lower, upper <|> pure (treeLeftMost t2))
  treeLookupBetween k (Branch2 t1 k' t2) | False = -- k >= k'
    let (lower, upper) = treeLookupBetween k t2 in
    (lower <|> pure (treeRightMost t1), upper)
treeLookupBetween k (Branch3 t1 k1 t2 k2 t3) with (k < k1)
  treeLookupBetween k (Branch3 t1 k1 t2 k2 t3) | True = treeLookupBetween k (Branch2 t1 k1 t2)
  treeLookupBetween k (Branch3 t1 k1 t2 k2 t3) | False with (k < k2)
    treeLookupBetween k (Branch3 t1 k1 t2 k2 t3) | False | False = treeLookupBetween k (Branch2 t2 k2 t3)
    treeLookupBetween k (Branch3 t1 k1 t2 k2 t3) | False | True = --k1 <= k < k2
      let (lower, upper) = treeLookupBetween k (Branch2 t1 k1 t2) in
      (lower, upper <|> pure (treeLeftMost t3))

||| looks up a key in map, returning the left and right closest values, so that
|||  k1 <= k < k2. If at the end of the beginning and/or end of the sorted map, returns
||| nothing appropriately
export
lookupBetween : k -> SortedDMap k v -> (Maybe (x : k ** v x), Maybe (x : k ** v x))
lookupBetween k Empty = (Nothing, Nothing)
lookupBetween k (M _ t) = treeLookupBetween k t

||| Returns the leftmost (least) key and value
export
leftMost : SortedDMap k v -> Maybe (x : k ** v x)
leftMost Empty = Nothing
leftMost (M _ t) = Just $ treeLeftMost t

||| Returns the rightmost (greatest) key and value
export
rightMost : SortedDMap k v -> Maybe (x : k ** v x)
rightMost Empty = Nothing
rightMost (M _ t) = Just $ treeRightMost t

export
(Show k, {x : k} -> Show (v x)) => Show (SortedDMap k v) where
   show m = "fromList " ++ (show $ toList m)

export
(DecEq k, {x : k} -> Eq (v x)) => Eq (SortedDMap k v) where
  (==) = (==) `on` toList

export
strictSubmap : DecEq k => ({x : k} -> Eq (v x)) => (sub : SortedDMap k v) -> (sup : SortedDMap k v) -> Bool
strictSubmap sub sup = all (\(k ** v) => Just v == lookupPrecise k sup) $ toList sub

-- TODO: is this the right variant of merge to use for this? I think it is, but
-- I could also see the advantages of using `mergeLeft`. The current approach is
-- strictly more powerful I believe, because `mergeLeft` can be emulated with
-- the `First` monoid. However, this does require more code to do the same
-- thing.
export
DecEq k => ({x : k} -> Semigroup (v x)) => Semigroup (SortedDMap k v) where
  (<+>) = merge

||| For `neutral <+> y`, y is rebuilt in `Ord k`, so this is not a "strict" Monoid.
||| However, semantically, it should be equal.
export
DecEq k => Ord k => ({x : k} -> Semigroup (v x)) => Monoid (SortedDMap k v) where
  neutral = empty


module Circuits.NetList.Check

import Decidable.Equality

import Data.Nat
import Data.String
import Data.List.Elem
import Data.List.Quantifiers
import Data.Fin

import Toolkit.Decidable.Informative

import Toolkit.Data.Location
import Toolkit.Data.Whole
import Toolkit.Data.List.DeBruijn

import Ref

import Circuits.NetList.Types
import Circuits.NetList.Terms
import Circuits.NetList.AST

%default total

data Entry : (String,Ty) -> Type where
  MkEntry : (name : String)
         -> (type : Ty)
                 -> Entry (MkPair name type)

Env : List (String,Ty) -> Type
Env = Env (String,Ty) Entry

export
data Error = Mismatch Ty Ty
           | MismatchD DType DType
           | NotBound String
           | VectorExpected
           | PortChanExpected
           | PortExpected
           | OOB Nat Nat
           | ErrI String
           | Err FileContext Error
export
Show Error where
  show (Mismatch x y)
    = "Type Mismatch:\n\n"
      <+>
      unlines [unwords ["\tExpected:",show x], unwords ["\tGiven:", show y]]

  show (MismatchD x y)
    = "Type Mismatch:\n\n"
      <+>
      unlines [unwords ["\tExpected:",show x], unwords ["\tGiven:", show y]]

  show (NotBound x)
    = unwords ["Undeclared variable:", x]

  show (VectorExpected)
    = "Vector Expected"

  show (PortChanExpected)
    = "Port or Wire Expected"

  show (PortExpected)
    = "Port Expected"

  show (ErrI msg)
    = "Internal Err: " <+> msg
  show (OOB x y)
    = unwords ["Out of Bounds:" , show x, "is not within", show y]

  show (Err x y) = unwords [show x, show y]

strip : {ctxt : List (String, Ty)}
     -> Elem (s,type) ctxt -> Elem type (map Builtin.snd ctxt)
strip Here = Here
strip (There x) = There (strip x)

public export
TyCheck : Type -> Type
TyCheck = Either Error

lift : Dec a -> Error -> TyCheck a
lift (Yes prf) _ = Right prf
lift (No contra) e = Left e

namespace Elab

  export
  getDataType : FileContext
             -> (term : (type ** Term ctxt type))
                     -> TyCheck DType
  getDataType fc (MkDPair (TyPort (d,x)) snd) = pure x
  getDataType fc (MkDPair (TyChan x) snd) = pure x
  getDataType fc (MkDPair type snd)
    = Left (Err fc PortChanExpected)

  ||| Need to make sure that the indices are in the correct direction.
  rewriteTerm : Cast flow expected
             -> Index INOUT
             -> Term ctxt (TyPort (flow,type))
             -> Term ctxt (TyPort (flow,type))
  rewriteTerm c d (Var prf) = Var prf

  rewriteTerm BI (UP UB) (Index idir what idx)
    = Index (UP UB) (rewriteTerm BI (UP UB) what) idx

  rewriteTerm BI (DOWN DB) (Index idir what idx)
    = Index (DOWN DB) (rewriteTerm BI (DOWN DB) what) idx

  rewriteTerm BO (UP UB) (Index idir what idx)
    = Index (UP UB) (rewriteTerm BI (UP UB) what) idx

  rewriteTerm BO (DOWN DB) (Index idir what idx)
    = Index (DOWN DB) (rewriteTerm BI (DOWN DB) what) idx

  rewriteTerm BI _ (Project WRITE _) impossible
  rewriteTerm BO _ (Project WRITE _) impossible
  rewriteTerm BI _ (Project READ _) impossible
  rewriteTerm BO _ (Project READ _) impossible

  rewriteTerm BI _ (Cast BI _) impossible
  rewriteTerm BO _ (Cast BI _) impossible
  rewriteTerm BI _ (Cast BO _) impossible
  rewriteTerm BO _ (Cast BO _) impossible

  ||| When casting we finally know which direction indexing should go, so lets fix that.
  shouldCast : {type : DType}
            -> (flow,expected : Direction)
            -> (term : Term ctxt (TyPort (flow,type)))
                    -> Dec ( Cast flow expected
                           , Term ctxt (TyPort (expected,type))
                           )
  shouldCast flow expected term with (Cast.cast flow expected)
    shouldCast INOUT INPUT term | (Yes BI) with (dirFromCast BI)
      shouldCast INOUT INPUT term | (Yes BI) | idir
        = Yes $ MkPair BI (Cast BI (rewriteTerm BI idir term))

    shouldCast INOUT OUTPUT term | (Yes BO) with (dirFromCast BO)
      shouldCast INOUT OUTPUT term | (Yes BO) | idir
        = Yes $ MkPair BO (Cast BO (rewriteTerm BO idir term))

    shouldCast flow expected term | (No contra)
      = No (\(prf,t) => contra prf)

  portCast : {type : DType}
        -> {flow : Direction}
        -> FileContext
        -> (expected : Direction)
        -> (term : Term ctxt (TyPort (flow,type)))
                -> TyCheck (Term ctxt (TyPort (expected,type)))

  portCast {type} {flow = flow} fc exp term with (shouldCast flow exp term)
    portCast {type} {flow = flow} fc exp term | Yes (p,e)
      = Right e
    portCast {type} {flow = flow} fc exp term | No contra with (decEq flow exp)
      portCast {type} {flow = exp} fc exp term | No contra | (Yes Refl)
        = Right term
      portCast {type} {flow = flow} fc exp term | No contra | (No f)
        = Left (Err fc (Mismatch (TyPort (exp,type)) (TyPort (flow,type))))

  export
  checkPort : (fc    : FileContext)
           -> (exdir : Direction)
           -> (expty : DType)
           -> (term  : (type ** Term ctxt type))
                    -> TyCheck (Term ctxt (TyPort (exdir,expty)))

  -- [ NOTE ]
  --
  checkPort fc exdir exty (MkDPair (TyPort (given,x)) term)
    = do Refl <- lift (decEq exty x)
                      (Err fc (MismatchD exty x))

         portCast fc exdir term

  -- [ NOTE ]
  --
  -- READ implies INPUT
  checkPort fc INPUT exty (MkDPair (TyChan x) term)
    = do Refl <- lift (decEq exty x)
                      (Err fc (MismatchD exty x))

         pure (Project READ term)

  -- [ NOTE ]
  --
  -- WRITE implies OUTPUT
  checkPort fc OUTPUT exty (MkDPair (TyChan x) term)
    = do Refl <- lift (decEq exty x)
                      (Err fc (MismatchD exty x))

         Right (Project WRITE term)

  -- [ NOTE ]
  --
  -- INOUT Chan's impossible.
  checkPort fc INOUT exty (MkDPair (TyChan x) term)
     = Left (Err fc (ErrI "INOUT CHAN not expected"))

  -- [ NOTE ]
  --
  -- Gates/TyUnit not expected
  checkPort fc exdir exty (MkDPair type term)
     = Left (Err fc (Mismatch (TyPort (exdir,exty)) type))

  export
  indexDir : {flow : Direction}
          -> (fc   : FileContext)
          -> (term : Term ctxt (TyPort (flow,BVECT (W (S n) ItIsSucc) type)))
                  -> TyCheck (Index flow)
  indexDir {flow} fc term with (flow)
    indexDir {flow = flow} fc term | INPUT
      = pure (DOWN DI)
    indexDir {flow = flow} fc term | OUTPUT
      = pure (UP UO)
    indexDir {flow = flow} fc (Var prf) | INOUT
      = pure (UP UB)
    indexDir {flow = flow} fc (Index idir what idx) | INOUT
      = pure idir
    indexDir {flow = flow} fc (Project how what) | INOUT
      = Left (Err fc (ErrI "Shouldn't happen impossible indexing a projection with inout"))
    indexDir {flow = flow} fc (Cast x what) | INOUT
      = Left (Err fc (ErrI "Shouldn't happen impossible indexing a cast with inout"))

namespace TypeCheck
  export
  typeCheck : {ctxt : List (String,Ty)}
           -> (curr : Env ctxt)
           -> (ast  : AST)
                    -> TyCheck (DPair Ty (Term (map Builtin.snd ctxt)))

  typeCheck {ctxt} curr (Var x)
    = do (ty ** prf) <- lift (isIndex (get x) ctxt)
                             (Err (span x) (NotBound (get x)))

         pure (ty ** Var (strip prf))

  typeCheck curr (Port fc flow ty n body)
    = do (TyUnit ** term) <- typeCheck (MkEntry (get n) (TyPort (flow,ty))::curr) body
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

         pure (_ ** Port flow ty term)

  typeCheck curr (Wire fc ty n body)
    = do (TyUnit ** term) <- typeCheck (MkEntry (get n) (TyChan ty)::curr) body
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

         pure (_ ** Wire ty term)

  typeCheck curr (GateDecl fc n g body)
    = do (TyGate ** gate) <- typeCheck curr g
           | (type ** _) => Left (Err fc (Mismatch TyGate type))

         (TyUnit ** term) <- typeCheck (MkEntry (get n) (TyGate)::curr) body
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

         pure (_ ** GateDecl gate term)

  typeCheck curr (Assign fc i o rest)
    =  do termI <- typeCheck curr i

          ity <- getDataType fc termI

          termO <- typeCheck curr o
          oty <- getDataType fc termO

          Refl <- lift (decEq ity oty)
                       (Err fc (MismatchD ity oty))

          i' <- checkPort fc INPUT  ity termI
          o' <- checkPort fc OUTPUT ity termO

          (TyUnit ** r') <- typeCheck curr rest
           | (type ** _) => Left (Err fc (Mismatch TyUnit type))

          pure (_ ** Assign i' o' r')

  typeCheck curr (Mux fc o c l r)
    = do termO <- typeCheck curr o
         termC <- typeCheck curr c
         termL <- typeCheck curr l
         termR <- typeCheck curr r

         o' <- checkPort fc OUTPUT LOGIC termO
         c' <- checkPort fc INPUT  LOGIC termC
         l' <- checkPort fc INPUT  LOGIC termL
         r' <- checkPort fc INPUT  LOGIC termR

         pure (_ ** Mux o' c' l' r')

  typeCheck curr (GateU fc k o i)
    = do termO <- typeCheck curr o
         termI <- typeCheck curr i

         o' <- checkPort fc OUTPUT LOGIC termO
         i' <- checkPort fc INPUT  LOGIC termI

         pure (_ ** GateU k o' i')

  typeCheck curr (GateB fc k o l r)

    = do termO <- typeCheck curr o
         termL <- typeCheck curr l
         termR <- typeCheck curr r

         o' <- checkPort fc OUTPUT LOGIC termO
         l' <- checkPort fc INPUT  LOGIC termL
         r' <- checkPort fc INPUT  LOGIC termR

         pure (_ ** GateB k o' l' r')

  typeCheck curr (Index fc idx t)

    = do (TyPort (flow,BVECT (W (S n) ItIsSucc) type) ** term) <- typeCheck curr t
           | (type ** term)
               => Left (Err fc VectorExpected)

         case natToFin idx (S n) of
           Nothing => Left (OOB idx (S n))
           Just idx' => do idir <- indexDir fc term
                           pure (_ ** Index idir term idx')

  typeCheck curr (Split fc a b i)

    = do termA <- typeCheck curr a
         termB <- typeCheck curr b
         termI <- typeCheck curr i

         a' <- checkPort fc OUTPUT LOGIC termA
         b' <- checkPort fc OUTPUT LOGIC termB
         i' <- checkPort fc INPUT  LOGIC termI

         pure (_ ** Split a' b' i')

  typeCheck curr (Collect fc o l r)
    = do (TyPort (OUTPUT,BVECT (W (S (S Z)) ItIsSucc) type) ** o') <- typeCheck curr o
           | (TyPort (flow,BVECT (W (S (S n)) ItIsSucc) type) ** term)
               => Left (Err fc (Mismatch (TyPort (OUTPUT, BVECT (W (S (S Z)) ItIsSucc) type))
                                         (TyPort (flow,   BVECT (W (S (S n)) ItIsSucc) type))
                                         ))
           | (type ** term)
               => Left (Err fc VectorExpected)

         termL <- typeCheck curr l
         termR <- typeCheck curr r

         l' <- checkPort fc INPUT  type termL
         r' <- checkPort fc INPUT  type termR

         pure (_ ** Collect o' l' r')

  typeCheck curr (Shim fc dir thing)

    = do t <- typeCheck curr thing

         dtype <- getDataType fc t

         term <- checkPort fc dir dtype t

         pure (_ ** term)

  typeCheck curr (Stop x)
    = pure (_ ** Stop)

namespace Design
  export
  typeCheck : (ast : AST) -> TyCheck (Term Nil TyUnit)
  typeCheck ast with (typeCheck Nil ast)
    typeCheck ast | (Left x) = Left x
    typeCheck ast | (Right (MkDPair TyUnit term)) = Right term
    typeCheck ast | (Right (MkDPair ty snd)) = Left (Mismatch TyUnit ty)

  export
  typeCheckIO : (ast : AST) -> IO (TyCheck (Term Nil TyUnit))
  typeCheckIO ast = pure (typeCheck ast)

-- [ EOF ]


module Circuits.Idealised.Check

import Decidable.Equality

import Data.Nat
import Data.String
import Data.List.Elem
import Data.List.Quantifiers
import Data.DPair

import Toolkit.Decidable.Informative
import Toolkit.Decidable.Equality.Views

import Toolkit.Data.Graph.EdgeBounded
import Toolkit.Data.Whole
import Toolkit.Data.Location
import Toolkit.Data.DList

import Toolkit.Data.List.AtIndex
import Toolkit.DeBruijn.Context.Item
import Toolkit.DeBruijn.Context
import Toolkit.DeBruijn.Renaming

import Circuits.Split
import Circuits.Idealised.Core
import Circuits.Idealised.Types
import Circuits.Idealised.Terms
import Circuits.Idealised.AST

%default total

public export
Context : List (Ty, Usage) -> Type
Context = Context (Ty,Usage)

namespace FreeVar

  public export
  data IsFree : (item : (Ty, Usage)) -> Type
    where
      FVar : (prf : u = FREE)
                 -> IsFree (type, u)

  Uninhabited (IsFree (ty,USED)) where
    uninhabited (FVar Refl) impossible

  isFree : (item : (Ty, Usage))
                -> DecInfo ()
                           (IsFree item)
  isFree (ty, USED)
    = No () absurd

  isFree (ty, FREE)
    = Yes (FVar Refl)

  public export
  FreeVar : {types : List (Ty, Usage)}
         -> (key   : String)
         -> (ctxt  : Context types)
                  -> Type
  FreeVar str ctxt
   = Exists (Ty,Usage)
            IsFree
            str
            ctxt

  export
  lookup : {types : List (Ty, Usage)}
        -> (str  : String)
        -> (ctxt : Context types)
                -> DecInfo (Exists.Error ())
                           (FreeVar str ctxt)
  lookup = exists isFree

use : (ctxt : Context curr)
   -> (use  : Use curr prf next)
           -> Context next
use (I k (ty,FREE) :: rest) H
  = I k (ty, USED) :: rest

use (head :: tail) (T later)
  = head :: use tail later

isUsed : (ctxt : Context types)
              -> Dec (All Used types)
isUsed []
  = Yes []

isUsed ((I name x) :: tail) with (used x)
  isUsed ((I name x) :: tail) | (Yes pH) with (isUsed tail)
    isUsed ((I name x) :: tail) | (Yes pH) | (Yes pT)
      = Yes (pH :: pT)

    isUsed ((I name x) :: tail) | (Yes pH) | (No contra)
      = No (\(a::as) => contra as)

  isUsed ((I name x) :: tail) | (No contra)
    = No (\(a::as) => contra a)

withLocThrow : FileContext -> Check.Error -> Idealised a
withLocThrow fc e = throw (TyCheck $ Err fc e)

throw : Check.Error -> Idealised a
throw = (throw . TyCheck)

public export
allEqual : FileContext
        -> (a,b,c : DType)
                 -> Idealised (AllEqual a b c)
allEqual fc a b c with (Views.allEqual a b c)
  allEqual fc c c c | (Yes AE)
    = pure AE
  allEqual fc a b c | (No AB prfWhyNot)
    = withLocThrow fc (MismatchGate a b)
  allEqual fc a b c | (No AC prfWhyNot)
    = withLocThrow fc (MismatchGate a c)

data Result : (curr : List (Ty,Usage))
           -> Type
  where
    R : {cout : _}
     -> (type : Ty)
     -> (new  : Context cout)
     -> (term : Term cin type cout)
             -> Result cin

check : {cin  : List (Ty,Usage)}
     -> (curr : Context cin)
     -> (ast  : AST)
             -> Idealised (Result cin)

check curr (Var x) with (FreeVar.lookup (get x) curr)
  check curr (Var x) | (Yes (E type item prf locC locN)) with (prf)
    check curr (Var x) | (Yes (E (type, u) item prf locC locN)) | (FVar prf1) with (prf1)
      check curr (Var x) | (Yes (E (type, FREE) item prf locC locN)) | (FVar prf1) | Refl with (use (V _ locN))
        check curr (Var x) | (Yes (E (type, FREE) item prf locC locN)) | (FVar prf1) | Refl | (MkDPair next pU) with (use curr pU)
          check curr (Var x) | (Yes (E (type, FREE) item prf locC locN)) | (FVar prf1) | Refl | (MkDPair next pU) | new
            = pure (R type new (Var (V _ locN) pU))

  check curr (Var x) | (No msg _)
    = withLocThrow (span x) (ElemFail (get x) msg)

check curr (Input fc x y name body)

  = do R TyUnit Nil body <- check (I (get name) ((TyPort (MkPair x y)),FREE) :: curr)
                                    body
           | R ty Nil _ => throw (Mismatch TyUnit ty)
           | R _  xs  _ => withLocThrow fc (LinearityError xs)

       pure (R TyUnit Nil (NewSignal x y body))

check curr (Wire fc type a b body)

  = do R TyUnit Nil term <- check (I (get a) ((TyPort (MkPair OUTPUT type)), FREE) ::
                                   I (get b) ((TyPort (MkPair INPUT  type)), FREE) :: curr)
                                  body
           | R ty Nil _ => throw (Mismatch TyUnit ty)
           | R ty xs  _ => withLocThrow fc (LinearityError xs)

       pure (R TyUnit Nil (Wire type term))

check curr (Seq x y)
  = do R TyGate ex x <- check curr x
         | R ty _ _ => throw (Mismatch TyGate ty)

       R TyUnit Nil y <- check ex y
         | R ty Nil _ => throw (Mismatch TyUnit ty)
         | R ty xs  _ => throw (LinearityError xs)

       pure (R TyUnit Nil (Seq x y))

check curr (Mux fc o c a b)
  = do R (TyPort (OUTPUT,dtypeA)) cO o <- check curr o
         | _ => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,LOGIC)) cC c <- check cO c
         | R ty _ _ => withLocThrow fc (Mismatch (TyPort (INPUT,LOGIC)) ty)

       R (TyPort (INPUT,dtypeB)) cA a <- check cC a
         | _ => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,dtypeC)) cB b <- check cA b
         | _ => withLocThrow fc (PortExpected OUTPUT)

       AE <- allEqual fc dtypeA dtypeB dtypeC

       pure (R TyGate cB (Mux o c a b))

check curr (Dup fc a b i)
  = do R (TyPort (OUTPUT,dtypeA)) cA a <- check curr a
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,dtypeB)) cB b <- check cA b
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,dtypeC)) cI i <- check cB i
         | ty => withLocThrow fc (PortExpected INPUT)

       AE <- allEqual fc dtypeA dtypeB dtypeC

       pure (R TyGate cI (Dup a b i))

check curr (Not fc a b)
  = do R (TyPort (OUTPUT,LOGIC)) cA a <- check curr a
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,LOGIC)) cB b <- check cA b
         | ty => withLocThrow fc (PortExpected INPUT)

       pure (R TyGate cB (Not a b))

check curr (Gate fc k a b c)
  = do R (TyPort (OUTPUT,LOGIC)) cA a <- check curr a
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,LOGIC)) cB b <- check cA b
         | ty => withLocThrow fc (PortExpected INPUT)

       R (TyPort (INPUT,LOGIC)) cC c <- check cB c
         | ty => withLocThrow fc (PortExpected INPUT)

       pure (R TyGate cC (Gate k a b c))

check curr (IndexS fc o i)
  = do R (TyPort (OUTPUT,dtypeO)) cO termO <- check curr o
         | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,BVECT (W (S Z) ItIsSucc) dtypeI)) cI termI <- check cO i
         | R (TyPort (INPUT, BVECT s type)) _ _
             => withLocThrow fc (Mismatch (TyPort (INPUT, BVECT (W (S Z) ItIsSucc) type))
                                          (TyPort (INPUT, BVECT s type)))
         | ty => withLocThrow fc (PortExpected INPUT)

       Refl <- embed (TyCheck $ Err fc (MismatchGate dtypeO  dtypeI))
                     (decEq dtypeO dtypeI)

       pure (R TyGate cI (IndexSingleton termO termI))

check curr (IndexE fc k a b i)

  = do R (TyPort (OUTPUT,dtypeA)) cA termA <- check curr a
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,BVECT free dtypeB)) cB termB <- check cA b
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,BVECT size dtypeC)) cI termI <- check cB i
                  | ty => withLocThrow fc (PortExpected INPUT)

       AE <- allEqual fc dtypeA dtypeB dtypeC

       let p = case k of { F => minus (toNat size) 1; L => 0}

       (s ** prf) <- embed (const $ TyCheck $ Err fc (NotEdgeCase (InvalidEdge (toNat size) (S Z) (toNat free))))
                           (EdgeCase.index size p)

       Refl <- embed (TyCheck $ Err fc (NotEdgeCase (InvalidEdge (toNat size) (S Z) (toNat free))))
                     (decEq free s)

       pure (R TyGate cI (IndexEdge p prf termA termB termI))

check curr (IndexP fc p a b c i)
  = do R (TyPort (OUTPUT,dtypeA)) cA termA <- check curr a
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,BVECT freeB dtypeB)) cB termB <- check cA b
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (OUTPUT,BVECT freeC dtypeC)) cC termC <- check cB c
                  | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT,BVECT size dtypeD)) cI termI <- check cC i
                  | ty => withLocThrow fc (PortExpected INPUT)

       Refl <- embed (TyCheck $ Err fc (MismatchGate dtypeA (BVECT freeB dtypeB)))
                     (decEq dtypeA dtypeB)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT freeB dtypeB) (BVECT freeC dtypeC)))
                     (decEq dtypeB dtypeC)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT freeC dtypeC) (BVECT size dtypeD)))
                     (decEq dtypeC dtypeD)

       (a ** b ** prf) <- embed (const $ TyCheck $ Err fc (NotEdgeCase (InvalidSplit p (toNat size) (toNat freeB) (toNat freeC))))
                                (Pivot.index p size)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT a     dtypeB)
                                                     (BVECT freeB dtypeB)))
                     (decEq freeB a)

       Refl <- embed (TyCheck $ Err fc (MismatchGate (BVECT b     dtypeB)
                                                     (BVECT freeC dtypeB)))
                     (decEq freeC b)

       pure (R TyGate cI (IndexSplit p prf termA termB termC termI))

check curr (MergeS fc o i)

  = do R (TyPort (OUTPUT,BVECT (W (S Z) ItIsSucc) dtypeO)) cO termO <- check curr o
           | R (TyPort (INPUT, BVECT s type)) _ _
                => withLocThrow fc (Mismatch (TyPort (OUTPUT, BVECT (W (S Z) ItIsSucc) type))
                                             (TyPort (INPUT,  BVECT s                  type)))
           | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT, dtypeI)) cI termI <- check cO i
           | ty => withLocThrow fc (PortExpected INPUT)

       Refl <- embed (TyCheck $ Err fc (MismatchGate dtypeO dtypeI))
                     (decEq dtypeO dtypeI)

       pure (R TyGate cI (MergeSingleton termO termI))

check curr (MergeV fc o a b)

  = do R (TyPort (OUTPUT, dtypeO)) cO termO <- check curr o
           | ty => withLocThrow fc (PortExpected OUTPUT)

       R (TyPort (INPUT, dtypeA)) cA termA <- check cO a
           | ty => withLocThrow fc (PortExpected INPUT)

       R (TyPort (INPUT, dtypeB)) cB termB <- check cA b
           | ty => withLocThrow fc (PortExpected INPUT)

       case Views.allEqual LOGIC dtypeA dtypeB of
         Yes AE
           => do Refl <- embed (TyCheck (Err fc (MismatchGate (BVECT (W (S (S Z)) ItIsSucc) LOGIC)
                                                              dtypeO)))
                               (decEq dtypeO (BVECT (W (S (S Z)) ItIsSucc) LOGIC))

                 pure (R TyGate cB (Merge2L2V termO termA termB))
         No msg prf
           => case dtypeO of
                LOGIC => withLocThrow fc VectorExpected
                BVECT sO tO
                  => case dtypeA of
                       LOGIC => withLocThrow fc VectorExpected
                       BVECT sA tA
                         => case dtypeB of
                              LOGIC => withLocThrow fc VectorExpected
                              BVECT sB tB
                                => do prfS <- embed (TyCheck (Err fc (VectorSizeMismatch sO sA sB)))
                                                    (isPlus sA sB sO)

                                      AE <- allEqual fc tO tA tB

                                      pure (R TyGate cB (Merge2V2V prfS termO termA termB))

check curr (Stop fc)
  = do prf <- embed (TyCheck (Err fc (LinearityError curr)))
                    (isUsed curr)

       pure (R TyUnit Nil (Stop prf))

namespace Design

  export
  check : (ast : AST)
              -> Idealised (Term Nil TyUnit Nil)
  check ast
    = do R TyUnit Nil term <- check Nil ast
           | R ty _ _ => throw (TyCheck (Mismatch TyUnit ty))
         pure term

-- [ EOF ]


module Data.Bytes.Strict.API

import public Data.Bytes.Strict.Internal
import public Data.Bytes.Prim
import        Data.Bytes.Util

import Data.Word.Word8

import Data.List -- List.drop

moduleName : String
moduleName = "Data.Bytes.Strict.API"

%hide Prelude.empty

%default total

---------------------------------------------------------------------
-- Documentation
---------------------------------------------------------------------
{-

Pretty standard (strict) ByteString kind of stuff. Some operations have `'`
(prime) versions with slightly different behavior for convenience. In
particular operations which require `NonEmpty` proof have their `'` versions
give runtime errors on bad inputs instead. And things like replicate' use Int
instead of Nat.

This is to support what I consider the Idris community spirit: be provably safe
when it can be made convenient, but don't force anyone to jump through hoops.
I'm sure there's better wording for that though.

Included are some intended complexity values. They might be a lie since I don't
understand complexity very well. Hopefully they're in the ballpark, which is
all big-o is anyway.

Open Design Questions:

Is there a reason to allow negative position values in a Bytes? If we were
using pointers there might be some cute things we could do with that but
overall it doesn't really seem useful.
If we can get Nat or Fin to compile to Int, instead of the Integer that Nat
compiles to, then Nat for both fields of Bytes makes sense.

https://hackage.haskell.org/package/bytestring-0.10.10.0/docs/src/Data.ByteString.Internal.html#concat
Should helpers take all their arguments explicitly to avoid capturing as much
in closures? Does this even happen in idris?

Should things like replicate and unfoldrN simply cast their Nat and then call
to replicate'/unfoldrN' ? If that's the case is there any advantage to
providing them, aside from reducing cast noise for users?

Should functions that return List return lazy Lists?

If you feel something is missing from the API it might not be! Internal modules
implement common interfaces, be sure to check there first. e.g. <+>
-}

-- All of this will get fancier as Idris2 gains support for documentation
-- generation.

---------------------------------------------------------------------
-- API
---------------------------------------------------------------------

-------------------------------------------------
-- Barebones basic Bytes
-------------------------------------------------

-- Intended complexity: O(1)
export
empty : Bytes
empty = neutral

-- Intended complexity: O(1)
-- Provides NonEmpty
export
singleton : Word8 -> Bytes
singleton w = unsafeCreateBytes 1 $ \p => setByte p 0 w

private
packLenBytes : Int -> List Word8 -> Bytes
packLenBytes len xs0
    = unsafeCreateBytes len $ \b => go 0 b xs0
  where
    go : Int -> MutBlock -> List Word8 -> IO ()
    go p buf [] = pure ()
    go p buf (x::xs) = setByte buf p x *> go (p+1) buf xs

-- Intended complexity: O(n)
export
pack : List Word8 -> Bytes
pack xs = packLenBytes (cast (length xs)) xs

-- Intended complexity: O(n)
export
unpack : Bytes -> List Word8
unpack (MkB fp pos len) =
  take (intToNat len) . drop (intToNat pos)
                      . unsafePerformIO . blockData $ fp

-------------------------------------------------
-- Basic interface
-------------------------------------------------

-- Intended complexity: O(1)
total
length : Bytes -> Int
length (MkB _ _ len) = len

-- Intended complexity: O(1)
export
total
null : Bytes -> Bool
null buf = 0 >= length buf

-- Intended complexity: O(1)
export
cons : Word8 -> Bytes -> Bytes
cons x (MkB p0 pos len)
    = do unsafeCreateBytes (1 + len) $ \p => do
         setByte p 0 x
         copyBlock p0 pos len p 1

-- Intended complexity: O(1)
export
snoc : Bytes -> Word8 -> Bytes
snoc (MkB p0 pos len) x
  = unsafeCreateBytes (1 + len) $ \p => do
      copyBlock p0 pos len p 0
      setByte p len x

-- Intended complexity: O(1)
export
head : (b : Bytes) -> NonEmpty b => Word8
head (MkB b pos _) = unsafePerformIO (getByte b pos)

export
partial
head' : (b : Bytes) -> Word8
head' (MkB b pos len) = if 0 >= len
  then errorCall moduleName "head'" "block empty"
  else unsafePerformIO (getByte b pos)

-- Intended complexity: O(1)
export
tail : (b : Bytes) -> NonEmpty b => Bytes
tail (MkB p pos len) = MkB p (1 + pos) (len - 1)

export
partial
tail' : Bytes -> Bytes
tail' (MkB p pos len) = if len > 0
                          then MkB p (1 + pos) (len - 1)
                          else errorCall moduleName "tail'" "block empty"

-- Intended complexity: O(1)
export
uncons : (b : Bytes) -> NonEmpty b => (Word8, Bytes)
uncons bs = (head bs, tail bs)

export
uncons' : Bytes -> Maybe (Word8, Bytes)
uncons' bs@(MkB _ _ len) = if len > 0
                             then Just ( assert_total $ head' bs
                                       , assert_total $ tail' bs)
                             else Nothing

export
partial
uncons'' : Bytes -> (Word8, Bytes)
uncons'' bs@(MkB _ _ len)
  = if len > 0
      then (head' bs, tail' bs)
      else errorCall moduleName "uncons''" "block empty"

-- Intended complexity: O(1)
export
last : (b : Bytes) -> NonEmpty b => Word8
last (MkB p pos len) = unsafePerformIO (getByte p (len + pos - 1))

export
partial
last' : Bytes -> Word8
last' (MkB p pos len) = if len > 0
                          then unsafePerformIO (getByte p (len + pos - 1))
                          else errorCall moduleName "last'" "block empty"

-- Intended complexity: O(1)
export
init : (b: Bytes) -> NonEmpty b => Bytes
init (MkB p pos len) = MkB p pos (len - 1)

export
partial
init' : Bytes -> Bytes
init' (MkB p pos len) = if len > 0
                        then MkB p pos (len - 1)
                        else errorCall moduleName "init'" "block empty"

-- Intended complexity: O(1)
export
unsnoc : (b : Bytes) -> NonEmpty b => (Bytes, Word8)
unsnoc bs = (init bs, last bs)

export
unsnoc' : Bytes -> Maybe (Bytes, Word8)
unsnoc' bs@(MkB _ _ len) = if len > 0
                             then Just ( assert_total $ init' bs
                                       , assert_total $ last' bs)
                             else Nothing

export
partial
unsnoc'' : Bytes -> (Bytes, Word8)
unsnoc'' bs@(MkB _ _ len) = if len > 0
                              then (init' bs, last' bs)
                              else errorCall moduleName "unsnoc''" "block empty"

-------------------------------------------------
-- Transforms
-------------------------------------------------

-- Intended complexity: O(n)
export
reverse : Bytes -> Bytes
reverse b@(MkB buf pos len) = unsafeCreateBytes len $ \new =>
    rev_ 0 (len - 1) new
  where
    rev_ : Int -> Int -> MutBlock -> IO ()
    rev_ p q new = if 0 > q
      then pure ()
      else do
        x <- getByte buf (pos + p)
        setByte new q x
        assert_total $ rev_ (p+1) (q-1) new

sort : Bytes -> Bytes

intersperse : Word8 -> Bytes -> Bytes

intercalate : Bytes -> List Bytes -> Bytes

transpose : List Bytes -> List Bytes

export
stringToBytes : String -> Int -> (Bytes,Int)
stringToBytes str len = unsafeCreateNBytes' len $ \b => do
    (_,r) <- fef b (unpack str) 0
    pure (r,r)
  where
    fef : MutBlock -> List Char -> Int -> IO (MutBlock, Int)
    fef bs [] pos = pure (bs,pos)
    fef bs (c :: cs) pos = if len > pos
      then setByte bs pos (cast (cast {to=Int} c)) *> fef bs cs (pos+1)
      else pure (bs, pos)

-------------------------------------------------
-- Folding
-------------------------------------------------

-- Intended complexity: O(n)
export
foldl : (a -> Word8 -> a) -> a -> Bytes -> a
foldl f v (MkB b pos len)
    = unsafePerformIO $ go v pos (len + pos)
  where
    go : a -> (start : Int) -> (end : Int) -> IO a
    go z p q
      = if p >= q then pure z
                  else assert_total $ go (f z !(getByte b p)) (p+1) q

-- TODO: consider foldl', foldl with a lazy accumulator

foldl1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Word8
foldl1 f b = foldl f (head b) (tail b)

partial
foldl1' : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> Word8
foldl1' f b = foldl f (head' b) (tail'
 b)

-- Intended complexity: O(n)
export
foldr : (Word8 -> a -> a) -> a -> Bytes -> a
foldr f v (MkB bs pos len)
    = unsafePerformIO $ go v pos (len + pos - 1)
  where
    go : a -> (start : Int) -> (end : Int) -> IO a
    go z p q
      = if p > q then pure z
                 else assert_total $ go (f !(getByte bs q) z) p (q-1)

-- TODO: consider foldr', foldr with a lazy accumulator

foldr1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Word8
foldr1 f b = foldr f (last b) (init b)

partial
foldr1' : (Word8 -> Word8 -> Word8) -> Bytes -> Word8
foldr1' f b = foldr f (last' b) (init' b)

concat : List Bytes -> Bytes

concatMap : (Word8 -> Bytes) -> Bytes -> Bytes

-------------------------------------------------
-- Mapping
-------------------------------------------------

-- Intended complexity: O(n)
export
map : (Word8 -> Word8) -> Bytes -> Bytes
map f (MkB b0 pos len)
    = unsafeCreateBytes len $ \new => map_ 0 len new
  where
    map_ : (pos1 : Int) -> (pos2 : Int) -> MutBlock -> IO ()
    map_ p q buf = if p >= q then pure ()
                             else do
                               x <- getByte b0 (pos + p)
                               setByte buf p (f x)
                               assert_total $ map_ (p+1) q buf

-- foldl with a state passed along
mapAccumL : (s -> Word8 -> (s, Word8)) -> s -> Bytes -> (s, Bytes)

-- foldr with a state passed along
mapAccumR : (s -> Word8 -> (s, Word8)) -> s -> Bytes -> (s, Bytes)

-------------------------------------------------
-- Scans
-------------------------------------------------

scanl : (Word8 -> Word8 -> Word8) -> Word8 -> Bytes -> Bytes
scanl1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Bytes
scanl1' : (Word8 -> Word8 -> Word8) -> Bytes -> Bytes

scanr : (Word8 -> Word8 -> Word8) -> Word8 -> Bytes -> Bytes
scanr1 : (Word8 -> Word8 -> Word8) -> (b : Bytes) -> NonEmpty b => Bytes
scanr1' : (Word8 -> Word8 -> Word8) -> Bytes -> Bytes

-------------------------------------------------
-- Generate Bytes
-------------------------------------------------

-- This can be written faster with a primitive like memset, should backends be
-- inclined to provide one?
-- Like replicate for List and elsewhere negative values are treated as 0.
replicate' : Int -> Word8 -> Bytes
replicate' n w = if n > 0
                   then map (const w) $ unsafeCreateBytes n $ (\_ => pure ())
                   else neutral

-- Why does a Nat version exist you ask? To make safety painless. People are
-- hopefully going to be using Nat all over their programs for safety reasons
-- so we want to support that easily. The user littering their code with casts
-- can get tedious so we'll support that for them here. That being said,
-- replicate' exists for when you're using Int anyway and especially if that's
-- due to performance, note that Nat compiles to Integer which (depending on
-- the backend) can be slower than Int.
-- TODO: should this case on Nat or is a cast fine? What does casing gain us?
replicate : Nat -> Word8 -> Bytes
replicate n w = replicate' (cast n) w

unfoldr : (a -> Maybe (Word8, a)) -> a -> Bytes

unfoldrN : Nat -> (a -> Maybe (Word8, a)) -> a -> (Bytes, Maybe a)

unfoldrN' : Int -> (a -> Maybe (Word8, a)) -> a -> (Bytes, Maybe a)

-------------------------------------------------
-- Splitting Bytes
-------------------------------------------------

take' : Int -> Bytes -> Bytes
take  : Nat -> Bytes -> Bytes

drop' : Int -> Bytes -> Bytes
drop  : Nat -> Bytes -> Bytes

splitAt' : Int -> Bytes -> (Bytes, Bytes)
splitAt  : Nat -> Bytes -> (Bytes, Bytes)

takeWhile : (Word8 -> Bool) -> Bytes -> Bytes
dropWhile : (Word8 -> Bool) -> Bytes -> Bytes

span  : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes)
spanEnd  : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes) -- starts from end

-- Should I really provide break when a person can just write not?
-- Might as well, for the same reason that we provide Nat and Int versions.
break : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes)
breakEnd  : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes) -- starts from end

-- potentially faster than groupBy (==), depends how we write this
group : Bytes -> List Bytes

groupBy : (Word8 -> Word8 -> Bool) -> Bytes -> List Bytes

inits : Bytes -> List Bytes
tails : Bytes -> List Bytes

-- TODO: Is this really common enough a need to include?
-- returns 2nd Bytes stripped of 1st Bytes iff 1st is a prefix of 2nd
stripPrefix : Bytes -> Bytes -> Maybe Bytes

-- Same, but from the other end.
stripSuffix : Bytes -> Bytes -> Maybe Bytes

-- split on, and consume, each occurence of Word8
split : Word8 -> Bytes -> List Bytes

-- same as above with predicate to determine delimiter
splitWith : (Word8 -> Bool) -> Bytes -> List Bytes

-------------------------------------------------
-- Predicates
-------------------------------------------------

any : (Word8 -> Bool) -> Bytes -> Bool
all : (Word8 -> Bool) -> Bytes -> Bool

isPrefixOf : Bytes -> Bytes -> Bool
isSuffixOf : Bytes -> Bytes -> Bool
isInfixOf  : Bytes -> Bytes -> Bool

-------------------------------------------------
-- Searches
-------------------------------------------------

-- TODO: needs more fitting name, even though yes we have a string of bytes in
-- memory.
-- Like break but we're breaking on a Bytes instead of a Word8. Examples:
{-
breakSubstring [3,4]     [1,2,3,4,5] ~ ([1,2],[3,4,5])
breakSubstring [3]       [1,2,3,4,5] ~ ([1,2],[3,4,5])
breakSubstring [3,4,5,6] [1,2,3,4,5] ~ ([1,2,3,4,5],[]) -- NB
breakSubstring [6]       [1,2,3,4,5] ~ ([1,2,3,4,5],[])
-}
-- This is likely to be a big player when you go to write parsers for Bytes
breakSubstring : Bytes -> Bytes -> (Bytes, Bytes)

elem : Word8 -> Bytes -> Bool

-- notElem is a common enough need to provide it for users so they don't have
-- to compose `not`
notElem : Word8 -> Bytes -> Bool

maximum :  Bytes -> Word8
minimum :  Bytes -> Word8

find : (Word8 -> Bool) -> Bytes -> Maybe Word8

filter : (Word8 -> Bool) -> Bytes -> Bytes

partition : (Word8 -> Bool) -> Bytes -> (Bytes, Bytes)

-------------------------------------------------
-- Indexing
-------------------------------------------------

-- NB: Best to avoid the Nat returning options until we have a primitive cast
-- for it to Int.

index : Bytes -> Nat -> Word8

index' : Bytes -> Int -> Word8

elemIndex  : Word8 -> Bytes -> Maybe Nat
elemIndex' : Word8 -> Bytes -> Maybe Int

elemIndices  : Word8 -> Bytes -> List Nat
elemIndices' : Word8 -> Bytes -> List Int

elemIndexEnd  : Word8 -> Bytes -> Maybe Nat
elemIndexEnd' : Word8 -> Bytes -> Maybe Int

findIndex  : (Word8 -> Bool) -> Bytes -> Maybe Nat
findIndex' : (Word8 -> Bool) -> Bytes -> Maybe Int

count  : Word8 -> Bytes -> Nat
count' : Word8 -> Bytes -> Int

-------------------------------------------------
-- Zips
-------------------------------------------------

-- analogous to zip for List
zip : Bytes -> Bytes -> List (Word8, Word8)

zipWith : (Word8 -> Word8 -> a) -> Bytes -> Bytes -> List a

unzip : List (Word8, Word8) -> (Bytes, Bytes)


||| SipHash24 copied from C [reference implementation](https://github.com/veorq/SipHash/blob/master/siphash.c)
||| and rust https://doc.rust-lang.org/src/core/hash/sip.rs.html
module Data.Hashable.SipHashV2

import Data.Buffer

%default total

%inline
CROUNDS : Nat
CROUNDS = 2

%inline
DROUNDS : Nat
DROUNDS = 4

record HashState where
    constructor MkST
    v0 : Bits64
    v1 : Bits64
    v2 : Bits64
    v3 : Bits64

initHashState : HashState
initHashState = MkST
    { v0 = 0x736f6d6570736575
    , v1 = 0x646f72616e646f6d
    , v2 = 0x6c7967656e657261
    , v3 = 0x7465646279746573
    }

record PartialHash where
    constructor MkPartial
    tail : Bits64
    index : Bits64
    length : Bits64
    hst : HashState

initPartial : PartialHash
initPartial = MkPartial 0 0 0 initHashState

%inline
shl : Bits64 -> Bits64 -> Bits64
shl = prim__shl_Bits64

%inline
shr : Bits64 -> Bits64 -> Bits64
shr = prim__shr_Bits64

%inline
bor : Bits64 -> Bits64 -> Bits64
bor = prim__or_Bits64

%inline
xor : Bits64 -> Bits64 -> Bits64
xor = prim__xor_Bits64

%inline
and : Bits64 -> Bits64 -> Bits64
and = prim__and_Bits64

%inline
shr16 : Bits16 -> Bits16 -> Bits16
shr16 = prim__shr_Bits16

%inline
shr32 : Bits32 -> Bits32 -> Bits32
shr32 = prim__shr_Bits32

%inline
andInt : Int -> Int -> Int
andInt = prim__and_Int

%inline
%spec b
rotl : Bits64 -> (b : Bits64) -> Bits64
rotl x b = (x `shl` b) `bor` (x `shr` (64 - b))

-- Make the length the smallest multiple of 8 tail >= the given number
%inline
fullSize : Int -> Int
fullSize x =
    let left = x `andInt` 7
     in if (x `andInt` 7) == 0
        then x
        else x - left + 8

compress : HashState -> HashState
compress (MkST v0 v1 v2 v3) =
    let v0 = v0 + v1;
        v1 = v1 `rotl` 13;
        v1 = v1 `xor` v0;
        v0 = v0 `rotl` 32;
        v2 = v2 + v3;
        v3 = v3 `rotl` 16;
        v3 = v3 `xor` v2;
        v0 = v0 + v3;
        v3 = v3 `rotl` 21;
        v3 = v3 `xor` v0;
        v2 = v2 + v1;
        v1 = v1 `rotl` 17;
        v1 = v1 `xor` v2;
        v2 = v2 `rotl` 32;
    in MkST v0 v1 v2 v3

%inline
%spec rounds, f
repeat : (rounds : Nat) -> (f : a -> a) -> a -> a
repeat Z f x = x
repeat (S k) f x = repeat k f (f x)

%inline
hashBits64 : HashState -> Bits64 -> HashState
hashBits64 (MkST v0 v1 v2 v3) m =
    let v3 = v3 `xor` m
        MkST v0 v1 v2 v3 = repeat CROUNDS compress $ MkST v0 v1 v2 v3
        v0 = v0 `xor` m
     in MkST v0 v1 v2 v3

export
finish : PartialHash -> Bits64
finish (MkPartial tail index length hst) =
    let MkST v0 v1 v2 v3 = hst
        rest = ((length `and` 0xff) `shl` 56) `bor` tail
        v3 = v3 `xor` rest
        MkST v0 v1 v2 v3 = repeat CROUNDS compress $ MkST v0 v1 v2 v3
        v0 = v0 `xor` rest
        v2 = v2 `xor` 0xff
        MkST v0 v1 v2 v3 = repeat DROUNDS compress $ MkST v0 v1 v2 v3
     in (v0 `xor` v1) `xor` (v2 `xor` v3)

export
addBits8 : PartialHash -> Bits8 -> PartialHash
addBits8 (MkPartial tail index len hs) x = case index of
    -- finished a set of tail
    56 => MkPartial 0 0 (len + 1) $ hashBits64 hs (tail `bor` (cast x `shl` 56))
    -- add byte to partial
    _ => MkPartial (tail `bor` (cast x `shl` index)) (index + 8) (len + 1) hs

export
addBits16 : PartialHash -> Bits16 -> PartialHash
addBits16 ph x = addBits8 (addBits8 ph $ cast x) (cast $ x `shr16` 8)

export
addBits32 : PartialHash -> Bits32 -> PartialHash
addBits32 ph x = addBits16 (addBits16 ph $ cast x) (cast $ x `shr32` 16)

export
addBits64 : PartialHash -> Bits64 -> PartialHash
addBits64 (MkPartial tail index length hst) x = MkPartial tail index (length + 8) $ hashBits64 hst x

hashBuffer' : PartialHash -> Buffer -> Int -> Int -> IO PartialHash
hashBuffer' ph buf len idx = if idx >= len
    then pure ph
    else do
        word <- getBits64 buf idx
        let ph = addBits64 ph word
        hashBuffer' ph buf len (assert_smaller idx $ idx + 8)

hashBuffer : PartialHash -> Buffer -> IO PartialHash
hashBuffer ph buf = do
    rawLen <- rawSize buf
    let len = fullSize rawLen
    Just buf' <- resizeBuffer buf len
        | Nothing => hashBuffer' ph buf (rawLen `andInt` (- 7)) 0
    hashBuffer' ph buf' len 0


module LightClick.Check

import Decidable.Equality

import Data.List
import Data.Vect

import Toolkit.Data.DList
import Toolkit.Data.DList.DeBruijn
import Toolkit.Data.DVect

import Toolkit.Data.Location
import Toolkit.Data.Rig

import Language.SystemVerilog.Gates
import Language.SystemVerilog.Utilities

import LightClick.Error

import LightClick.Types
import LightClick.Types.Equality
import LightClick.Terms

import LightClick.Connection

import LightClick.Values
import LightClick.Env

%default covering

public export
TyCheck : Type -> Type
TyCheck = Either LightClick.Error

mutual
  namespace Field

    hasKey : (fc    : FileContext)
          -> (label : String)
          -> (store : List String)
                   -> TyCheck (List String)
    hasKey fc label store with (isElem label store)
      hasKey fc label store | Yes prf =
        Left (LabelAlreadyExists fc label store)
      hasKey fc label store | No contra = Right (label :: store)

    export
    check : (env   : Env ctxt)
         -> (key   : String)
         -> (value : Term ctxt DATA)
         -> (store : List String)
         -> TyCheck ( Pair String (Value DATA)
                    , Pair String (Ty DATA)
                    , List String
                    , Env ctxt
                    )
    -- References are special
    check env key (Ref {label} fc idx) store
      = do (v,t,env') <- check env (Ref fc idx)
           store' <- hasKey fc key store
           pure ((key, VRef label DATA), (key,t), store, env' )

    -- Rest is normal
    check env key term store
      = do (v,t,env') <- check env term
           fc <- getFC term
           store' <- hasKey fc key store
           pure ((key,v), (key,t), store, env')

  namespace Fields
    export
    check : {n : Nat}
         -> (env   : Env ctxt)
         -> (kvs   : Vect (S n) (Pair String (Term ctxt DATA)))
         -> (store : List String)
                  -> TyCheck
                         ( Vect (S n) (Pair String (Value DATA))
                         , Vect (S n) (Pair String (Ty DATA))
                         )
    check {n = n} env ((k,v) :: xs) store with (check env k v store)
      check {n = n} env ((k,v) :: xs) store | Left err = Left err
      check {n = n} env ((k,v) :: xs) store | Right (kv, kt, store', env') with (xs)
        check {n = Z} env ((k,v) :: Nil) store | Right (kv, kt, store', env') | Nil
          = pure ([kv], [kt])
        check {n = S n} env ((k,v) :: xs) store | Right (kv, kt, store', env') | (y::ys)
          = do (kvs, kts) <- check env' (y::ys) store'
               pure ((kv::kvs), kt::kts)

  namespace Modules

    export
    check : (env   : Env ctxt)
         -> (ports : DVect String
                           (\s => Term ctxt (PORT s))
                           (S n)
                           names)
         -> TyCheck ( DVect String (Value . PORT) (S n) names
                    , DVect String (Ty . PORT)    (S n) names
                    , Env ctxt)
    check {n = n} env (ex :: rest) with (Check.check env ex)
      check {n = n} env (ex :: rest) | (Left l) = Left l
      check {n = n} env (ex :: rest) | (Right (valueX, typeX, env')) with (rest)
        check {n = Z} env (ex :: Nil) | (Right (valueX, typeX, env')) | Nil
          = Right ([valueX], [typeX], env')
        check {n = S n} env (ex :: xs) | (Right (valueX, typeX, env')) | (y::ys)
          = do (pvs, pts, env'') <- Modules.check env' (y::ys)
               Right (valueX::pvs, typeX::pts, env'')

  namespace Port
    export
    use : {s : String} -> FileContext -> Ty (PORT s) -> TyCheck (Ty (PORT s))
    use fc type {s} = do u <- shiftUsage fc s (getUsage type)
                         Right (setUsage type u)

      where
        shiftUsage : FileContext -> String -> TyRig -> TyCheck TyRig
        shiftUsage fc s None  = Left (PortInUse fc s)
        shiftUsage _  _ One   = Right None
        shiftUsage _  _ Tonne = Right Tonne

    export
    check : (env  : Env ctxt)
         -> (term : Term ctxt (PORT s))
                 -> TyCheck (Value (PORT s), Ty (PORT s), Env ctxt)

    check env (Ref fc idx) with (Check.check env (Ref fc idx))
      check env (Ref fc idx) | Left l = Left l
      check env (Ref fc idx) | Right (v,t,env') with (t)
        check env (Ref fc idx) | Right (v,t,env') | portTy with (use fc portTy)
          check env (Ref fc idx) | Right (v,t,env') | portTy | Left l = Left l
          check env (Ref fc idx) | Right (v,t,env') | portTy | Right portTy'
            = do let env'' = updateWith env' idx (\(MkEntry value (MkTheType s portTy)) => MkEntry value (MkTheType s portTy'))
                 Right (v,portTy', env'')

    -- projection is just projection
    check env (Index fc mod idx) = Check.check env (Index fc mod idx)

    -- Seqs and Lets are not supposed to be here.
    check env _ = Left (NotSupposedToHappen (Just "Port.check"))

  namespace Fan

    export
    check : (env   : Env ctxt)
         -> (ports : DVect String
                           (\s => Term ctxt (PORT s))
                           (S (S n))
                           names)
         -> TyCheck
                   ( DVect String (Value . PORT) (S (S n)) names
                   , DVect String (Ty . PORT)    (S (S n)) names
                   , Env ctxt)
    check {n = n} env (x::y::xs) with (Port.check env x)
      check {n = n} env (x::y::xs) | Left l = Left l

      check {n = n} env (x::y::xs) | Right (vx,tx,ex) with (xs)
        check {n = Z} env (x::y::xs) | Right (vx,tx,ex) | Nil with (Port.check ex y)
          check {n = Z} env (x::y::xs) | Right (vx,tx,ex) | Nil | Left l
            = Left l
          check {n = Z} env (x::y::xs) | Right (vx,tx,ex) | Nil | Right (vy,ty,ey)
            = Right ([vx,vy], [tx,ty], ey)

        check {n = S n} env (x::y::xs) | Right (vx,tx,ex) | (z::zs) with (Fan.check ex (y::z::zs))
          check {n = S n} env (x::y::xs) | Right (vx,tx,ex) | (z::zs) | Left l = Left l
          check {n = S n} env (x::y::xs) | Right (vx,tx,ex) | (z::zs) | Right (vs, ts, env')
            = Right ((vx::vs), (tx::ts), env')

  -- [ Top Level Check Definition Begins Here ]

  export
  check : (env  : Env ctxt)
       -> (term : Term ctxt mty)
       -> TyCheck (Value (interp mty), Ty mty, Env ctxt)

  -- [ Checking References ]
  check env (Ref fc prf) with (read prf env)
    check env (Ref fc prf) | (MkEntry value (MkTheType name type))
      = Right (value, type, env)

  -- [ Checking Let Bindings ]
  check env (Let fc label this inThis)
    = do (ev, et, env') <- check env this
         (bv, bt, (u::env'')) <- check (MkEntry ev (MkTheType label et)::env') inThis
         Right (VLet label ev bv, bt, env'')

  -- [ Checking Sequencing ]
  check env (Seq x y)
    = do (vX, tX, env') <- check env x
         (vY, tY, env'') <- check env' y
         Right (VSeq vX vY, tY, env'')

  -- [ Checking Data Types]

  -- Logic
  check env (DataLogic fc) = Right (VDataLogic, TyLogic, env)

  -- Arrays
  check env (DataArray fc type size)
    = do (vs, ty', env') <- check env type
         Right (VDataArray vs size, TyArray ty' size, env')

  -- Data Strucutres

  -- Structs

  check env (DataStruct fc kvs)
    = do (kvalues, ktypes) <- check env kvs Nil
         Right (VDataStruct kvalues, TyStruct ktypes, env)

  -- Unions
  check env (DataUnion fc kvs)
    = do (kvalues, ktypes) <- check env kvs Nil
         Right (VDataUnion kvalues, TyUnion ktypes, env)

  -- [ Checking Ports ]
  check env (Port fc l d s w (Ref {label} x y))
    = do (v, t, env') <- check env (Ref x y)
         Right (VPort l d (VRef label DATA), TyPort l d s w t One, env')

  check env (Port fc l d s w term)
    = do (v, t, env') <- check env term
         Right (VPort l d v, TyPort l d s w t One, env')

  -- [ Checking Modules ]

  check env (Module fc ports)
    = do (vs, ts, env') <- check env ports
         Right (VModule vs, TyModule ts, env')

  -- [ Checking Module projection ]

  check env (Index fc m idx) with (check env m)
    check env (Index fc m idx) | Left l = Left l
    check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') with (t)
      check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names with (index names idx)
        check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names | portTy with (use fc portTy)
          check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names | portTy | Left l = Left l
          check env (Index fc (Ref fc' {label} midx) idx) | Right (v, t, env') | TyModule names | portTy | Right portTy'
            = do let names' = update names idx portTy'
                 let env''  = updateWith env' midx (\(MkEntry value (MkTheType s (TyModule names))) => MkEntry value (MkTheType s (TyModule names')))
                 port <- getPortFromModule v idx
                 Right (newIDX (recoverRef v label) port, portTy, env'')

    check env (Index fc _ idx) | Right (v, t, env') = Left (ConstantsNotAllowed fc)

  -- [ Checking Direct Connections ]

  check env (Connect fc left right)
    = do (vX, tyX, envx) <- Port.check env  left
         (vY, tyY, envy) <- Port.check envx right

         case compatible tyX tyY of
           No msg contra => Left (Nest (Mismatch fc tyX tyY)
                                       (UnSafeDirectConnection fc msg))
           Yes prf => do
             ty <- getData vX

             nX <- genNameConn vX
             nY <- genNameConn vY
             let n = newName [nX,nY]

             Right (VLet n (VChan ty) (newConn n vX vY), TyConn, envy)

  -- [ Checking Fanouts]

  check env (FanOut fc i fan)
    = do (vI, tyIN,  envi) <- Port.check env i
         (vF, tyFAN,  envf) <- Fan.check envi fan
         case Fanout.compatible tyIN tyFAN of
           No (PListError pos ty reason) contra =>
             Left (Nest (Mismatch fc tyIN ty) (UnSafeFan fc FANOUT pos reason))

           Yes prf => do
               ty <- getData vI

               nI <- genNameConn vI
               nF <- genNameFan vF
               let n = newName ["fan_out_from", nI, "to", nF]
               Right (VLet n (VChan ty) (newConn n vI vF) , TyConn, envf)

  -- [ Checking Multiplexers ]

  check env (Mux fc fan ctrl o)
    = do (fs, tf, envf) <- Fan.check  env  fan
         (vC, tc, envc) <- Port.check envf ctrl
         (vO, to, envo) <- Port.check envc o

         case Mux.compatible tf tc to of
           No (CtrlNotSafe c x) contra =>
                Left (Nest (Mismatch fc c tc)
                           (UnSafeMuxCtrl !(getFC ctrl) x))

           No (MuxNotSafe (PListError pos ty reason)) contra =>
             Left (Nest  (Mismatch fc ty to)
                         (UnSafeFan fc FANIN pos reason))
           Yes prf => do
             nO <- genNameConn vO
             nC <- genNameConn vC
             nF <- genNameFan  fs
             nFS <- getNameFan fs

             dC <- getData vC
             dO <- getData vO

             let mName = newName ["mux", nO, nC, nF]

             dualFS <- dualFan' ("input_") fs
             dualC  <- mkDual "control_" vC
             dualO  <- mkDual "output_" vO

             let mRef = (VRef mName (MODULE (nC::nO::nFS)))
             fi <- newConn (newName [mName, "fanin"]) dO mRef fs dualFS
             Right (VLet mName
                           (VModule (dualC::dualO::dualFS))
                           (VLet (newName [mName, "control"])
                                 (VChan dC)
                                 (VLet (newName [mName, "output"])
                                       (VChan dO)
                                       (VSeq (Direct.newConn (newName [mName, "control"]) vC (newIDX mRef dualC))
                                             (VSeq (Direct.newConn (newName [mName,"output"]) vO (newIDX mRef dualO))
                                                   fi
                                             )
                                       )

                                   )
                           )
                   , TyConn, envo)

  -- [ Checking NOT ]
  check env (NOT fc i o)
    = do (vX, tyX, envx) <- Port.check env  i
         (vY, tyY, envy) <- Port.check envx o

         case compatible tyX tyY of
           No msg contra =>
             Left (Nest (Mismatch fc tyX tyY)
                        (UnSafeDirectConnection fc msg))
           Yes prf => do

             ty <- getData vX

             nX <- genNameConn vX
             nY <- genNameConn vY

             let c_in_name = newName ["not_in",   nX, nY]
             let c_out_name = newName ["not_out", nX, nY]

             Right (VLet c_in_name
                         (VChan ty)
                         (VLet c_out_name
                               (VChan ty)
                               (VSeq (Gate.newConn c_in_name vX)
                                     (VSeq (Gate.newConn c_out_name vY)
                                           (VNot (VRef c_out_name CHAN)
                                                 (VRef c_in_name  CHAN)
                                         )
                                    )
                               )
                         )
                   , TyGate, envy
                   )

  -- [ Checking the GATE ]
  check env (GATE fc ty is o)
    = do (fs, tf, envf) <- Fan.check  env  is
         (vO, to, envo) <- Port.check envf o

         case Fanin.compatible tf to of
           No (PListError pos ty reason) contra => do
             Left (Nest (Mismatch fc ty to) (UnSafeFan fc FANIN pos reason))

           Yes prf => do

             tyO <- getData vO
             nO  <- genNameConn vO

             nF  <- genNameFan  fs

             let c_out_name = newName [Gates.toString ty, nO, nF, "out"]
             let c_in_name  = newName [toString ty, nO, nF, "in"]

             (ins', conns) <- Gate.FanIn.newConn c_in_name tyO fs

             Right (VLet c_out_name
                         (VChan tyO)
                         (VSeq conns
                               (VSeq (Gate.newConn c_out_name vO)
                                     (VGate ty (VRef c_out_name CHAN) ins')
                               )
                         )
                   , TyGate, envo)

  -- [ Checking the End ]
  check env End with (free env)
    check env End | Nil = Right (VEnd, TyUnit, env)
    check env End | (x::xs) = Left (UnusedPorts (x::xs))

export
runCheck : (term : Term Nil UNIT) -> TyCheck (Value UNIT)
runCheck term with (check Nil term)
  runCheck term | (Left l) = Left l
  runCheck term | (Right (value, ty, env)) = Right (value)

-- [ EOF ]


import Data.Vect
import Data.Vect.Elem
import Data.List
import Data.Strings

import Decidable.Equality

%default total

public export
data GameState : Type where
  NotRunning : GameState
  Running : (guesses : Nat) -> (letters : Nat) -> GameState

letters : String -> List Char
letters str = nub (map toUpper (unpack str))

data GuessResult = Correct | Incorrect

export
data GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
  NewGame : (word : String) ->
            GameCmd () NotRunning (const (Running 6 (length (letters word))))

  Won :  GameCmd () (Running (S guesses) 0) (const NotRunning)
  Lost : GameCmd () (Running 0 (S guesses)) (const NotRunning)

  Guess : (c : Char) ->
          GameCmd GuessResult
                  (Running (S guesses) (S letters))
                  (\res => case res of
                                Correct => Running (S guesses) letters
                                Incorrect => Running guesses (S letters))

  ShowState : GameCmd () state (const state)
  Message : String -> GameCmd () state (const state)
  ReadGuess : GameCmd Char state (const state)

  Pure : (res : ty) -> GameCmd ty (state_fn res) state_fn
  (>>=) : GameCmd a state1 state2_fn ->
          ((res : a) -> GameCmd b (state2_fn res) state3_fn) ->
          GameCmd b state1 state3_fn

namespace Loop
  public export
  data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
    (>>=) : GameCmd a state1 state2_fn ->
            ((res : a) -> Inf (GameLoop b (state2_fn res) state3_fn)) ->
            GameLoop b state1 state3_fn
    Exit : GameLoop () NotRunning (const NotRunning)

gameLoop : {letters : _} -> {guesses : _} ->
           GameLoop () (Running (S guesses) (S letters)) (const NotRunning)
gameLoop {guesses} {letters} = do ShowState
                                  g <- ReadGuess
                                  ok <- Guess g
                                  case ok of
                                       Correct => case letters of
                                                       Z => do Won
                                                               ShowState
                                                               Exit
                                                       S k => do Message "Correct"
                                                                 gameLoop
                                       Incorrect => case guesses of
                                                         Z => do Lost
                                                                 ShowState
                                                                 Exit
                                                         S k => do Message "Incorrect"
                                                                   gameLoop

hangman : GameLoop () NotRunning (const NotRunning)
hangman = do NewGame "testing"
             gameLoop

data Game : GameState -> Type where
  GameStart : Game NotRunning
  GameWon : (word : String) -> Game NotRunning
  GameLost : (word : String) -> Game NotRunning
  InProgress : {letters : _} -> (word : String) -> (guesses : Nat) ->
               (missing : Vect letters Char) -> Game (Running guesses letters)

Show (Game g) where
  show GameStart = "Starting"
  show (GameWon word) = "Game won: word was " ++ word
  show (GameLost word) = "Game lost: word was " ++ word
  show (InProgress word guesses missing) = "\n" ++ pack (map hideMissing (unpack word))
                                        ++ "\n" ++ show guesses ++ " guesses left "
  where
    hideMissing : Char -> Char
    hideMissing c = if c `elem` missing then '-' else c

data Fuel = Dry | More (Lazy Fuel)

removeElem : {n : _} -> (value : a) -> (xs : Vect (S n) a) -> {auto prf : Elem value xs} -> Vect n a
removeElem value (value :: ys) {prf = Here} = ys
removeElem {n = Z} value (y :: []) {prf = There later} = absurd later
removeElem {n = (S k)} value (y :: ys) {prf = There later} = y :: removeElem value ys

data GameResult : (ty : Type) -> (ty -> GameState) -> Type where
  OK : (res : ty) -> Game (outState_fn res) -> GameResult ty outState_fn
  OutOfFuel : GameResult ty outState_fn

ok : (res : ty) -> Game (outstate_fn res) -> IO (GameResult ty outstate_fn)
ok res st = pure (OK res st)

runCmd : Fuel -> Game inState -> GameCmd ty inState outState_fn -> IO (GameResult ty outState_fn)
runCmd fuel state (NewGame word) = ok () (InProgress (toUpper word) _ (fromList (letters word)))
runCmd fuel (InProgress word _ missing) Won = ok () (GameWon word)
runCmd fuel (InProgress word _ missing) Lost = ok () (GameLost word)
runCmd fuel (InProgress word _ missing) (Guess c) = case isElem c missing of
                                                         Yes prf => ok Correct (InProgress word _ (removeElem c missing))
                                                         No contra => ok Incorrect (InProgress word _ missing)
runCmd fuel state ShowState = do printLn state
                                 ok () state
runCmd fuel state (Message str) = do putStrLn str
                                     ok () state
runCmd (More fuel) state ReadGuess = do putStr "Guess: "
                                        input <- getLine
                                        case unpack input of
                                             [x] => if isAlpha x
                                                       then ok (toUpper x) state
                                                       else do putStrLn "Invalid input"
                                                               runCmd fuel state ReadGuess
                                             _ => do putStrLn "Invalid input"
                                                     runCmd fuel state ReadGuess
runCmd fuel state (Pure res) = ok res state
runCmd fuel state (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel state cmd
                                                         | OutOfFuel => pure OutOfFuel
                                      runCmd fuel newSt (next cmdRes)
runCmd Dry _ _ = pure OutOfFuel

run : Fuel -> Game inState -> GameLoop ty inState outState_fn -> IO (GameResult ty outState_fn)
run Dry _ _ = pure OutOfFuel
run (More fuel) st Exit = ok () st
run (More fuel) st (cmd >>= next) = do OK cmdRes newSt <- runCmd fuel st cmd
                                                          | OutOfFuel => pure OutOfFuel
                                       run fuel newSt (next cmdRes)

partial
forever : Fuel
forever = More forever

partial
main : IO ()
main = do run forever GameStart hangman
          pure ()


total twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible

partial loop : Void
loop = loop


module Chapter.Concurrency.ProcessLib

import System.Concurrency.Channels

export
data MessagePID : (iface : reqType -> Type) -> Type where
     MkMessage : PID -> MessagePID iface

%access public export

NoRecv : Void -> Type
NoRecv = const Void

data ProcState = Ready
               | Sent
               | Looping

data Process : (iface : reqType -> Type) ->
               Type ->
               (in_state  : ProcState) ->
               (out_state : ProcState) ->
               Type where
     Request : MessagePID service_iface ->
               (msg : service_reqType) ->
               Process ifae (service_iface msg) st st
     Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) ->
               Process iface (Maybe reqType) st Sent
     Spawn   : Process service_iface () Ready Looping ->
               Process iface (Maybe (MessagePID service_iface)) st st

     Loop    : Inf (Process iface a Ready Looping) ->
               Process iface a Sent Looping
     Action  : IO a -> Process iface a st st
     Pure    : a -> Process iface a st st
     (>>=)   : Process iface a st1 st2 ->
               (a -> Process iface b st2 st3) ->
               Process iface b st1 st3

data Fuel = Dry
          | More (Lazy Fuel)

%access export

partial
forever : Fuel
forever = More forever

run : Fuel -> Process iface t in_state out_state -> IO (Maybe t)
run fuel (Request {service_iface} (MkMessage proc) msg) =
    do Just chan <- connect proc
         | Nothing => pure Nothing
       if !(unsafeSend chan msg)
          then do Just x <- unsafeRecv (service_iface msg) chan
                    | Nothing => pure Nothing
                  pure (Just x)
          else pure Nothing
-- TODO: encapsulate timeout
run fuel (Respond {reqType} calc) =
    do Just sender <- listen 1
         | Nothing => pure (Just Nothing)
       Just msg <- unsafeRecv reqType sender
         | Nothing => pure (Just Nothing)
       Just res <- run fuel (calc msg)
         | Nothing => pure Nothing
       unsafeSend sender res
       pure (Just (Just msg))
run fuel (Spawn proc)       = do Just pid <- spawn (run fuel proc *> pure ())
                                   | Nothing => pure (Just Nothing)
                                 pure (Just (Just (MkMessage pid)))
run (More fuel) (Loop proc) = run fuel proc
run fuel (Action act)       = pure (Just !act)
run fuel (Pure val)         = pure (Just val)
run fuel (act >>= next)     = do Just x <- run fuel act
                                   | Nothing => pure Nothing
                                 run fuel (next x)
run Dry _                   = pure Nothing

%access public export

Service : (iface : reqType -> Type) -> Type -> Type
Service iface a = Process iface a Ready Looping

Client : Type -> Type
Client a = Process NoRecv a Ready Ready

partial export
runProc : Process iface () in_state out_state -> IO ()
runProc proc = run forever proc *> pure ()