module Uri.Util

import Data.Buffer
import Debug.Trace

public export
hexDigitToDigit : Char -> Int
hexDigitToDigit c =
         if c >= '0' && c <= '9' then (cast c) - (cast '0')
    else if c >= 'A' && c <= 'F' then (cast c) - (cast 'A') + 10
    else if c >= 'a' && c <= 'f' then (cast c) - (cast 'a') + 10
    else 0

public export
hexToStringIO : List Int -> IO String
hexToStringIO list = do
        let size = length list
        res <- newBuffer (cast $ size)
        case res of
            Just buf => getString (hexToStr buf 0 list) 0 (cast size)
            Nothing => pure ""
    where
        hexToStr : Buffer -> Int -> List Int -> Buffer
        hexToStr buf idx (h :: tl) =
            let () = unsafePerformIO (setByte buf idx h) in
            hexToStr buf (idx+1) tl
        hexToStr buf idx [] = buf

%inline
public export
hexToStr : List Int -> String
hexToStr = unsafePerformIO . hexToStringIO


module Util

-- NB things will need to be removed from here as Idris gains them in the
-- Prelude.

import System.File

infixl 1 <&>
export
(<&>) : Functor f => f a -> (a -> b) -> f b
x <&> f = f <$> x

infixr 1 =<<
export
(=<<) : Monad m => (a -> m b) -> m a -> m b
(=<<) = flip (>>=)

-- For when Lazy is causing type problems and you want to avoid Force/Delay, or
-- force/delay isn't working as I've noticed it sometimes doesn't.
infixr 4 &&|
export
(&&|) : Bool -> Bool -> Bool
(&&|) x y = x && y

export
catMaybes : List (Maybe a) -> List a
catMaybes z = foldr (\m,f => maybe f (\x => (x ::) . f) m) id z []

export
isJust : Maybe a -> Bool
isJust (Just _ ) = True
isJust _ = False

export
unzip : List (a,b) -> (List a, List b)
unzip = foldr (\(x,y),(xs,ys) => (x :: xs, y :: ys)) ([],[])

-- This is hiiiiiideously slow! maybe it's because I'm using it at elab-time
export
unzip3 : List (a,b,c) -> (List a, List b, List c)
unzip3 [] = ([],[],[])
unzip3 ((x, (y, z)) :: ls) = let (xs,ys,zs) = unzip3 ls
                             in (x :: xs, y:: ys, z :: zs)

export
unless : Applicative f => Bool -> Lazy (f ()) -> f ()
unless b act = if b then pure () else act

public export
monus : Nat -> Nat -> Nat
monus Z _ = Z
monus k Z = k
monus (S k) (S j) = k `monus`j

export
withFile : HasIO io => String -> Mode -> (Either FileError File -> io a) -> io a
withFile file mode act = do res <- openFile file mode
                            a <- act res
                            either (\_ => pure a)
                                   (\f => pure a <* closeFile f) res

export
on : (b -> b -> c) -> (a -> b) -> a -> a -> c
on f g x y = g x `f` g y

infixl 9 ^
export
%foreign "scheme:expt"
(^) : Int -> Int -> Int

infixl 7 .&.
export
%foreign "scheme:bitwise-and"
(.&.) : Int -> Int -> Int

infixl 8 .|.
export
%foreign "scheme:bitwise-ior"
(.|.) : Int -> Int -> Int

%foreign "scheme:bitwise-xor"
export
xor : Int -> Int -> Int

%foreign "scheme:bitwise-not"
export
not : Int -> Int

export
leadingBits : Bits8 -> Int
leadingBits b0 = count (cast b0) 7
  where
    count : Int -> Int -> Int
    count b p = if p >= 0 && b .&. shiftL 1 p > 0
                  then 1 + count b (p - 1)
                  else 0

-- Bits8 is always a valid codepoint
export
bits8ToChar : Bits8 -> Char
bits8ToChar = cast . cast {to=Int}

export
Range Char where
  rangeFromTo x y = cast <$> rangeFromTo {a=Int} (cast x) (cast y)
  rangeFromThenTo x y z
    = cast <$> rangeFromThenTo {a=Int} (cast x) (cast y) (cast z)
  rangeFrom x = cast <$> rangeFrom {a=Int} (cast x)
  rangeFromThen x y = cast <$> rangeFromThen {a=Int} (cast x) (cast y)


module Circuits.NetList.Linear.Interp

import Decidable.Equality

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

import Toolkit.Decidable.Informative

import Toolkit.Data.Graph.EdgeBounded
import Toolkit.Data.Graph.EdgeBounded.HasExactDegree.All

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

import Circuits.NetList.Types

import Circuits.NetList.Linear.Usage
import Circuits.NetList.Linear.Terms

%default total

public export
InterpTy : Ty -> Type
InterpTy TyUnit
  = Unit

InterpTy (TyPort x)
  = Vertex String

InterpTy (TyChan x)
  = Pair (Vertex String) (Vertex String)

InterpTy TyGate
  = Graph String

select : Project dir -> Vertex a -> Vertex a -> Vertex a
select WRITE y z = y
select READ y z = z

namespace Environments

  public export
  data Env : List Item -> Type where
    Empty  : Env Nil
    Extend : (term : InterpTy type)
          -> (env  : Env rest)
                  -> Env (I type usage :: rest)

  namespace Port

    export
    lookup : (env : Env this)
          -> (prf : IsFreePort (I (TyPort (flow,type)) u) this)
          -> (use : UsePort this prf that)
                 -> (Env that, InterpTy (TyPort (flow,type)))
    lookup (Extend term rest) (FreePortHere pf) (UsePortHere use)
      = (Extend term rest, term)

    lookup (Extend not_term env) (FreePortThere rest) (UsePortThere later) with (lookup env rest later)
      lookup (Extend not_term env) (FreePortThere rest) (UsePortThere later) | (new, term)
        = (Extend not_term new, term)

  namespace Project

    export
    lookup : (env : Env this)
          -> (prf : IsFreeChannel how (I (TyChan type) (TyChan ein eout)) this)
          -> (use : ProjectChannel how this prf that)
                 -> (Env that, InterpTy (TyChan type))
    lookup (Extend term env) (FreeChannelHere prf) (ProjectHere use)
      = (Extend term env, term)

    lookup (Extend not_term env) (FreeChannelThere rest) (ProjectThere later) with (lookup env rest later)
      lookup (Extend not_term env) (FreeChannelThere rest) (ProjectThere later) | (new, term)
        = (Extend not_term new, term)

  namespace Index

   export
   lookup : (env : Env this)
         -> (prf : CanIndexPort idx (I (TyPort (flow, BVECT (W (S n) ItIsSucc) type)) u) this)
         -> (use : IndexPort idx this prf that)
                -> (Env that, InterpTy (TyPort (flow, type)))
   lookup (Extend term env) (CanIndexHere prf) (IndexHere use)
     = (Extend term env, term)

   lookup (Extend not_term env) (CanIndexThere rest) (IndexThere later) with (lookup env rest later)
     lookup (Extend not_term env) (CanIndexThere rest) (IndexThere later) | (new, term)
       = (Extend not_term new, term)

namespace Result

  public export
  data Result : (context : List Item)
             -> (type    : Ty)
                        -> Type
   where
     R : (counter : Nat)
      -> (env     : Env      new)
      -> (graph   : Graph String)
      -> (result  : InterpTy     type)
                 -> Result   new type

  public export
  getResult : Result ctxt type -> InterpTy type
  getResult (R counter env g result) = result

  public export
  data GetGraph : (res : Result.Result ctxt type) -> Graph String -> Type
    where
      G : (g : Graph String) -> GetGraph (R c e g r) g

  public export
  getGraph : (r : Result.Result ctxt type) -> DPair (Graph String) (GetGraph r)
  getGraph (R counter env graph result) = MkDPair graph (G graph)

interp : (env     : Env this)
      -> (counter : Nat)
      -> (graph   : Graph String)
      -> (term    : Term this type that)
                 -> Result that type

-- [ NOTE ]
--
-- As normal
interp e c g (VarPort prf use)

  = let (new, ret) = lookup e prf use
    in R c new g ret

-- [ NOTE ]
--
-- Ports are leaf nodes in the graph.
interp e c g (Port flow dtype (FP u prf) body)
    = let    c1 = S c
      in let v  = vertexFromFlow flow c1 (size dtype)

      in let R e1 c2 g1 MkUnit = interp (Extend v e)
                                        c1
                                        (insertNode v g)
                                        body
      in R e1 c2 g1 MkUnit

  where
    vertexFromFlow : Direction -> Nat -> Nat -> Vertex String
    vertexFromFlow INPUT  = driver  ("INPUT : "  <+> show dtype )
    vertexFromFlow OUTPUT = catcher ("OUTPUT : " <+> show dtype )
    vertexFromFlow INOUT  = gateway ("INOUT : "  <+> show dtype )

interp e c g (Wire dtype (FC u prf) body)
  = let    c1 = S c
    in let c2 = S c1

    in let s = size dtype

    in let chanIN  = node ("CHAN_IN : "  <+> show dtype) c1 s 1
    in let chanOUT = node ("CHAN_OUT : " <+> show dtype) c2 1 s

    in let R e1 c3 g2 MkUnit = interp (Extend (chanIN, chanOUT) e)
                                      c2
                                      (updateWith g [chanIN, chanOUT]
                                                    [MkPair (ident chanIN) (ident chanOUT)])
                                       body
    in R e1 c3 g2 MkUnit

interp e c g (Gate gate body)
  = let R c1 e1 g1 res = interp e c g gate
    in interp (Extend res e1) c1 (merge g res) body

interp e c g (Stop prf)
  = R c Empty g MkUnit

interp e c g (Mux o s l r)

  = let c1 = S c

    in let mux = node "MUX" c1 3 1

    in let R c2 e1 g1 vo = interp e  c1 g  o
    in let R c3 e2 g2 vc = interp e1 c2 g1 s
    in let R c4 e3 g3 vl = interp e2 c2 g2 l
    in let R c5 e4 g4 vr = interp e3 c3 g3 r

    in let mg = fromLists [mux]
                          [ (ident vl,  ident mux)
                          , (ident vr,  ident mux)
                          , (ident vc,  ident mux)
                          , (ident mux, ident vo)
                          ]
    in R c5 e4 g4 mg

interp e c g (GateU kind o i)
    = let c1 = S c

      in let ugate = node (show kind) c1 1 1

      in let R c2 e1 g1 vo = interp e  c1 g  o
      in let R c3 e2 g2 vi = interp e1 c2 g1 i

      in R c3 e2 g2
              (fromLists [ugate] [ MkPair (ident vi)    (ident ugate)
                                 , MkPair (ident ugate) (ident vo)
                                 ])

interp e c g (GateB kind o l r)

   = let c1 = S c

    in let bgate = node (show kind) c1 2 1

    in let R c2 e1 g1 vo = interp e  c1 g  o
    in let R c3 e2 g2 vl = interp e1 c2 g1 l
    in let R c4 e3 g3 vr = interp e2 c3 g2 r

    in let bg = fromLists [bgate]
                          [ MkPair (ident bgate) (ident vo)
                          , MkPair (ident vl) (ident bgate)
                          , MkPair (ident vr) (ident bgate)
                          ]

    in R c4 e3 g3 bg

interp e c g (Split a b i)

  = let c1 = S c
    in let s = size LOGIC

    in let sVertex = both "SPLIT" c1 s

    in let R c2 e1 g1 av = interp e  c1 g  a
    in let R c3 e2 g2 bv = interp e1 c2 g1 b
    in let R c4 e3 g3 iv = interp e2 c3 g2 i

    in let esIS = replicate s (MkPair (ident iv)      (ident sVertex))
    in let esSA = replicate s (MkPair (ident sVertex) (ident av))
    in let esSB = replicate s (MkPair (ident sVertex) (ident bv))

    in R c4 e3
            g3
            (fromLists [av,bv,iv,sVertex]
                       (esIS ++ esSA ++ esSB))

interp e c g (Collect {type} o a b)

  = let c1 = S c
    in let s = size type

    in let sVertex = both "COLLECT" c1 s

    in let R c2 e1 g1 ov = interp e  c1 g  o
    in let R c3 e2 g2 av = interp e1 c2 g1 a
    in let R c4 e3 g3 bv = interp e2 c3 g2 b

    in let esAC = replicate s (MkPair (ident av) (ident sVertex))
    in let esBC = replicate s (MkPair (ident bv) (ident sVertex))
    in let esSO = replicate s (MkPair (ident sVertex) (ident ov))

    in R c4 e3
            g3
            (fromLists [ov,av,bv,sVertex]
                       (esAC ++ esBC ++ esSO))

interp e c g (Cast cast port)
    = let c1 = S c

      in let cVertex = both "CAST" c1 1

      in let R c2 e1 g1 what = interp e c1 g port

      in R c2 e1
              (updateWith g1 [cVertex] [buildEdge cast cVertex what])
              cVertex

  where buildEdge : Cast INOUT r -> (a,b : Vertex String) -> Edge
        buildEdge BI a b = MkPair (ident b) (ident a)
        buildEdge BO a b = MkPair (ident a) (ident b)

interp e c g (Project how prf use)

    = let (new, (i,o)) = lookup e prf use

      in R c new g (selectNode how i o)

  where selectNode : Project dir -> Vertex String -> Vertex String -> Vertex String
        selectNode WRITE i _ = i
        selectNode READ  _ o = o

interp e c g (Index dir idx prf use)
    = let c1 = S c

      in let idxVertex = both ("IDX [" <+> show (finToNat idx) <+> "](" <+>  show dir <+>")" ) c1 1

      in let (new,p) = lookup e prf use

      in R c1 new (updateWith g [idxVertex]
                               (buildEdge dir p idxVertex))
              idxVertex
  where buildEdge : Index direc -> (a,b : Vertex String) -> Edges
        buildEdge (UP x)   a b = [MkPair (ident b) (ident a)]
        buildEdge (DOWN x) a b = [MkPair (ident a) (ident b)]

public export
data ValidGraph : Graph type -> Type where
  IsValid : HasExactDegrees vs es
         -> ValidGraph (MkGraph vs es)

export
validGraph : {type : Type}
          -> (g    : Graph type)
                  -> DecInfo (HasExactDegree.Error type)
                             (ValidGraph g)
validGraph (MkGraph nodes edges) with (hasExactDegrees nodes edges)
  validGraph (MkGraph nodes edges) | (Yes prf)
    = Yes (IsValid prf)
  validGraph (MkGraph nodes edges) | (No msg contra)
    = No msg (\(IsValid prf) => contra prf)

public export
data Valid : (res  : Result ctxt TyUnit)
                  -> Type
  where
    D : {res : Result ctxt TyUnit}
     -> (g   : Graph String)
            -> GetGraph res g
            -> ValidGraph g
            -> Valid res

isValid : (r : Result ctxt TyUnit)
            -> DecInfo (Graph String, HasExactDegree.Error String)
                       (Valid r)
isValid r with (getGraph r)
  isValid (R c e g r) | (MkDPair g (G g)) with (validGraph g)
    isValid (R c e g r) | (MkDPair g (G g)) | (Yes prf)
      = Yes (D g (G g) prf)
    isValid (R c e g r) | (MkDPair g (G g)) | (No msg contra)
      = No (g,msg) (\(D graph (G graph) prf) => contra prf)

public export
data Run : (term : Term Nil TyUnit Nil) -> Type where
  R : (prf  : Valid (interp Empty Z (MkGraph Nil Nil) term))
           -> Run term

public export
getGraph : Run term -> DPair (Graph String) ValidGraph
getGraph (R (D g x y)) = MkDPair g y

export
run : (term : Term Nil TyUnit Nil)
           -> DecInfo (Graph String, HasExactDegree.Error String) (Run term)
run term with (isValid (interp Empty Z empty term))
  run term | (Yes prf) = Yes (R prf)
  run term | (No msg contra) = No msg (\(R prf) => contra prf)

export
runIO : (term : Term Nil TyUnit Nil)
             -> IO (Either (Graph String, HasExactDegree.Error String)
                           (Run term))
runIO term = pure $ (asEither (run term))

-- [ EOF ]


module Circuits.NetList.Linear.Usage.Item

import Decidable.Equality

import Data.Nat
import Data.List.Elem
import Data.List.Quantifiers

import Data.Vect
import Data.Vect.AtIndex
import Data.Vect.Quantifiers

import Data.String

import Toolkit.Data.Whole
import Toolkit.Data.DList
import Toolkit.Data.DList.Elem

import Toolkit.Data.Vect.Extra
import Toolkit.Data.DVect

import Circuits.Common

import Circuits.NetList.Types

import Circuits.NetList.Linear.Usage.DataType
import Circuits.NetList.Linear.Usage.DataType.Use.Full
import Circuits.NetList.Linear.Usage.DataType.Use.Partial

import Circuits.NetList.Linear.Usage.TermType
import Circuits.NetList.Linear.Usage.TermType.Use.Port
import Circuits.NetList.Linear.Usage.TermType.Use.Channel

%default total

public export
record Item where
  constructor I
  getType : Ty
  getUsage : Usage getType

public export
data FreePort : (flow : Direction)
             -> (type : DType)
             -> (item : Item)
                      -> Type
  where
    FP : (u : Usage type) -> (prf : IsFree type u) -> FreePort flow type (I (TyPort (flow, type)) (TyPort u))

public export
freePort : (flow : Direction)
        -> (type : DType)
                -> DPair Item (FreePort flow type)
freePort flow type with (init type)
  freePort flow type | (MkDPair u prf)
    = MkDPair (I (TyPort (flow, type)) (TyPort u)) (FP u prf)

public export
data FreeChan : (type : DType) -> (item : Item) -> Type where
  FC : (u : Usage type) -> (prf : IsFree type u) -> FreeChan type (I (TyChan type) (TyChan u u))

public export
freeChan : (type : DType) -> DPair Item (FreeChan type)
freeChan type with (init type)
  freeChan type | (MkDPair u prf)
    = MkDPair (I (TyChan type) (TyChan u u)) (FC u prf)

-- I (TyPort (flow,type)) ?as)

public export
data CanStop : Item -> Type where
  StopG : CanStop (I TyGate TyGate)
  StopU : CanStop (I TyUnit TyUnit)

  StopP : (prf : IsUsed     (TyPort (flow,dtype)) u)
              -> CanStop (I (TyPort (flow,dtype)) u)

  StopC : (prf : IsUsed     (TyChan type) u)
              -> CanStop (I (TyChan type) u)

portIsFree : (IsUsed (TyPort x) u -> Void) -> CanStop (I (TyPort x) u) -> Void
portIsFree f (StopP prf) = f prf

chanOutIsFree : (IsUsed x eout -> Void) -> CanStop (I (TyChan x) (TyChan ein eout)) -> Void
chanOutIsFree f (StopC (UsedC uin uou)) = f uou

chanInIsFree : (IsUsed x ein -> Void) -> CanStop (I (TyChan x) (TyChan ein eout)) -> Void
chanInIsFree f (StopC (UsedC uin uou)) = f uin

export
canStop : (i : Item) -> Dec (CanStop i)
canStop (I TyUnit TyUnit)
  = Yes StopU

canStop (I (TyPort x) u) with (isUsed u)
  canStop (I (TyPort (flow, type)) (TyPort u)) | (Yes (UsedP y))
    = Yes (StopP (UsedP y))

  canStop (I (TyPort x) u) | (No contra)
    = No (portIsFree contra)

canStop (I (TyChan x) (TyChan ein eout)) with (isUsed ein)
  canStop (I (TyChan x) (TyChan ein eout)) | (Yes prfIN) with (isUsed eout)
    canStop (I (TyChan x) (TyChan ein eout)) | (Yes prfIN) | (Yes prfOUT)
      = Yes (StopC (UsedC prfIN prfOUT))

    canStop (I (TyChan x) (TyChan ein eout)) | (Yes prfIN) | (No contra)
      = No (chanOutIsFree contra)

  canStop (I (TyChan x) (TyChan ein eout)) | (No contra)
    = No (chanInIsFree contra)

canStop (I TyGate TyGate)
  = Yes StopG

-- [ EOF ]


module Core.Abstraction

import General
import Core.Variable
import Core.Term
import Core.ConSig

%access export

--  o8o  8888. oYYYo YY8YY 8YYYo  o8o   oYYo YY8YY Y8Y _YYY_ 8o  0 oYYYo
-- 8   8 8___Y %___    0   8___P 8   8 0   "   0    0  0   0 8Yo 8 %___
-- 8YYY8 8"""o `"""p   0   8""Yo 8YYY8 0   ,   0    0  0   0 8 Yo8 `"""p
-- 0   0 8ooo" YoooY   0   0   0 0   0  YooY   0   o8o "ooo" 0   8 YoooY

implementation Abstract a b c => Abstract a b (Plict,c) where
	abstr (plic,x) = MkPair plic <$> abstr x

implementation (Abstract a b Pattern, Abstract a b Term) => Abstract a b Clause where
	abstr (NewClause psc sc) = NewClause <$> abstractScope psc <*> abstractScope sc

implementation Abstract a b Term => Abstract a b CaseMotive where
	abstr (CaseMotiveNil a) = CaseMotiveNil <$> abstr a
	abstr (CaseMotiveCons a sc) = CaseMotiveCons <$> abstr a <*> abstractScope sc

implementation Abstract a b Term => Abstract a b Telescope where
	abstr TelescopeNil = pure TelescopeNil
	abstr (TelescopeCons t sc) = TelescopeCons <$> abstr t <*> abstractScope sc

mutual
	implementation Abstract String Term Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = asks $ \e => case SortedMap.lookup x e of
			Nothing => Var (Name x)
			Just m  => m
		abstr (Var (Generated x i)) = pure $ Var (Generated x i)
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic, a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract String Term Pattern where
		abstr (VarPat x) = pure $ VarPat x
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

mutual
	implementation Abstract Int Term Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = pure $ Var (Name x)
		abstr (Var (Generated x i)) = asks $ \e => case SortedMap.lookup i e of
			Nothing => Var (Generated x i)
			Just m  => m
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic,a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract Int Term Pattern where
		abstr (VarPat x) = pure $ VarPat x
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

mutual
	implementation Abstract String Variable Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = asks $ \e => case SortedMap.lookup x e of
			Nothing => Var (Name x)
			Just y  => Var y
		abstr (Var (Generated x i)) = pure $ Var (Generated x i)
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic,a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract String Variable Pattern where
		abstr (VarPat (Name x)) = asks $ \e => case SortedMap.lookup x e of
			Nothing => VarPat (Name x)
			Just y  => VarPat y
		abstr (VarPat (Generated x i)) = pure $ VarPat (Generated x i)
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

mutual
	implementation Abstract Int Variable Term where
		abstr (Meta i) = pure $ Meta i
		abstr (Var (Name x)) = pure $ Var (Name x)
		abstr (Var (Generated x i)) = asks $ \e => case SortedMap.lookup i e of
			Nothing => Var (Generated x i)
			Just y  => Var y
		abstr (DottedVar m var) = pure $ DottedVar m var
		abstr (AbsoluteDottedVar m var) = pure $ AbsoluteDottedVar m var
		abstr (Ann m ty) = Ann <$> abstr m <*> pure ty
		abstr Star = pure Star
		abstr (Pi plic a sc) = Pi plic <$> abstr a <*> abstractScope sc
		abstr (Lam plic sc) = Lam plic <$> abstractScope sc
		abstr (App plic f a) = App plic <$> abstr f <*> abstr a
		abstr (Con c as) = Con c <$> Traversable.for as (\(plic,a) => do a' <- abstr a ; pure (plic,a'))
		abstr (Case as t cs) = Case <$> traverse abstr as <*> abstr t <*> traverse abstr cs
		abstr (RecordType tele) = RecordType <$> abstr tele
		abstr (RecordCon fields) = RecordCon <$> (sequence [ MkPair x <$> abstr m | (x,m) <- fields ])
		abstr (Project m x) = Project <$> abstr m <*> pure x

	implementation Abstract Int Variable Pattern where
		abstr (VarPat (Name x)) = pure $ VarPat (Name x)
		abstr (VarPat (Generated x i)) = asks $ \e => case SortedMap.lookup i e of
			Nothing => VarPat (Generated x i)
			Just y  => VarPat y
		abstr (ConPat c ps) = ConPat c <$> traverse abstr ps
		abstr (AssertionPat m) = AssertionPat <$> abstr m
		abstr MakeMeta = pure MakeMeta

-- 0   0 8YYYY 0    8YYYo 8YYYY 8YYYo oYYYo
-- 8___8 8___  0    8___P 8___  8___P %___
-- 8"""8 8"""  0    8"""  8"""  8""Yo `"""p
-- 0   0 8oooo 8ooo 0     8oooo 0   0 YoooY

piHelper : Plict -> String -> Term -> Term -> Term
piHelper plic x a b = Pi plic a (scope [x] b)

lamHelper : Plict -> String -> Term -> Term
lamHelper plic x b = Lam plic (scope [x] b)

clauseHelper : List Pattern -> List String -> Term -> Clause
clauseHelper ps xs b = do
	let cleanedXs = fst $ runState (traverse cleanXs xs) 0
	let cleanedPs = fst $ runState (traverse cleanPs ps) 0
	NewClause (scope2 xs cleanedXs cleanedPs) (scope (filter isVar xs) b)
where
	cleanXs : String -> State Integer String
	cleanXs "_" = do
		i <- get
		put (i + 1)
		pure $ "$" ++ show i
	cleanXs x = pure x

	cleanPs : Pattern -> State Integer Pattern
	cleanPs (VarPat (Name "_")) = do
		i <- get
		put (i + 1)
		pure $ VarPat (Name ("$" ++ show i))
	cleanPs (VarPat (Name n)) = pure $ VarPat (Name n)
	cleanPs (VarPat (Generated n i)) = pure $ VarPat (Generated n i)
	cleanPs (ConPat c ps') = ConPat c <$> traverse (\(plic,p) => do { p' <- cleanPs p ; pure (plic,p') }) ps'
	cleanPs (AssertionPat m) = pure $ AssertionPat m
	cleanPs MakeMeta = pure MakeMeta

consMotiveHelper : String -> Term -> CaseMotive -> CaseMotive
consMotiveHelper x a b = CaseMotiveCons a (scope [x] b)

telescopeHelper : List (String, Term) -> Telescope
telescopeHelper [] = TelescopeNil
telescopeHelper ((x,t)::xts) = let tele = telescopeHelper xts in TelescopeCons t (scope [x] tele)

implementation Abstract a Term Term => Abstract a Term (ConSig Term) where
	abstr (ConSigNil a) = ConSigNil <$> abstr a
	abstr (ConSigCons plic a sc) = ConSigCons plic <$> abstr a <*> abstractScope sc

conSigHelper : List DeclArg -> Term -> ConSig Term
conSigHelper [] b = ConSigNil b
conSigHelper (NewDeclArg plic x a :: as) b = ConSigCons plic a (scope [x] (conSigHelper as b))


module FoldFusion

Array : Type -> Type
Var : Type -> Type -> Type

interface Symantics (rep : Type -> Type) where
  int : Int -> rep Int
  bool : Bool -> rep Bool
  (==) : rep Int -> rep Int -> rep Bool
  (>) : rep Int -> rep Int -> rep Bool
  (<) : rep Int -> rep Int -> rep Bool
  (&&) : rep Bool -> rep Bool -> rep Bool
  (||) : rep Bool -> rep Bool -> rep Bool
  (+) : rep Int -> rep Int -> rep Int
  (*) : rep Int -> rep Int -> rep Int
  ite : rep Bool -> rep a -> rep a -> rep a
  deref : rep (Var s a) -> rep a
  assign : rep a -> rep (Var s a) -> rep ()
  newVar : rep a -> ({s : Type} -> rep (Var s a) -> rep b) -> rep b
  foreach : rep (Array a) -> (rep a -> rep ()) -> rep ()
  seq : rep a -> rep b -> rep b
  lam : (rep a -> rep b) -> rep (a -> b)
  app : rep (a -> b) -> rep a -> rep b

data Code : Type -> Type where
  C : (Int -> String) -> Code a

Symantics Code where
  int x = C (\_ => show x)
  bool x = C (\_ => if x then "true" else "false")
  (==) (C l) (C r) = C (\v => "( " ++ l v ++ " = " ++ r v ++ " )")
  (>) (C l) (C r) = C (\v => "( " ++ l v ++ " > " ++ r v ++ " )")
  (<) (C l) (C r) = C (\v => "( " ++ l v ++ " < " ++ r v ++ " )")
  (&&) (C l) (C r) = C (\v => "( " ++ l v ++ " && " ++ r v ++ " )")
  (||) (C l) (C r) = C (\v => "( " ++ l v ++ " || " ++ r v ++ " )")
  (+) (C l) (C r) = C (\v => "( " ++ l v ++ " + " ++ r v ++ " )")
  (*) (C l) (C r) = C (\v => "( " ++ l v ++ " * " ++ r v ++ " )")
  ite (C b) (C l) (C r) = C (\v => "(if " ++ b v ++ " then " ++ l v ++ " else " ++ r v ++ ")")
  deref (C x) = C (\v => "!" ++ x v)
  assign (C val) (C var) = C (\v => var v ++ " := " ++ val v)
  newVar {a} (C s) f = C (\v => let x = "x" ++ show v in
                                let (C c) = f $ the (Code (Var () a)) (C (\_ => x)) in
                                "let " ++ x ++ " = ref " ++ s v ++ " in " ++ c (v + 1))
  foreach (C arr) f = C (\v =>  let x = "x" ++ show v in
                                let (C c) = f (C (\_ => x)) in
                                "(for " ++ x ++ " in " ++ arr v ++ " do " ++ c (v + 1) ++ ")")
  seq (C fs) (C sn) = C (\v => "(" ++ fs v ++ "; " ++ sn v ++ ")")
  lam f = C (\v => let x = "x" ++ show v in
                   let (C g) = f (C (\_ => x)) in
                   "(fun " ++ x ++ " -> " ++ g (v + 1) ++ ")" )
  app (C f) (C g) = C (\v => "(" ++ f v ++ " " ++ g v ++ ")" )

data Fold : (rep : Type -> Type) -> (a : Type) -> Type where
  FC : ({r : Type} -> (rep a -> rep r -> rep r) -> rep r -> rep r) -> Fold rep a

ofArray : Symantics rep => rep (Array a) -> Fold rep a
ofArray arr = FC (\f, seed => newVar seed (\v => seq (foreach arr (\x => assign (f x (deref v)) v)) (deref v)))

fold : (rep a -> rep r -> rep r) -> rep r -> Fold rep a -> rep r
fold f seed (FC g) = g f seed

map : (rep a -> rep b) -> Fold rep a -> Fold rep b
map f (FC g) = FC (\h => g (\x, r => h (f x) r))

flatMap : (rep a -> Fold rep b) -> Fold rep a -> Fold rep b
flatMap f (FC g) = FC (\h => g (\x, r => fold h r (f x)))

filter : Symantics rep => (rep a -> rep Bool) -> Fold rep a -> Fold rep a
filter f (FC g) = FC (\h => g (\x, r =>  ite (f x) (h x r) r))

count : Symantics rep => Fold rep a -> rep Int
count = fold (\x, acc => acc + (int 1)) (int 0)

sum : Symantics rep => Fold rep Int -> rep Int
sum = fold (\x, acc => x + acc) (int 0)

example : Symantics rep => rep (Array Int) -> rep Int
example = sum . map (\x => x * (int 2)) . filter (\x => x < (int 5)) . ofArray

test : Code (Array Int -> Int)
test = lam example

code : String
code = let (C c) = test in c 0


module Brainfeck.Parse
-- Local Variables:
-- idris-load-packages: ("contrib")
-- End:
import Control.ST
import Data.Vect as V

import Brainfeck.Type
import Brainfeck.Util

%default total

public export
data ParseError : Type where
  MkParseError  : Location -> String -> ParseError

data TempOp : Type where
  TOp  : Operation n -> Location -> TempOp
  TJZ  : Nat -> Location -> TempOp
  TJNZ : Nat -> Location -> TempOp

mkParseError : TempOp -> String -> ParseError
mkParseError (TOp  _ loc) err = MkParseError loc err
mkParseError (TJZ  _ loc) err = MkParseError loc err
mkParseError (TJNZ _ loc) err = MkParseError loc err

tokenToTOp : Token -> Location -> Nat -> TempOp
tokenToTOp TLeft loc _        = TOp OLeft {n=0} loc
tokenToTOp TRight loc _       = TOp ORight {n=0}loc
tokenToTOp TInc loc _         = TOp OInc {n=0} loc
tokenToTOp TDec loc _         = TOp ODec {n=0} loc
tokenToTOp TOut loc _         = TOp OOut {n=0} loc
tokenToTOp TIn loc _          = TOp OIn {n=0} loc
tokenToTOp TJumpForward loc i = TJZ i loc
tokenToTOp TJumpBack loc i    = TJNZ i loc

tempToOp : (numOps : Nat) -> TempOp -> Maybe (Operation numOps)
tempToOp _      (TOp OLeft  _) = Just OLeft
tempToOp _      (TOp ORight _) = Just ORight
tempToOp _      (TOp OInc   _) = Just OInc
tempToOp _      (TOp ODec   _) = Just ODec
tempToOp _      (TOp OOut   _) = Just OOut
tempToOp _      (TOp OIn    _) = Just OIn
tempToOp _      (TOp _      _) = Nothing
tempToOp numOps (TJZ  l _) = map OJumpZero  $ natToFin l numOps
tempToOp numOps (TJNZ l _) = map OJumpNZero $ natToFin l numOps

matchForwardJump : (jumpTo : Nat) -> TempOp -> TempOp
matchForwardJump n (TJZ _ loc) = TJZ n loc
matchForwardJump _ anything = anything

updateListElem : (a -> a) -> (idx : Nat) -> List a -> List a
updateListElem f n xs = go f (length xs `minus` S n) xs where
  go _ _ [] = []
  go f Z (x :: xs) = f x :: xs
  go f (S n) (x :: xs) = x :: go f n xs

goLoop : Tokens n -> (is : Var) -> (forwards : Var) -> (opNo : Var)
       -> ST id (Either ParseError (List TempOp))
            [ is ::: State (List TempOp),
              forwards ::: State (List (TempOp, Nat)),
              opNo ::: State Nat ]
goLoop [] is forwards _ = do
  fs <- read forwards
  case fs of
    Nil       => read is >>= \is => pure (Right $ reverse is)
    (f :: fs) => pure (Left $ mkParseError (fst f) "Unmatched forward jump")
goLoop ((loc, t) :: xs) is forwards iVar = do
  i <- read iVar
  update iVar (+1)
  let tOp = tokenToTOp t loc i
  case tOp of
    TJZ  _ l => do
      update forwards ((TJZ i l, i) ::)
      -- remember to update these when the matching bracket is found
      update is ((TJZ 0 l) ::)
      goLoop xs is forwards iVar
    TJNZ _ l => do
      fs <- read forwards
      case fs of
        Nil        => pure (Left $ MkParseError loc $ "Unmatched backward jump " ++ show i)
        ((_, prev) :: rem) => do
          write forwards rem
          update is ((TJNZ prev l) ::)
          update is (updateListElem (matchForwardJump i) prev)
          goLoop xs is forwards iVar
    _      => update is (tOp ::) >>= \_ => goLoop xs is forwards iVar

go : Tokens n -> ST id (Either ParseError (n : Nat ** Instructions n)) []
go ts = do
  is <- new Nil
  fs <- new Nil
  i  <- new Z

  instructionList <- call $ goLoop ts is fs i
  let instructionVect = map listToVect instructionList
  delete is
  delete fs
  delete i
  case instructionVect of
    (Left l) => pure $ Left l
    (Right (n ** vs)) =>
      let (m ** converted) = mapMaybe (tempToOp n) vs in
      case decEq n m of
        (Yes Refl   ) => pure . Right $ (n ** converted)
        (No  contra) =>
          pure . Left $ MkParseError (Loc 0 0) "Labels not bounded by number of operations."

export
parse : Tokens n -> Either ParseError (n : Nat ** Instructions n)
parse tokens = runPure (go tokens)


module Control.Effect.Exception

import Data.Contravariant

import Control.EffectAlgebra

import public Control.Effect.Fail

import Control.Monad.Either

||| Exception effect.
public export
data TryE : Type -> (Type -> Type) -> Type -> Type where
  Try : m a -> (e -> m a) -> TryE e m a

public export
Contravariant (\e => TryE e m r) where
  contramap f (Try x h) = Try x (h . f)

public export
EitherE : Type -> (Type -> Type) -> Type -> Type
EitherE e = TryE e :+: FailE e

public export
Inj (EitherE e) sig => Inj (FailE e) sig where
  inj = inj {sub = EitherE e, sup = sig} . Inr

public export
Inj (EitherE e) sig => Inj (TryE e) sig where
  inj = inj {sub = EitherE e, sup = sig} . Inl

||| Try running a computation. If it fails (via Fail) resort to the supplied callback.
public export
try : Inj (TryE e) sig => Algebra sig m => m a -> (e -> m a) -> m a
try x err = send (Try x err)

namespace Algebra
  public export
  [Either] (al : Algebra sig m) => Algebra (EitherE e :+: sig) (EitherT e m) where
    alg ctx hdl (Inl (Inr (Fail x))) = left x
    alg ctx hdl (Inl (Inl (Try t er))) =
      catchE (hdl (t <$ ctx)) (hdl . (<$ ctx) . er)
    alg ctxx hdl (Inr other) =
      let fused = (~<~) {ctx2 = ctx} {m = EitherT e m} f hdl in
      MkEitherT (alg {f = Functor.Compose} {ctx = Either e . ctx} (Right ctxx) fused other)
     where
      f : forall a. Either e (EitherT e m a) -> m (Either e a)
      f (Left x) = pure (Left x)
      f (Right x) = runEitherT x

  %hint public export
  AlgebraEither : (al : Algebra sig m) => Algebra (EitherE e :+: sig) (EitherT e m)
  AlgebraEither = Algebra.Either


module Language.SystemVerilog.MetaTypes

import        Data.String

import public Toolkit.Data.DList.DeBruijn
import public Toolkit.Decidable.Equality.Indexed

%default total

public export
data Ty = MODULE (List String)
        | DATA
        | CHAN
        | PORT String
        | MINST (List String)
        | UNIT
        | TYPE
        | GATE
        | GINST

export
Show Ty where
  show (MODULE xs) = unwords ["(MODULE", show xs, ")"]
  show DATA = "(DATA)"
  show CHAN = "(CHAN)"
  show (PORT x) = unwords ["(PORT", show x, ")"]
  show (MINST xs) = unwords ["(MINST", show xs, ")"]
  show UNIT = "(UNIT)"
  show TYPE = "(TYPE)"
  show GATE = "(GATE)"
  show GINST = "(GINST)"

public export
Context : Type
Context = List (Pair String Ty)

public export
Index : Context -> Pair String Ty -> Type
Index = DeBruijn.Index (Pair String Ty)

export
Eq Ty where
  (==) (MODULE xs)   (MODULE ys)     = xs == ys
  (==) DATA          DATA            = True
  (==) CHAN          CHAN            = True
  (==) (PORT x)      (PORT y)        = x == y
  (==) (MINST xs)    (MINST ys)      = xs == ys
  (==) UNIT          UNIT            = True
  (==) TYPE          TYPE            = True
  (==) GATE          GATE            = True
  (==) GINST         GINST           = True
  (==) _             _               = False

namespace DecEq

  -- Modules

  modulesDifferentNames : (xs : List String)
                       -> (ys : List String)
                       -> (contra : (xs = ys) -> Void)
                       -> (MODULE xs = MODULE ys)
                       -> Void
  modulesDifferentNames ys ys contra Refl = contra Refl

  moduleDataNotEq : (MODULE xs = DATA) -> Void
  moduleDataNotEq Refl impossible

  moduleChanNotEq : (MODULE xs = CHAN) -> Void
  moduleChanNotEq Refl impossible

  modulePortNotEq : (MODULE xs = PORT x) -> Void
  modulePortNotEq Refl impossible

  moduleDeclmoduleInstNotEq : (MODULE xs = MINST ys) -> Void
  moduleDeclmoduleInstNotEq Refl impossible

  moduleUnitNotEq : (MODULE xs = UNIT) -> Void
  moduleUnitNotEq Refl impossible

  moduleTypeNotEq : (MODULE xs = TYPE) -> Void
  moduleTypeNotEq Refl impossible

  moduleGateNotEq : (MODULE xs = GATE) -> Void
  moduleGateNotEq Refl impossible

  moduleGinstNotEq : (MODULE xs = GINST) -> Void
  moduleGinstNotEq Refl impossible

  -- Data.

  dataChanNotEq : (DATA = CHAN) -> Void
  dataChanNotEq Refl impossible

  dataPortNotEq : (DATA = PORT x) -> Void
  dataPortNotEq Refl impossible

  dataModuleInstNotEq : (DATA = MINST xs) -> Void
  dataModuleInstNotEq Refl impossible

  dataUnitNotEq : (DATA = UNIT) -> Void
  dataUnitNotEq Refl impossible

  dataTypeNotEq : (DATA = TYPE) -> Void
  dataTypeNotEq Refl impossible

  dataGateNotEq : (DATA = GATE) -> Void
  dataGateNotEq Refl impossible

  dataGinstNotEq : (DATA = GINST) -> Void
  dataGinstNotEq Refl impossible

  -- Channels

  chanPortNotEq : (CHAN = PORT x) -> Void
  chanPortNotEq Refl impossible

  chanModuleInstNotEq : (CHAN = MINST xs) -> Void
  chanModuleInstNotEq Refl impossible

  chanUnitNotEq : (CHAN = UNIT) -> Void
  chanUnitNotEq Refl impossible

  chanTypeNotEq : (CHAN = TYPE) -> Void
  chanTypeNotEq Refl impossible

  chanGateNotEq : (CHAN = GATE) -> Void
  chanGateNotEq Refl impossible

  chanGinstNotEq : (CHAN = GINST) -> Void
  chanGinstNotEq Refl impossible

  -- Port

  portLabelMismatch : (contra : (x = y) -> Void) -> (PORT x = PORT y) -> Void
  portLabelMismatch contra Refl = contra Refl

  portModuleInstNotEq : (PORT x = MINST xs) -> Void
  portModuleInstNotEq Refl impossible

  portUnitNotEq : (PORT x = UNIT) -> Void
  portUnitNotEq Refl impossible

  portTypeNotEq : (PORT x = TYPE) -> Void
  portTypeNotEq Refl impossible

  portGateNotEq : (PORT x = GATE) -> Void
  portGateNotEq Refl impossible

  portGinstNotEq : (PORT x = GINST) -> Void
  portGinstNotEq Refl impossible

  -- MInst
  moduleInstParamsDiffer : (xs : List String)
                        -> (ys : List String)
                        -> (contra : (xs = ys) -> Void) -> (MINST xs = MINST ys) -> Void
  moduleInstParamsDiffer ys ys contra Refl = contra Refl

  moduleInstUnitNotEq : (MINST xs = UNIT) -> Void
  moduleInstUnitNotEq Refl impossible

  moduleInstTypeNotEq : (MINST xs = TYPE) -> Void
  moduleInstTypeNotEq Refl impossible

  moduleInstGateNotEq : (MINST xs = GATE) -> Void
  moduleInstGateNotEq Refl impossible

  moduleInstGinstNotEq : (MINST xs = GINST) -> Void
  moduleInstGinstNotEq Refl impossible

  -- Unit

  unitTypeNotEq : (UNIT = TYPE) -> Void
  unitTypeNotEq Refl impossible

  unitGateNotEq : (UNIT = GATE) -> Void
  unitGateNotEq Refl impossible

  unitGinstNotEq : (UNIT = GINST) -> Void
  unitGinstNotEq Refl impossible

  -- Type

  typeGateNotEq : (TYPE = GATE) -> Void
  typeGateNotEq Refl impossible

  typeGinstNotEq : (TYPE = GINST) -> Void
  typeGinstNotEq Refl impossible

  -- Gate
  gateGinstNotEq : (GATE = GINST) -> Void
  gateGinstNotEq Refl impossible

  -- Definition

  decEqTy : (x,y : Ty) -> Dec (x = y)
  decEqTy (MODULE xs) ty with (ty)
    decEqTy (MODULE xs) ty | (MODULE ys) with (decEq xs ys)
      decEqTy (MODULE ys) ty | (MODULE ys) | (Yes Refl) = Yes Refl
      decEqTy (MODULE xs) ty | (MODULE ys) | (No contra) = No (modulesDifferentNames xs ys contra)

    decEqTy (MODULE xs) ty | DATA = No (moduleDataNotEq)
    decEqTy (MODULE xs) ty | CHAN = No (moduleChanNotEq)
    decEqTy (MODULE xs) ty | (PORT x) = No (modulePortNotEq)
    decEqTy (MODULE xs) ty | (MINST ys) = No (moduleDeclmoduleInstNotEq)
    decEqTy (MODULE xs) ty | UNIT = No (moduleUnitNotEq)
    decEqTy (MODULE xs) ty | TYPE = No (moduleTypeNotEq)
    decEqTy (MODULE xs) ty | GATE = No (moduleGateNotEq)
    decEqTy (MODULE xs) ty | (GINST) = No (moduleGinstNotEq)

  decEqTy DATA ty with (ty)
    decEqTy DATA ty | (MODULE xs) = No (negEqSym moduleDataNotEq)
    decEqTy DATA ty | DATA = Yes Refl
    decEqTy DATA ty | CHAN = No (dataChanNotEq)
    decEqTy DATA ty | (PORT x) = No (dataPortNotEq)
    decEqTy DATA ty | (MINST xs) = No (dataModuleInstNotEq)
    decEqTy DATA ty | UNIT = No (dataUnitNotEq)
    decEqTy DATA ty | TYPE = No (dataTypeNotEq)
    decEqTy DATA ty | GATE = No (dataGateNotEq)
    decEqTy DATA ty | (GINST) = No (dataGinstNotEq)

  decEqTy CHAN ty with (ty)
    decEqTy CHAN ty | (MODULE xs) = No (negEqSym moduleChanNotEq)
    decEqTy CHAN ty | DATA = No (negEqSym dataChanNotEq)
    decEqTy CHAN ty | CHAN = Yes Refl
    decEqTy CHAN ty | (PORT x) = No (chanPortNotEq)
    decEqTy CHAN ty | (MINST xs) = No (chanModuleInstNotEq)
    decEqTy CHAN ty | UNIT = No (chanUnitNotEq)
    decEqTy CHAN ty | TYPE = No (chanTypeNotEq)
    decEqTy CHAN ty | GATE = No (chanGateNotEq)
    decEqTy CHAN ty | (GINST) = No (chanGinstNotEq)

  decEqTy (PORT x) ty with (ty)
    decEqTy (PORT x) ty | (MODULE xs) = No (negEqSym modulePortNotEq)
    decEqTy (PORT x) ty | DATA = No (negEqSym dataPortNotEq)
    decEqTy (PORT x) ty | CHAN = No (negEqSym chanPortNotEq)
    decEqTy (PORT x) ty | (PORT y) with (decEq x y)
      decEqTy (PORT y) ty | (PORT y) | (Yes Refl) = Yes Refl
      decEqTy (PORT x) ty | (PORT y) | (No contra) = No (portLabelMismatch contra)

    decEqTy (PORT x) ty | (MINST xs) = No (portModuleInstNotEq)
    decEqTy (PORT x) ty | UNIT = No (portUnitNotEq)
    decEqTy (PORT x) ty | TYPE = No (portTypeNotEq)
    decEqTy (PORT x) ty | GATE = No (portGateNotEq)
    decEqTy (PORT x) ty | (GINST) = No (portGinstNotEq)

  decEqTy (MINST xs) ty with (ty)
    decEqTy (MINST xs) ty | (MODULE ys) = No (negEqSym moduleDeclmoduleInstNotEq)
    decEqTy (MINST xs) ty | DATA = No (negEqSym dataModuleInstNotEq)
    decEqTy (MINST xs) ty | CHAN = No (negEqSym chanModuleInstNotEq)
    decEqTy (MINST xs) ty | (PORT x) = No (negEqSym portModuleInstNotEq)
    decEqTy (MINST xs) ty | (MINST ys) with (decEq xs ys)
      decEqTy (MINST ys) ty | (MINST ys) | (Yes Refl) = Yes Refl
      decEqTy (MINST xs) ty | (MINST ys) | (No contra) = No (moduleInstParamsDiffer xs ys contra)

    decEqTy (MINST xs) ty | UNIT = No moduleInstUnitNotEq
    decEqTy (MINST xs) ty | TYPE = No moduleInstTypeNotEq
    decEqTy (MINST xs) ty | GATE = No moduleInstGateNotEq
    decEqTy (MINST xs) ty | (GINST) = No moduleInstGinstNotEq

  decEqTy UNIT ty with (ty)
    decEqTy UNIT ty | (MODULE xs) = No (negEqSym moduleUnitNotEq)
    decEqTy UNIT ty | DATA = No (negEqSym dataUnitNotEq)
    decEqTy UNIT ty | CHAN = No (negEqSym chanUnitNotEq)
    decEqTy UNIT ty | (PORT x) = No (negEqSym portUnitNotEq)
    decEqTy UNIT ty | (MINST xs) = No (negEqSym moduleInstUnitNotEq)
    decEqTy UNIT ty | UNIT = Yes Refl
    decEqTy UNIT ty | TYPE = No unitTypeNotEq
    decEqTy UNIT ty | GATE = No unitGateNotEq
    decEqTy UNIT ty | (GINST) = No unitGinstNotEq

  decEqTy TYPE ty with (ty)
    decEqTy TYPE ty | (MODULE xs) = No (negEqSym moduleTypeNotEq)
    decEqTy TYPE ty | DATA = No (negEqSym dataTypeNotEq)
    decEqTy TYPE ty | CHAN = No (negEqSym chanTypeNotEq)
    decEqTy TYPE ty | (PORT x) = No (negEqSym portTypeNotEq)
    decEqTy TYPE ty | (MINST xs) = No (negEqSym moduleInstTypeNotEq)
    decEqTy TYPE ty | UNIT = No (negEqSym unitTypeNotEq)
    decEqTy TYPE ty | TYPE = Yes Refl
    decEqTy TYPE ty | GATE = No typeGateNotEq
    decEqTy TYPE ty | (GINST) = No typeGinstNotEq

  decEqTy GATE ty with (ty)
    decEqTy GATE ty | (MODULE xs) = No (negEqSym moduleGateNotEq)
    decEqTy GATE ty | DATA = No (negEqSym dataGateNotEq)
    decEqTy GATE ty | CHAN = No (negEqSym chanGateNotEq)
    decEqTy GATE ty | (PORT x) = No (negEqSym portGateNotEq)
    decEqTy GATE ty | (MINST xs) = No (negEqSym moduleInstGateNotEq)
    decEqTy GATE ty | UNIT = No (negEqSym unitGateNotEq)
    decEqTy GATE ty | TYPE = No (negEqSym typeGateNotEq)
    decEqTy GATE ty | GATE = Yes Refl
    decEqTy GATE ty | (GINST) = No gateGinstNotEq

  decEqTy (GINST) ty with (ty)
    decEqTy (GINST) ty | (MODULE xs) = No (negEqSym moduleGinstNotEq)
    decEqTy (GINST) ty | DATA = No (negEqSym dataGinstNotEq)
    decEqTy (GINST) ty | CHAN = No (negEqSym chanGinstNotEq)
    decEqTy (GINST) ty | (PORT x) = No (negEqSym portGinstNotEq)
    decEqTy (GINST) ty | (MINST xs) = No (negEqSym moduleInstGinstNotEq)
    decEqTy (GINST) ty | UNIT = No (negEqSym unitGinstNotEq)
    decEqTy (GINST) ty | TYPE = No (negEqSym typeGinstNotEq)
    decEqTy (GINST) ty | GATE = No (negEqSym gateGinstNotEq)
    decEqTy (GINST) ty | (GINST) = Yes Refl

  export
  DecEq Ty where
   decEq = decEqTy

namespace Validity

  namespace Decl
    public export
    data ValidDecl : (expr : Ty) -> (type : Ty) -> Type where
       IsDeclM : ValidDecl (MODULE names) TYPE
       IsDeclD : ValidDecl DATA           TYPE

    -- Modules

    moduleCannotHaveTypeModule : ValidDecl (MODULE xs) (MODULE ys) -> Void
    moduleCannotHaveTypeModule IsDeclM impossible
    moduleCannotHaveTypeModule IsDeclD impossible

    moduleCannotHaveTypeData : ValidDecl (MODULE xs) DATA -> Void
    moduleCannotHaveTypeData IsDeclM impossible
    moduleCannotHaveTypeData IsDeclD impossible

    moduleCannotHaveTypeChan : ValidDecl (MODULE xs) CHAN -> Void
    moduleCannotHaveTypeChan IsDeclM impossible
    moduleCannotHaveTypeChan IsDeclD impossible

    moduleCannotHaveTypePort : ValidDecl (MODULE xs) (PORT x) -> Void
    moduleCannotHaveTypePort IsDeclM impossible
    moduleCannotHaveTypePort IsDeclD impossible

    moduleCannotHaveTypeMInst : ValidDecl (MODULE xs) (MINST ys) -> Void
    moduleCannotHaveTypeMInst IsDeclM impossible
    moduleCannotHaveTypeMInst IsDeclD impossible

    moduleCannotHaveTypeUnit : ValidDecl (MODULE xs) UNIT -> Void
    moduleCannotHaveTypeUnit IsDeclM impossible
    moduleCannotHaveTypeUnit IsDeclD impossible

    moduleCannotHaveTypeGate : ValidDecl (MODULE xs) GATE -> Void
    moduleCannotHaveTypeGate IsDeclM impossible
    moduleCannotHaveTypeGate IsDeclD impossible

    moduleCannotHaveTypeGinst : ValidDecl (MODULE xs) (GINST) -> Void
    moduleCannotHaveTypeGinst IsDeclM impossible
    moduleCannotHaveTypeGinst IsDeclD impossible

    -- Data

    dataCannotHaveTypeModule : ValidDecl DATA (MODULE xs) -> Void
    dataCannotHaveTypeModule IsDeclM impossible
    dataCannotHaveTypeModule IsDeclD impossible

    dataCannotHaveTypeData : ValidDecl DATA DATA -> Void
    dataCannotHaveTypeData IsDeclM impossible
    dataCannotHaveTypeData IsDeclD impossible

    dataCannotHaveTypeChan : ValidDecl DATA CHAN -> Void
    dataCannotHaveTypeChan IsDeclM impossible
    dataCannotHaveTypeChan IsDeclD impossible

    dataCannotHaveTypePort : ValidDecl DATA (PORT x) -> Void
    dataCannotHaveTypePort IsDeclM impossible
    dataCannotHaveTypePort IsDeclD impossible

    dataCannotHaveTypeMInst : ValidDecl DATA (MINST xs) -> Void
    dataCannotHaveTypeMInst IsDeclM impossible
    dataCannotHaveTypeMInst IsDeclD impossible

    dataCannotHaveTypeUnit : ValidDecl DATA UNIT -> Void
    dataCannotHaveTypeUnit IsDeclM impossible
    dataCannotHaveTypeUnit IsDeclD impossible

    dataCannotHaveTypeGate : ValidDecl DATA GATE -> Void
    dataCannotHaveTypeGate IsDeclM impossible
    dataCannotHaveTypeGate IsDeclD impossible

    dataCannotHaveTypeGinst : ValidDecl DATA (GINST) -> Void
    dataCannotHaveTypeGinst IsDeclM impossible
    dataCannotHaveTypeGinst IsDeclD impossible

    -- CHAN

    chanCannotBeDecl : ValidDecl CHAN type -> Void
    chanCannotBeDecl IsDeclM impossible
    chanCannotBeDecl IsDeclD impossible

    portCannotBeDecl : ValidDecl (PORT x) type -> Void
    portCannotBeDecl IsDeclM impossible
    portCannotBeDecl IsDeclD impossible

    minstsCannotBeDecl : ValidDecl (MINST xs) type -> Void
    minstsCannotBeDecl IsDeclM impossible
    minstsCannotBeDecl IsDeclD impossible

    unitCannotBeDecl : ValidDecl UNIT type -> Void
    unitCannotBeDecl IsDeclM impossible
    unitCannotBeDecl IsDeclD impossible

    typeCannotBeDecl : ValidDecl TYPE type -> Void
    typeCannotBeDecl IsDeclM impossible
    typeCannotBeDecl IsDeclD impossible

    gateCannotBeDecl : ValidDecl GATE type -> Void
    gateCannotBeDecl IsDeclM impossible
    gateCannotBeDecl IsDeclD impossible

    ginstCannotBeDecl : ValidDecl (GINST) type -> Void
    ginstCannotBeDecl IsDeclM impossible
    ginstCannotBeDecl IsDeclD impossible

    export
    validDecl : (expr : Ty)
             -> (type : Ty)
             -> Dec (ValidDecl expr type)
    validDecl (MODULE xs) (MODULE ys) = No moduleCannotHaveTypeModule
    validDecl (MODULE xs) DATA = No moduleCannotHaveTypeData
    validDecl (MODULE xs) CHAN = No moduleCannotHaveTypeChan
    validDecl (MODULE xs) (PORT x) = No moduleCannotHaveTypePort
    validDecl (MODULE xs) (MINST ys) = No moduleCannotHaveTypeMInst
    validDecl (MODULE xs) UNIT = No moduleCannotHaveTypeUnit
    validDecl (MODULE xs) TYPE = Yes IsDeclM
    validDecl (MODULE xs) GATE = No moduleCannotHaveTypeGate
    validDecl (MODULE xs) (GINST) = No moduleCannotHaveTypeGinst

    validDecl DATA (MODULE xs) = No dataCannotHaveTypeModule
    validDecl DATA DATA = No dataCannotHaveTypeData
    validDecl DATA CHAN = No dataCannotHaveTypeChan
    validDecl DATA (PORT x) = No dataCannotHaveTypePort
    validDecl DATA (MINST xs) = No dataCannotHaveTypeMInst
    validDecl DATA UNIT = No dataCannotHaveTypeUnit
    validDecl DATA TYPE = Yes IsDeclD
    validDecl DATA GATE = No dataCannotHaveTypeGate
    validDecl DATA (GINST) = No dataCannotHaveTypeGinst

    validDecl CHAN _ = No chanCannotBeDecl
    validDecl (PORT x) _ = No portCannotBeDecl
    validDecl (MINST xs) _ = No minstsCannotBeDecl
    validDecl UNIT _ = No unitCannotBeDecl
    validDecl TYPE _ = No typeCannotBeDecl
    validDecl GATE _ = No gateCannotBeDecl
    validDecl (GINST) _ = No ginstCannotBeDecl

  namespace LetBinding
    public export
    data ValidLet : (expr : Ty) -> (type : Ty) -> Type where
       IsLetMM : (prf :                 xs  =         ys)
                     -> ValidLet (MINST xs)   (MODULE ys)

       IsLetCD : ValidLet CHAN DATA

       IsLetGG : ValidLet (GINST) GATE

       IsLetDecl : ValidDecl expr ty
                -> ValidLet  expr ty

    -- Modules

    moduleCannotHaveTypeModuleLocal : ValidLet (MODULE xs) (MODULE ys) -> Void
    moduleCannotHaveTypeModuleLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypeModuleLocal (IsLetDecl IsDeclD) impossible

    moduleCannotHaveTypeDataLocal : ValidLet (MODULE xs) DATA -> Void
    moduleCannotHaveTypeDataLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypeDataLocal (IsLetDecl IsDeclD) impossible

    moduleCannotHaveTypeChanLocal :  ValidLet (MODULE xs) CHAN -> Void
    moduleCannotHaveTypeChanLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypeChanLocal (IsLetDecl IsDeclD) impossible

    moduleCannotHaveTypePortLocal : ValidLet (MODULE xs) (PORT y) -> Void
    moduleCannotHaveTypePortLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypePortLocal (IsLetDecl IsDeclD) impossible

    moduleCannotHaveTypeMInstLocal : ValidLet (MODULE xs) (MINST ys) -> Void
    moduleCannotHaveTypeMInstLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypeMInstLocal (IsLetDecl IsDeclD) impossible

    moduleCannotHaveTypeUnitLocal : ValidLet (MODULE xs) UNIT -> Void
    moduleCannotHaveTypeUnitLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypeUnitLocal (IsLetDecl IsDeclD) impossible

    moduleCannotHaveTypeGateLocal : ValidLet (MODULE xs) GATE -> Void
    moduleCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    moduleCannotHaveTypeGInstLocal : ValidLet (MODULE xs) (GINST) -> Void
    moduleCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    moduleCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- Data

    dataCannotHaveTypeModuleLocal : ValidLet DATA (MODULE xs) -> Void
    dataCannotHaveTypeModuleLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypeModuleLocal (IsLetDecl IsDeclD) impossible

    dataCannotHaveTypeDataLocal : ValidLet DATA DATA -> Void
    dataCannotHaveTypeDataLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypeDataLocal (IsLetDecl IsDeclD) impossible

    dataCannotHaveTypeChanLocal : ValidLet DATA CHAN -> Void
    dataCannotHaveTypeChanLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypeChanLocal (IsLetDecl IsDeclD) impossible

    dataCannotHaveTypePortLocal : ValidLet DATA (PORT y) -> Void
    dataCannotHaveTypePortLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypePortLocal (IsLetDecl IsDeclD) impossible

    dataCannotHaveTypeMInstLocal : ValidLet DATA (MINST xs) -> Void
    dataCannotHaveTypeMInstLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypeMInstLocal (IsLetDecl IsDeclD) impossible

    dataCannotHaveTypeUnitLocal : ValidLet DATA UNIT -> Void
    dataCannotHaveTypeUnitLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypeUnitLocal (IsLetDecl IsDeclD) impossible

    dataCannotHaveTypeGateLocal : ValidLet DATA GATE -> Void
    dataCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    dataCannotHaveTypeGInstLocal : ValidLet DATA (GINST) -> Void
    dataCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    dataCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- Chan

    chanCannotHaveTypeType : ValidLet CHAN TYPE -> Void
    chanCannotHaveTypeType (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypeType (IsLetDecl IsDeclD) impossible

    chanCannotHaveTypeModule : ValidLet CHAN (MODULE xs) -> Void
    chanCannotHaveTypeModule (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypeModule (IsLetDecl IsDeclD) impossible

    chanCannotHaveTypeChan : ValidLet CHAN CHAN -> Void
    chanCannotHaveTypeChan (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypeChan (IsLetDecl IsDeclD) impossible

    chanCannotHaveTypePort : ValidLet CHAN (PORT y) -> Void
    chanCannotHaveTypePort (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypePort (IsLetDecl IsDeclD) impossible

    chanCannotHaveTypeMInst : ValidLet CHAN (MINST xs) -> Void
    chanCannotHaveTypeMInst (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypeMInst (IsLetDecl IsDeclD) impossible

    chanCannotHaveTypeUnit : ValidLet CHAN UNIT -> Void
    chanCannotHaveTypeUnit (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypeUnit (IsLetDecl IsDeclD) impossible

    chanCannotHaveTypeGateLocal : ValidLet CHAN GATE -> Void
    chanCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    chanCannotHaveTypeGInstLocal : ValidLet CHAN (GINST) -> Void
    chanCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    chanCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- Ports

    portCannotHaveTypeModule : ValidLet (PORT y) (MODULE xs) -> Void
    portCannotHaveTypeModule (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeModule (IsLetDecl IsDeclD) impossible

    portCannotHaveTypeData : ValidLet (PORT y) DATA -> Void
    portCannotHaveTypeData (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeData (IsLetDecl IsDeclD) impossible

    portCannotHaveTypeChan : ValidLet (PORT y) CHAN -> Void
    portCannotHaveTypeChan (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeChan (IsLetDecl IsDeclD) impossible

    portCannotHaveTypePort : ValidLet (PORT y) (PORT x) -> Void
    portCannotHaveTypePort (IsLetDecl IsDeclM) impossible
    portCannotHaveTypePort (IsLetDecl IsDeclD) impossible

    portCannotHaveTypeMInst : ValidLet (PORT y) (MINST xs) -> Void
    portCannotHaveTypeMInst (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeMInst (IsLetDecl IsDeclD) impossible

    portCannotHaveTypeUnit : ValidLet (PORT y) UNIT -> Void
    portCannotHaveTypeUnit (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeUnit(IsLetDecl IsDeclD) impossible

    portCannotHaveTypeType : ValidLet (PORT y) TYPE -> Void
    portCannotHaveTypeType (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeType (IsLetDecl IsDeclD) impossible

    portCannotHaveTypeGateLocal : ValidLet (PORT p) GATE -> Void
    portCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    portCannotHaveTypeGInstLocal : ValidLet (PORT p) (GINST) -> Void
    portCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    portCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- MINST

    minstCannotHaveTypeData : ValidLet (MINST xs) DATA -> Void
    minstCannotHaveTypeData (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypeData (IsLetDecl IsDeclD) impossible

    minstCannotHaveTypeChan : ValidLet (MINST xs) CHAN -> Void
    minstCannotHaveTypeChan (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypeChan (IsLetDecl IsDeclD) impossible

    minstCannotHaveTypePort : ValidLet (MINST xs) (PORT x) -> Void
    minstCannotHaveTypePort (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypePort (IsLetDecl IsDeclD) impossible

    minstCannotHaveTypeMInst : ValidLet (MINST xs) (MINST ys) -> Void
    minstCannotHaveTypeMInst (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypeMInst (IsLetDecl IsDeclD) impossible

    minstCannotHaveTypeUnit : ValidLet (MINST xs) UNIT -> Void
    minstCannotHaveTypeUnit (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypeUnit(IsLetDecl IsDeclD) impossible

    minstCannotHaveTypeType : ValidLet (MINST xs) TYPE -> Void
    minstCannotHaveTypeType (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypeType (IsLetDecl IsDeclD) impossible

    minstCannotHaveTypeGateLocal : ValidLet (MINST xs) GATE -> Void
    minstCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    minstCannotHaveTypeGInstLocal : ValidLet (MINST xs) (GINST) -> Void
    minstCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    minstCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- Unit
    unitCannotHaveTypeModule : ValidLet UNIT (MODULE xs) -> Void
    unitCannotHaveTypeModule (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeModule (IsLetDecl IsDeclD) impossible

    unitCannotHaveTypeData : ValidLet UNIT DATA -> Void
    unitCannotHaveTypeData (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeData (IsLetDecl IsDeclD) impossible

    unitCannotHaveTypeChan : ValidLet UNIT CHAN -> Void
    unitCannotHaveTypeChan (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeChan (IsLetDecl IsDeclD) impossible

    unitCannotHaveTypePort : ValidLet UNIT (PORT x) -> Void
    unitCannotHaveTypePort (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypePort (IsLetDecl IsDeclD) impossible

    unitCannotHaveTypeMInst : ValidLet UNIT (MINST xs) -> Void
    unitCannotHaveTypeMInst (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeMInst (IsLetDecl IsDeclD) impossible

    unitCannotHaveTypeUnit : ValidLet UNIT UNIT -> Void
    unitCannotHaveTypeUnit (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeUnit(IsLetDecl IsDeclD) impossible

    unitCannotHaveTypeType : ValidLet UNIT TYPE -> Void
    unitCannotHaveTypeType (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeType (IsLetDecl IsDeclD) impossible

    unitCannotHaveTypeGateLocal : ValidLet UNIT GATE -> Void
    unitCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    unitCannotHaveTypeGInstLocal : ValidLet UNIT (GINST) -> Void
    unitCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    unitCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- TYPE

    typeCannotHaveTypeModule : ValidLet TYPE (MODULE xs) -> Void
    typeCannotHaveTypeModule (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeModule (IsLetDecl IsDeclD) impossible

    typeCannotHaveTypeData : ValidLet TYPE DATA -> Void
    typeCannotHaveTypeData (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeData (IsLetDecl IsDeclD) impossible

    typeCannotHaveTypeChan : ValidLet TYPE CHAN -> Void
    typeCannotHaveTypeChan (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeChan (IsLetDecl IsDeclD) impossible

    typeCannotHaveTypePort : ValidLet TYPE (PORT x) -> Void
    typeCannotHaveTypePort (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypePort (IsLetDecl IsDeclD) impossible

    typeCannotHaveTypeMInst : ValidLet TYPE (MINST xs) -> Void
    typeCannotHaveTypeMInst (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeMInst (IsLetDecl IsDeclD) impossible

    typeCannotHaveTypeUnit : ValidLet TYPE UNIT -> Void
    typeCannotHaveTypeUnit (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeUnit(IsLetDecl IsDeclD) impossible

    typeCannotHaveTypeType : ValidLet TYPE TYPE -> Void
    typeCannotHaveTypeType (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeType (IsLetDecl IsDeclD) impossible

    typeCannotHaveTypeGateLocal : ValidLet TYPE GATE -> Void
    typeCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    typeCannotHaveTypeGInstLocal : ValidLet TYPE (GINST) -> Void
    typeCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    typeCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- Gates

    gateCannotHaveTypeModuleLocal : ValidLet GATE (MODULE xs) -> Void
    gateCannotHaveTypeModuleLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeModuleLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypeDataLocal : ValidLet GATE DATA -> Void
    gateCannotHaveTypeDataLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeDataLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypeChanLocal : ValidLet GATE CHAN -> Void
    gateCannotHaveTypeChanLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeChanLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypePortLocal : ValidLet GATE (PORT y) -> Void
    gateCannotHaveTypePortLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypePortLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypeMInstLocal : ValidLet GATE (MINST xs) -> Void
    gateCannotHaveTypeMInstLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeMInstLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypeUnitLocal : ValidLet GATE UNIT -> Void
    gateCannotHaveTypeUnitLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeUnitLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypeGateLocal : ValidLet GATE GATE -> Void
    gateCannotHaveTypeGateLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeGateLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypeGInstLocal : ValidLet GATE (GINST) -> Void
    gateCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    gateCannotHaveTypeTypeLocal : ValidLet GATE TYPE -> Void
    gateCannotHaveTypeTypeLocal (IsLetDecl IsDeclM) impossible
    gateCannotHaveTypeTypeLocal (IsLetDecl IsDeclD) impossible

    -- GInst

    ginstCannotHaveTypeModuleLocal : ValidLet (GINST) (MODULE xs) -> Void
    ginstCannotHaveTypeModuleLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypeModuleLocal (IsLetDecl IsDeclD) impossible

    ginstCannotHaveTypeDataLocal : ValidLet (GINST) DATA -> Void
    ginstCannotHaveTypeDataLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypeDataLocal (IsLetDecl IsDeclD) impossible

    ginstCannotHaveTypeChanLocal : ValidLet (GINST) CHAN -> Void
    ginstCannotHaveTypeChanLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypeChanLocal (IsLetDecl IsDeclD) impossible

    ginstCannotHaveTypePortLocal : ValidLet (GINST) (PORT y) -> Void
    ginstCannotHaveTypePortLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypePortLocal (IsLetDecl IsDeclD) impossible

    ginstCannotHaveTypeMInstLocal : ValidLet (GINST) (MINST xs) -> Void
    ginstCannotHaveTypeMInstLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypeMInstLocal (IsLetDecl IsDeclD) impossible

    ginstCannotHaveTypeUnitLocal : ValidLet (GINST) UNIT -> Void
    ginstCannotHaveTypeUnitLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypeUnitLocal (IsLetDecl IsDeclD) impossible

    ginstCannotHaveTypeTypeLocal : ValidLet (GINST) TYPE -> Void
    ginstCannotHaveTypeTypeLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypeTypeLocal (IsLetDecl IsDeclD) impossible

    ginstCannotHaveTypeGInstLocal : ValidLet (GINST) (GINST) -> Void
    ginstCannotHaveTypeGInstLocal (IsLetDecl IsDeclM) impossible
    ginstCannotHaveTypeGInstLocal (IsLetDecl IsDeclD) impossible

    -- Misc
    minstAndModulesHaveDiffNames : (f : (xs = ys) -> Void)
                                -> ValidLet (MINST xs) (MODULE ys)
                                -> Void
    minstAndModulesHaveDiffNames f (IsLetMM Refl) = f Refl
    minstAndModulesHaveDiffNames _ (IsLetDecl IsDeclM) impossible
    minstAndModulesHaveDiffNames _ (IsLetDecl IsDeclD) impossible

    export
    validLet : (expr : Ty)
            -> (type : Ty)
            -> Dec (ValidLet expr type)
    validLet (MODULE xs) (MODULE ys) = No moduleCannotHaveTypeModuleLocal
    validLet (MODULE xs) DATA        = No moduleCannotHaveTypeDataLocal
    validLet (MODULE xs) CHAN        = No moduleCannotHaveTypeChanLocal
    validLet (MODULE xs) (PORT x)    = No moduleCannotHaveTypePortLocal
    validLet (MODULE xs) (MINST ys)  = No moduleCannotHaveTypeMInstLocal
    validLet (MODULE xs) UNIT        = No moduleCannotHaveTypeUnitLocal
    validLet (MODULE xs) TYPE        = Yes (IsLetDecl IsDeclM)
    validLet (MODULE xs) GATE        = No moduleCannotHaveTypeGateLocal
    validLet (MODULE xs) (GINST) = No moduleCannotHaveTypeGInstLocal

    validLet DATA (MODULE xs) = No (dataCannotHaveTypeModuleLocal)
    validLet DATA DATA        = No (dataCannotHaveTypeDataLocal)
    validLet DATA CHAN        = No (dataCannotHaveTypeChanLocal)
    validLet DATA (PORT x)    = No (dataCannotHaveTypePortLocal)
    validLet DATA (MINST xs)  = No (dataCannotHaveTypeMInstLocal)
    validLet DATA UNIT        = No (dataCannotHaveTypeUnitLocal)
    validLet DATA TYPE        = Yes (IsLetDecl IsDeclD)
    validLet DATA GATE         = No dataCannotHaveTypeGateLocal
    validLet DATA (GINST) = No dataCannotHaveTypeGInstLocal

    validLet CHAN (MODULE xs) = No (chanCannotHaveTypeModule)
    validLet CHAN DATA        = Yes IsLetCD
    validLet CHAN CHAN        = No (chanCannotHaveTypeChan)
    validLet CHAN (PORT x)    = No (chanCannotHaveTypePort)
    validLet CHAN (MINST xs)  = No (chanCannotHaveTypeMInst)
    validLet CHAN UNIT        = No (chanCannotHaveTypeUnit)
    validLet CHAN TYPE        = No (chanCannotHaveTypeType)
    validLet CHAN GATE         = No chanCannotHaveTypeGateLocal
    validLet CHAN (GINST) = No chanCannotHaveTypeGInstLocal

    validLet (PORT x) (MODULE xs) =  No portCannotHaveTypeModule
    validLet (PORT x) DATA        =  No portCannotHaveTypeData
    validLet (PORT x) CHAN        =  No (portCannotHaveTypeChan)
    validLet (PORT x) (PORT y)    =  No portCannotHaveTypePort
    validLet (PORT x) (MINST xs)  =  No portCannotHaveTypeMInst
    validLet (PORT x) UNIT        =  No portCannotHaveTypeUnit
    validLet (PORT x) TYPE        =  No portCannotHaveTypeType
    validLet (PORT x) GATE         = No portCannotHaveTypeGateLocal
    validLet (PORT x) (GINST) = No portCannotHaveTypeGInstLocal

    validLet (MINST xs) (MODULE ys) with (decEq xs ys)
      validLet (MINST ys) (MODULE ys) | (Yes Refl) = Yes (IsLetMM Refl)
      validLet (MINST xs) (MODULE ys) | (No contra) = No (minstAndModulesHaveDiffNames contra)

    validLet (MINST xs) DATA       =  No minstCannotHaveTypeData
    validLet (MINST xs) CHAN       =  No minstCannotHaveTypeChan
    validLet (MINST xs) (PORT x)   =  No minstCannotHaveTypePort
    validLet (MINST xs) (MINST ys) =  No minstCannotHaveTypeMInst
    validLet (MINST xs) UNIT       =  No minstCannotHaveTypeUnit
    validLet (MINST xs) TYPE       =  No minstCannotHaveTypeType
    validLet (MINST xs) GATE         = No minstCannotHaveTypeGateLocal
    validLet (MINST xs) (GINST) = No minstCannotHaveTypeGInstLocal

    validLet UNIT (MODULE xs) = No unitCannotHaveTypeModule
    validLet UNIT DATA        = No unitCannotHaveTypeData
    validLet UNIT CHAN        = No unitCannotHaveTypeChan
    validLet UNIT (PORT x)    = No unitCannotHaveTypePort
    validLet UNIT (MINST xs)  = No unitCannotHaveTypeMInst
    validLet UNIT UNIT        = No unitCannotHaveTypeUnit
    validLet UNIT TYPE        = No unitCannotHaveTypeType
    validLet UNIT GATE         = No unitCannotHaveTypeGateLocal
    validLet UNIT (GINST) = No unitCannotHaveTypeGInstLocal

    validLet TYPE (MODULE xs) = No typeCannotHaveTypeModule
    validLet TYPE DATA        = No typeCannotHaveTypeData
    validLet TYPE CHAN        = No typeCannotHaveTypeChan
    validLet TYPE (PORT y)    = No typeCannotHaveTypePort
    validLet TYPE (MINST xs)  = No typeCannotHaveTypeMInst
    validLet TYPE UNIT        = No typeCannotHaveTypeUnit
    validLet TYPE TYPE        = No typeCannotHaveTypeType
    validLet TYPE GATE         = No typeCannotHaveTypeGateLocal
    validLet TYPE (GINST) = No typeCannotHaveTypeGInstLocal

    validLet GATE (MODULE xs)   = No gateCannotHaveTypeModuleLocal
    validLet GATE DATA          = No gateCannotHaveTypeDataLocal
    validLet GATE CHAN          = No gateCannotHaveTypeChanLocal
    validLet GATE (PORT y)      = No gateCannotHaveTypePortLocal
    validLet GATE (MINST xs)    = No gateCannotHaveTypeMInstLocal
    validLet GATE UNIT          = No gateCannotHaveTypeUnitLocal
    validLet GATE TYPE          = No gateCannotHaveTypeTypeLocal
    validLet GATE GATE          = No gateCannotHaveTypeGateLocal
    validLet GATE (GINST) = No gateCannotHaveTypeGInstLocal

    validLet (GINST) (MODULE xs)     = No ginstCannotHaveTypeModuleLocal
    validLet (GINST) DATA            = No ginstCannotHaveTypeDataLocal
    validLet (GINST) CHAN            = No ginstCannotHaveTypeChanLocal
    validLet (GINST) (PORT y)        = No ginstCannotHaveTypePortLocal
    validLet (GINST) (MINST xs)      = No ginstCannotHaveTypeMInstLocal
    validLet (GINST) UNIT            = No ginstCannotHaveTypeUnitLocal
    validLet (GINST) TYPE            = No ginstCannotHaveTypeTypeLocal
    validLet (GINST) GATE            = Yes IsLetGG
    validLet (GINST) GINST           = No ginstCannotHaveTypeGInstLocal

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


import Data.List
import System.Concurrency

consumer : Channel Nat -> IO ()
consumer c =
  do (S k) <- channelGet c
      | Z => pure ()
     consumer c

producer : Channel Nat -> IO ()
producer c = ignore $ traverse (\n => channelPut c n) [1..100]

nConsumers : Nat
nConsumers = 3

nProducers : Nat
nProducers = 5

main : IO ()
main =
  do c <- makeChannel
     cTIDs <- for (replicate nConsumers 0) $ \_ => fork (consumer c)
     pTIDs <- for (replicate nProducers 0) $ \_ => fork (producer c)
     ignore $ traverse (\t => threadWait t) pTIDs
     ignore $ for (replicate nConsumers 0) $ \_ => channelPut c Z
     ignore $ traverse (\t => threadWait t) cTIDs
     putStrLn "SUCCESS!!!"


module System.FFI.Lua

import Data.List

%default total

export
data External : Type where [external]

%foreign "idris.support.world|support"
world : External

%foreign "function(_) end"
prim__compile : List External -> PrimIO ()

export
compile : HasIO io => List External -> io ()
compile externals = primIO (prim__compile externals)

export
data OpaqueDict : Type where [external]

-- TODO: How we properly manage nil?

public export
data Dict : List (String, Type) -> Type where
  MkDict : OpaqueDict -> Dict ts

public export
data List : List Type -> Type where
  MkList : (n : Nat) -> OpaqueDict -> n = length ts => List ts

%foreign "{}"
prim__empty : OpaqueDict

namespace Dict
  public export
  data FieldType : String -> Type -> List (String, Type) -> Type where
    First : FieldType n t ((n, t) :: ts)
    Later : FieldType n t ts -> FieldType n t (f :: ts)

  %foreign "_, d, n => d[n]"
  prim__getField : OpaqueDict -> (n : String) -> ty

  %foreign "_, d, n, v => function(_) d[n] = v end"
  prim__setField : OpaqueDict -> (n : String) -> ty -> PrimIO ()

  public export %inline
  getField : Dict ts -> (n : String) -> FieldType n ty ts => ty
  getField (MkDict dict) field = prim__getField dict field

  public export %inline
  setField : HasIO io => Dict ts -> (n : String) -> FieldType n ty ts => ty -> io ()
  setField (MkDict dict) field val = primIO $ prim__setField dict field val

  export
  empty : Dict []
  empty = MkDict prim__empty

  export
  addField : HasIO io => (n : String) -> (val : t) -> Dict ts -> io (Dict ((n, t) :: ts))
  addField n val (MkDict dict) = do
    primIO $ prim__setField dict n val
    pure (MkDict dict)

namespace List
  public export
  data FieldType : Nat -> Type -> List Type -> Type where
    First : FieldType 1 t (t :: ts)
    Later : FieldType n t ts -> FieldType (S n) t (t' :: ts)

  %foreign "_, d, n => d[n]"
  prim__getField : OpaqueDict -> (n : Nat) -> ty

  %foreign "_, d, n, v => function(_) d[n] = v end"
  prim__setField : OpaqueDict -> (n : Nat) -> ty -> PrimIO ()

  public export %inline
  getField : List ts -> (n : Nat) -> FieldType n ty ts => ty
  getField (MkList _ list) field = prim__getField list field

  public export %inline
  setField : HasIO io => List ts -> (n : Nat) -> FieldType n ty ts => ty -> io ()
  setField (MkList _ list) field val = primIO $ prim__setField list field val

  export
  empty : List []
  empty = MkList _ prim__empty

  lengthSuc : (xs : List a) -> (y : a) -> (ys : List a) ->
              length (xs ++ (y :: ys)) = S (length (xs ++ ys))
  lengthSuc [] _ _ = Refl
  lengthSuc (x :: xs) y ys = cong S (lengthSuc xs y ys)

  export
  addField : HasIO io => (val : t) -> List ts -> io (List (ts ++ [t]))
  addField val (MkList size list @{prf}) = do
    primIO $ prim__setField list (S size) val
    pure (MkList (S size) list @{rewrite prf in
                                 rewrite lengthSuc ts t [] in
                                 rewrite appendNilRightNeutral ts in Refl})

%foreign "v, _ => v == nil"
prim__isNil : OpaqueDict -> PrimIO Bool

isNil : HasIO io => OpaqueDict -> io Bool
isNil = primIO . prim__isNil


||| Spec: https://webassembly.github.io/spec/core/syntax/types.html#external-types
module WebAssembly.Structure.Types.ExternalTypes

import WebAssembly.Structure.Types.ValueTypes
import WebAssembly.Structure.Types.FunctionTypes
import WebAssembly.Structure.Types.TableTypes
import WebAssembly.Structure.Types.Limits
import WebAssembly.Structure.Types.MemoryTypes
import WebAssembly.Structure.Types.GlobalTypes

import Decidable.Equality

-- Definition

public export
data ExternType : Type where
  Func   : FuncType    -> ExternType
  Table  : TableType   -> ExternType
  Mem    : MemType     -> ExternType
  Global : GlobalType  -> ExternType

-- Equality

total public export
lemma_externtype__func_injective : ((x = y) -> Void) -> (Func x = Func y) -> Void
lemma_externtype__func_injective func_types_neq Refl = func_types_neq Refl

total public export
lemma_externtype__table_injective : ((x = y) -> Void) -> (Table x = Table y) -> Void
lemma_externtype__table_injective table_tables_neq Refl = table_tables_neq Refl

total public export
lemma_externtype__mem_injective : ((x = y) -> Void) -> (Mem x = Mem y) -> Void
lemma_externtype__mem_injective mem_types_neq Refl = mem_types_neq Refl

total public export
lemma_externtype__global_injective : ((x = y) -> Void) -> (Global x = Global y) -> Void
lemma_externtype__global_injective global_types_neq Refl = global_types_neq Refl

total public export
lemma_func_not_table : (Func x = Table y) -> Void
lemma_func_not_table Refl impossible

total public export
lemma_func_not_mem : (Func x = Mem y) -> Void
lemma_func_not_mem Refl impossible

total public export
lemma_func_not_global : (Func x = Global y) -> Void
lemma_func_not_global Refl impossible

total public export
lemma_table_not_func : (Table x = Func y) -> Void
lemma_table_not_func Refl impossible

total public export
lemma_table_not_mem : (Table x = Mem y) -> Void
lemma_table_not_mem Refl impossible

total public export
lemma_table_not_global : (Table x = Global y) -> Void
lemma_table_not_global Refl impossible

total public export
lemma_mem_not_func : (Mem x = Func y) -> Void
lemma_mem_not_func Refl impossible

total public export
lemma_mem_not_table : (Mem x = Table y) -> Void
lemma_mem_not_table Refl impossible

total public export
lemma_mem_not_global : (Mem x = Global y) -> Void
lemma_mem_not_global Refl impossible

total public export
lemma_global_not_func : (Global x = Func y) -> Void
lemma_global_not_func Refl impossible

total public export
lemma_global_not_table : (Global x = Table y) -> Void
lemma_global_not_table Refl impossible

total public export
lemma_global_not_mem : (Global x = Mem y) -> Void
lemma_global_not_mem Refl impossible

-- Decidable Equality

public export
implementation DecEq ExternType where
  decEq (Func x)   (Func y)   = case decEq x y of
    No func_types_neq => No (lemma_externtype__func_injective func_types_neq)
    Yes Refl          => Yes Refl
  decEq (Table x)  (Table y)  = case decEq x y of
    No table_tables_neq => No (lemma_externtype__table_injective table_tables_neq)
    Yes Refl            => Yes Refl
  decEq (Mem x)    (Mem y)    = case decEq x y of
    No mem_types_neq => No (lemma_externtype__mem_injective mem_types_neq)
    Yes Refl         => Yes Refl
  decEq (Global x) (Global y) = case decEq x y of
    No global_types_neq => No (lemma_externtype__global_injective global_types_neq)
    Yes Refl            => Yes Refl
  decEq (Func x)   (Table y)  = No lemma_func_not_table
  decEq (Func x)   (Mem y)    = No lemma_func_not_mem
  decEq (Func x)   (Global y) = No lemma_func_not_global
  decEq (Table x)  (Func y)   = No lemma_table_not_func
  decEq (Table x)  (Mem y)    = No lemma_table_not_mem
  decEq (Table x)  (Global y) = No lemma_table_not_global
  decEq (Mem x)    (Func y)   = No lemma_mem_not_func
  decEq (Mem x)    (Table y)  = No lemma_mem_not_table
  decEq (Mem x)    (Global y) = No lemma_mem_not_global
  decEq (Global x) (Func y)   = No lemma_global_not_func
  decEq (Global x) (Table y)  = No lemma_global_not_table
  decEq (Global x) (Mem y)    = No lemma_global_not_mem


module effects

import Data.Vect

import Effects
import Effect.StdIO

vadd : Vect n Int -> Vect n Int -> Vect n Int
vadd [] [] = []
vadd (x :: xs) (y :: ys) = x + y :: vadd xs ys

hello : Eff () [STDIO]
hello = putStrLn "hello, world!"

main : IO ()
main = run hello