-- --------------------------------------------------------- [ Concurrency.idr ]
-- Module      : Chapter.Concurrency
-- Description : Definitions from Chapter 15 of Edwin Brady's book,
--               "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Chapter.Concurrency

import System.Concurrency.Channels
import Chapter.Concurrency.ProcessLib

-- import Control.Arrow
-- import Control.Category
-- import Data.Morphisms

-- ------------------------------------ [ 15.1.1 Defining Concurrent Processes ]

%access public export

data Message = Add Nat Nat

-- ---------------------------------------- [ 15.1.2 Primitive Message Passing ]

namespace Unsafe

  %access export

  partial adder :IO ()
  adder = do Just chan <- listen 1
               | Nothing => adder
             Just msg <- unsafeRecv Message chan
               | Nothing => adder
             case msg of
                  Add x y => do ok <- unsafeSend chan (x + y)
                                adder

  partial main : IO ()
  main = do Just pid <- spawn adder
              | Nothing => putStrLn "Spawn failed"
            Just chan <- connect pid
              | Nothing => putStrLn "Connection failed"
            ok <- unsafeSend chan (Add 2 3)
            Just answer <- unsafeRecv Nat chan
              | Nothing => putStrLn "Receive failed"
            printLn answer

-- ----------------------------------- [ 15.2.1 Describing Processes in a Type ]

namespace Safe

  %access public export

  data MessagePID = MkMessage PID

  data Process : Type -> Type where
       Request : MessagePID -> Message -> Process (Maybe Nat)
       Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message)
       Spawn   : Process () -> Process (Maybe MessagePID)
       Loop    : Inf (Process a) -> Process a

       Action  : IO a -> Process a
       Pure    : a -> Process a
       (>>=)   : Process a -> (a -> Process b) -> Process b

  run : Fuel -> Process t -> IO (Maybe t)
  run Dry _                  = pure Nothing
  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 (More fuel) (Loop act) = run fuel act
  run fuel (Spawn proc)   = do Just pid <- spawn (run fuel proc *> pure ())
                                 | Nothing => pure Nothing
                               pure (Just (Just (MkMessage pid)))
  -- TODO: encapsulate timeout
  run fuel (Respond calc) = do Just sender <- listen 1
                                 | Nothing => pure (Just Nothing)
                               Just msg <- unsafeRecv Message sender
                                 | Nothing => pure (Just Nothing)
                               Just res <- run fuel (calc msg)
                                 | Nothing => pure Nothing
                               unsafeSend sender res
                               pure (Just (Just msg))
  run fuel (Request (MkMessage proc) msg) =
      do Just chan <- connect proc
           | Nothing => pure (Just Nothing)
         if !(unsafeSend chan msg)
            then do Just x <- unsafeRecv Nat chan
                      | Nothing => pure (Just Nothing)
                    pure (Just (Just x))
            else pure (Just Nothing)

  partial runProc : Process () -> IO ()
  runProc proc = run forever proc *> pure ()

  adder : Process ()
  adder = do Respond go
             Loop adder
    where
      go : Message -> Process Nat
      go (Add x y) = Pure (x + y)

  partial main : Process ()
  main = do Just pid <- Spawn adder
              | Nothing => Action (putStrLn "Spawn failed")
            Just answer <- Request pid (Add 2 3)
              | Nothing => Action (putStrLn "Request failed")
            Action (printLn answer)

  -- NOTE: These two definitions type-check, but don't respond to messages.

  -- adderBad1 : Process ()
  -- adderBad1 = do Action $ putStrLn "I'm out of the office today"
  --                    Loop adderBad1

  -- adderBad2 : Process ()
  -- adderBad2 = Loop adderBad2

namespace Stateful

  -- data AdderAction : Type where
  --      Add : Nat -> Nat -> AdderAction

  public export
  AdderType : Message -> Type
  AdderType (Add x y) = Nat

  export
  adder : Service AdderType ()
  adder = do Respond (\(Add x y) => Pure (x + y))
             Loop adder

namespace ListProcessing

  %access public export

  data ListAction : Type where
       Length : List elem -> ListAction
       Append : List elem -> List elem -> ListAction

  ListType : ListAction -> Type
  ListType (Length xs)           = Nat
  ListType (Append {elem} xs ys) = List elem

  %access export

  procList : Service ListType ()
  procList = do Respond go
                Loop procList
    where
      go : (msg : ListAction) -> Process ListType (ListType msg) Ready Ready
      go (Length xs)    = Pure (length xs)
      go (Append xs ys) = Pure (xs ++ ys)

  procMain : Client ()
  procMain = do Just list <- Spawn procList
                  | Nothing => Action (putStrLn "Spawn failed")
                len <- Request list (Length [1,2,3])
                Action (printLn len)
                app <- Request list (Append [1,2,3] [4,5,6])
                Action (printLn app)

namespace WordCounting

  %access public export

  record WCData where
      constructor MkWCData
      wordCount : Nat
      lineCount : Nat

  implementation Show WCData where
    show (MkWCData wc lc) = unlines [ "Words: " ++ show wc
                                    , "Lines: " ++ show lc
                                    ]

  data WC = CountFile String
          | GetData String

  implementation Show WC where
    show (CountFile fname) = "CountFile " ++ fname
    show (GetData fname) = "GetData " ++ fname

  WCType : WC -> Type
  WCType (CountFile _) = ()
  WCType (GetData _)   = Maybe WCData

  private
  doCount : (content : String) -> WCData
  doCount content = MkWCData (length (lines content))
                             (length (words content))

  -- doCount' : (content : String) -> WCData
  -- doCount' = applyMor $ arrow (length . lines) &&&
  --                       arrow (length . words) >>>
  --                       arrow (uncurry MkWCData)

  countFile : List (String, WCData) -> String ->
              Process WCType (List (String, WCData)) Sent Sent
  countFile files fname =
      do Right content <- Action (readFile fname)
           | Left _ => Pure files
         let count = doCount content
         Action (putStrLn ("Counting complete for " ++ fname))
         Pure ((fname, doCount content) :: files)

  wcService : (loaded : List (String, WCData)) ->
              Service WCType ()
  wcService loaded =
      do msg <- Respond go
         newLoaded <- case msg of
              Just (CountFile fname) => countFile loaded fname
              _                      => Pure loaded
         Loop (wcService newLoaded)
    where
      go : (msg : WC) -> Process WCType (WCType msg) Ready Ready
      go (CountFile fname) = Pure ()
      go (GetData fname)   = Pure (lookup fname loaded)

  procMain : Client ()
  procMain =
      do Just wc <- Spawn (wcService [])
           | Nothing => Action (putStrLn "Spawn failed")
         Action (putStrLn "Counting test.txt")
         let fname = "/Users/mohacker/src/yurrriq/tdd-with-idris/README.org"
         Request wc (CountFile fname)
         Action (putStrLn "Processing")
         Just wcdata <- Request wc (GetData fname)
           | Nothing => Action (putStrLn "File error")
         Action (printLn wcdata)

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


> module SequentialDecisionProblems.applications.Main

> import Data.Fin
> import Data.List
> import Data.List.Quantifiers
> import Data.So
> import Effects
> import Effect.Exception
> import Effect.StdIO

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.FullTheory
> import SequentialDecisionProblems.TabBackwardsInduction
> import SequentialDecisionProblems.Utils
> import SequentialDecisionProblems.FastStochasticDefaults
> import SequentialDecisionProblems.CoreTheoryOptDefaults
> import SequentialDecisionProblems.FullTheoryOptDefaults
> import SequentialDecisionProblems.TabBackwardsInductionOptDefaults

> import FastSimpleProb.SimpleProb
> import FastSimpleProb.BasicOperations
> import FastSimpleProb.BasicProperties
> import FastSimpleProb.MonadicOperations
> import FastSimpleProb.MonadicProperties
> import FastSimpleProb.Measures
> import FastSimpleProb.MeasuresProperties
> import FastSimpleProb.Operations
> import Sigma.Sigma
> import Sigma.Operations
> import Sigma.Properties
> import Nat.LTProperties
> import Double.Predicates
> import Double.Postulates
> import Double.Operations
> import Double.Properties
> import NonNegDouble.NonNegDouble
> import NonNegDouble.Constants
> import NonNegDouble.BasicOperations
> import NonNegDouble.Operations
> import NonNegDouble.Properties
> import NonNegDouble.Predicates
> import NonNegDouble.LTEProperties
> import NonNegDouble.Measures
> import NonNegDouble.MeasureProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Unique.Predicates
> import Decidable.Predicates
> import Decidable.Properties
> import LocalEffect.Exception
> import LocalEffect.StdIO
> import Fin.Operations
> import Fraction.Fraction
> import Fraction.Normal
> import Nat.Positive
> import List.Operations
> import Unit.Properties

> -- %default total
> %auto_implicits off
> -- %logging 5

> computation : { [STDIO] } Eff ()
> computation =
>   do putStrLn "done!"

> main : IO ()
> main = run computation

> {-

> ---}

-- Local Variables:
-- idris-packages: ("effects")
-- End:


module Cordial.EDSL.Description.Lang

import Data.Vect
import Data.List.Quantifiers
import Data.Ranged

import Text.Markup.Edda

import Language.EDSL.SingleStateVar

import Cordial.Model.Specification

%default total
%access public export

-- ------------------------------------------------- [ Important Language Defs ]

data Used = FREE | USED

||| State associated with labels.
record State (labelType : Type) where
  constructor MkState
  used  : Used
  label : labelType

VarState : Type -> Type
VarState labelTy = StateItem (State labelTy)

Gamma : Type -> Type
Gamma labelTy = Context (State labelTy)

-- -------------------------------------------------------------- [ Predicates ]

namespace Predicates

  data CanUseVar : (labelTy : Type) -> Var -> VarState labelTy -> Type where
    FreeName : CanUseVar type lbl (MkStateItem lbl $ MkState FREE val)

  data UsedVar : (labelTy : Type) -> VarState labelTy -> Type where
    NameIsUsed : UsedVar type (MkStateItem lbl $ MkState USED val)

  VarsAllUsed : (labelTy : Type) -> (ctxt : Gamma labelTy) -> Type
  VarsAllUsed labelTy ctxt =
    AllContext (UsedVar labelTy) ctxt

  data VarIsNotNamed : (labelTy : Type)
                    -> (label : labelTy)
                    -> VarState labelTy
                    -> Type where
    IsNotNamed : Eq labelTy
              => {l,r : labelTy}
              -> (prf : l /= r = True)
              -> VarIsNotNamed labelTy l (MkStateItem lbl (MkState u r))

  CanUseName : (label : labelTy) -> (ctxt : Gamma labelTy) -> Type
  CanUseName {labelTy} label =
    AllContext (VarIsNotNamed labelTy label)

-- ----------------------------------------------------------------- [ Updates ]

namespace Functions
  Consume : (item : VarState labelTy)
         -> (bewijs : CanUseVar labelTy lbl item)
         -> VarState labelTy
  Consume item bewijs with (bewijs)
    Consume (MkStateItem lbl (MkState FREE val)) bewijs | FreeName =
      MkStateItem lbl (MkState USED val)

-- ------------------------------------------------------------- [ Expressions ]

record Metadata where
  constructor MkMetadata
  mvendor  : Maybe String
  mlibrary : Maybe String
  mname    : Maybe String
  mversion : Maybe String
  mmaxp    : Maybe Whole
  mmaxc    : Maybe Whole
  mcstyle  : Maybe CommStyle
  mdoc     : Maybe DocString

processMetadata : Metadata -> (VLNV, (Whole, Whole), CommStyle, DocString)
processMetadata (MkMetadata mvendor mlibrary mname mversion mmax mmin mcstyle mdoc) =
  let vlnv = MkVLNV (fromMaybe "Default Vendor" mvendor)
                    (fromMaybe "Default Library" mlibrary)
                    (fromMaybe "Default Name" mname)
                    (fromMaybe "Default Version" mversion) in
  let a = (fromMaybe (fromNat 1) mmin, fromMaybe (fromNat 1) mmax) in
  let c = fromMaybe Unicast mcstyle in
  let d = fromMaybe Empty mdoc in
    (vlnv, a,c,d)

defaultMetadata : Metadata
defaultMetadata =
  MkMetadata
     Nothing
     Nothing
     Nothing
     Nothing
     Nothing
     Nothing
     Nothing
     Nothing

data ExprTy = DECL | MDATA | NAME | END

data IDescribe : (labelTy : Type) -> Lang ExprTy (State labelTy) where
   NewName : (name : labelTy)
          -> (prf  : CanUseName name old)
          -> IDescribe labelTy NAME Var old (\lbl => MkStateItem lbl (MkState FREE name)::old)

   Stop : (prf : VarsAllUsed labelTy old)
       -> IDescribe labelTy END () old (const Nil)

   SetMetadata : (Metadata -> Metadata)
              -> IDescribe labelTy MDATA () old (const old)

   DeclareSignal : (label  : Var)
                -> (kind  : PortShape)
                -> (wirety : WireTy)
                -> (flow  : Flow)
                -> (width : PortWidthDesc kind)

                -> (sense : Sensitivity)

                -> (required : OptionalTy)
                -> (origin   : Origin)

                -> (vorigin : ValueOrigin width)
                -> (doc : DocString)

                -> (prf : InContext (CanUseVar labelTy label) old)

                -> IDescribe labelTy DECL () old (const $ update Consume old prf)

   Replicate : (n : Nat)
            -> (var : Var)
            -> (kind : PortShape)
            -> (wirety : WireTy)
            -> (flow  : Flow)
            -> (width : PortWidthDesc kind)

            -> (sense : Sensitivity)

            -> (required : OptionalTy)
            -> (origin   : Origin)

            -> (vorigin : ValueOrigin width)
            -> (doc : DocString)
            -> (prf : InContext (CanUseVar labelTy var) old)
            -> IDescribe labelTy DECL () old (const $ update Consume old prf)

LangIDL : (labelTy : Type) -> LANG ExprTy (State labelTy)
LangIDL labelTy = MkLang ExprTy
                         (State labelTy)
                         (Name WHOLE labelTy)
                         (IDescribe labelTy)

namespace API
  IDL' : (labelTy : Type) -> (m : Type -> Type) -> Type
  IDL' ty m = LangM m () (LangIDL ty) (TyStmt) Nil (const Nil)

  label : (name : labelTy)
         -> {auto prf : CanUseName name old}
         -> LangM m Var (LangIDL labelTy) (TyExpr NAME) old (\lbl => MkStateItem lbl (MkState FREE name)::old)
  label n {prf} = Expr $ NewName n prf

  stop : {auto prf : VarsAllUsed labelTy old}
      -> LangM m () (LangIDL labelTy) (TyExpr END) old (const Nil)
  stop {prf} = Expr (Stop prf)

  setMetadata : (Metadata -> Metadata) -> LangM m () (LangIDL labelTy) (TyExpr MDATA) old (const old)
  setMetadata f = Expr (SetMetadata f)

  signal : (label  : Var)
        -> (kind  : PortShape)
        -> (wirety : WireTy)
        -> (flow  : Flow)
        -> (width : PortWidthDesc kind)

        -> (sense : Sensitivity)

        -> (required : OptionalTy)
        -> (origin   : Origin)

        -> (vorigin : ValueOrigin width)
        -> (doc : DocString)

        -> (prf : InContext (CanUseVar labelTy label) old)
        -> LangM m () (LangIDL labelTy) (TyExpr DECL) old (const $ update Consume old prf)
  signal label kind wirety flow width sense required origin vorigin doc prf =
    Expr $ DeclareSignal label kind wirety flow width sense required origin vorigin doc prf

  replicateExpr : (n : Nat)
           -> (var : Var)
           -> (kind : PortShape)
           -> (wirety : WireTy)
           -> (flow  : Flow)
           -> (width : PortWidthDesc kind)

           -> (sense : Sensitivity)

           -> (required : OptionalTy)
           -> (origin   : Origin)

           -> (vorigin : ValueOrigin width)
           -> (doc : DocString)
           -> {auto prf : InContext (CanUseVar labelTy var) old}

           -> LangM m () (LangIDL labelTy) (TyExpr DECL) old (const $ update Consume old prf)
  replicateExpr n var kind wirety flow width sense required origin vorigin doc {prf} =
    Expr $ Replicate n var kind wirety flow width sense required origin vorigin doc prf

nCopies : (c : Nat)
       -> (n : Name WHOLE labelTy)
       -> (kind  : PortShape)
       -> (wirety : WireTy)
       -> (flow  : Flow)
       -> (width : PortWidthDesc kind)

       -> (sense : Sensitivity)

       -> (required : OptionalTy)
       -> (origin   : Origin)

       -> (vorigin : ValueOrigin width)
       -> (doc : DocString)
       -> PortGroupTy () labelTy
nCopies c (WName xs x) k ty f w s r o vo doc =
    map (\i => PortDesc () k (IName xs x i) ty f w s r o vo doc) (countdown c)
  where
    countdown : Nat -> List Nat
    countdown Z     = [Z]
    countdown (S j) = S j :: countdown j

namespace Pure
  Builder (LangIDL labelTy) (Metadata, PortGroupTy () labelTy) Basics.id where
    build env (NewName name prf) (mdata,pg) cont =
      cont MkVar (MkTag (WName Nil name) :: env) (mdata,pg)

    build env (Stop prf) (mdata, acc) cont =
      cont () Nil (mdata, acc)

    build env (SetMetadata f) (mdata,acc) cont =
      cont () env ((f mdata),acc)

    build env (DeclareSignal label kind wirety flow width sense required origin vorigin doc prf) (mdata,acc) cont with (lookup env prf)
      build env (DeclareSignal label kind wirety flow width sense required origin vorigin doc prf) (mdata,acc) cont | (MkTag (WName xs x)) =
        cont () (update env prf Consume) (mdata,(PortDesc () kind (WName xs x) wirety flow width sense required origin vorigin doc :: acc))

    build env (Replicate n var kind wirety flow width sense required origin vorigin doc prf) (mdata, acc) cont with (lookup env prf)
      build env (Replicate n var kind wirety flow width sense required origin vorigin doc prf) (mdata, acc) cont | (MkTag (WName xs x)) =
        let ports = nCopies n (WName xs x) kind wirety flow width sense required origin vorigin doc in
          cont () (update env prf Consume) (mdata, ports ++ acc)

  IDL : (labelTy : Type) -> Type
  IDL ty = IDL' ty Basics.id

  buildSpec : IDL labelTy
           -> InterfaceTy () labelTy
  buildSpec expr =
      let (MkResult () (mdata,ps)) = runPure (defaultMetadata, List.Nil) expr in
      let (vlnv, (minA, minB), cstyle, doc) = processMetadata mdata in
        MkInterfaceTy vlnv () cstyle minA minB ps Nil doc

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


import Data.Vect

containsWord : {- LogMessage -} String -> Bool
containsWord = const True

stringToList : String -> List Char
stringToList "" = []
stringToList s = strHead s :: stringToList (strTail s)

listToVector : (s : List a) -> Vect (length s) a
listToVector [] = Nil
listToVector (l::ls) = l :: listToVector (ls)

stringToVector : (s : String) -> Vect (length (stringToList s)) Char
stringToVector s = listToVector $ stringToList s

breakOffWord : Vect (S (a + b)) Char -> (Vect a Char, Vect b Char)
breakOffWord (s :: st) = if s == ' '
    then (Nil, st)
    else let (a, b) = breakOffWord st in (s :: a, b)


f1 : Nat
f1 = g1 where
  g1 : Nat
  g1 = 5

f2 : Nat
f2 = g2 where
  namespace X
    export
    g2 : Nat
    g2 = 5

--f3 : Integer -> Nat
--f3 x = g3 where
--  namespace Y
--    export
--    g3 : Nat
--    g3 = 4

f4 : Integer -> Nat
f4 x = g4 x where
  namespace Z
    export
    g4 : Nat
    g4 _ = 4


module Arduino.Time

-------------
--- Types ---
-------------

-- TODO to make this type be nicer
public export
Time : Type
Time = Int

-----------------
--- Functions ---
-----------------

-- TODO to make something with, well, the fact that `Bits32` leaks out from the implementation

export
toMilliseconds : Time -> Bits32
toMilliseconds = cast

export
fromMilliseconds : Bits32 -> Time
fromMilliseconds = fromInteger . cast

------------------
--- Interfaces ---
------------------

public export
interface Timed m where
  currentTime : m Time

public export
interface Monad m => DelayableTill m where
  sleepTill : Time -> m Unit

public export
interface Monad m => DelayableFor m where
  sleepFor : Time -> m Unit


import Data.List

-- %default total

total
foo : Maybe a -> a
foo (Just x) = x

total
bar : %World -> ()
bar %MkWorld = ()

total
qsortBad : Ord a => List a -> List a
qsortBad [] = []
qsortBad (x :: xs)
   = qsortBad (filter (< x) xs) ++ x :: qsortBad (filter (> x) xs)

total
qsort : Ord a => List a -> List a
qsort [] = []
qsort (x :: xs)
   = qsort (assert_smaller (x :: xs) (filter (< x) xs)) ++
         x :: qsort (assert_smaller (x :: xs) (filter (> x) xs))

partial
main : IO ()
main = do let x = foo Nothing
          printLn (the Int x)


module Extra.Either

import Data.Maybe

export
mapError : (a -> c) -> Either a b -> Either c b
mapError f e = either (Left . f) (Right . id) e

export
expect : a -> Maybe b -> Either a b
expect left =
  (fromMaybe $ Left left) . (map Right)

export
flipEither : Either a b -> Either b a
flipEither (Left x) = Right x
flipEither (Right x) = Left x


module Main

import Control.Monad.State

increase : Nat -> State Nat ()
increase inc = do
  current <- get
  put (current + inc)

main : IO ()
main = do
  printLn $ runState (increase 5) 89
  printLn $ evalState (increase 5) 89
  printLn $ execState (increase 5) 89


import Language.Reflection
import DerivingEq

%language ElabReflection

-- This tree doesn't work

data TreeTwo a = BranchTwo (TreeTwo a) a (TreeTwo a)
               | Leaf

Eq a => Eq (TreeTwo a) where
  (==) = %runElab genEq `{ TreeTwo }


module Issue660

%default total

data Sig : (a : Type) -> (a -> Type) -> Type where

data Value : Unit -> Type where
  MkV : Sig Unit Value -> Value ()


module CantElabType

import Data.Vect

import Language.Reflection

%language ElabReflection

0 T : Nat -> Type
T n = Vect n Nat

desiredType : TTImp
desiredType = IApp EmptyFC (IVar EmptyFC `{CantElabType.T}) `(3)

elabDecl : Name -> Elab Unit
elabDecl n = declare [
    IClaim EmptyFC MW Public [] $ MkTy EmptyFC EmptyFC n desiredType
  ]

%runElab elabDecl `{x1}
x1 = [1, 2, 3]

elabExpr : Elab Type
elabExpr = check desiredType

-- should typecheck because the rig of calling is zero

x2 : %runElab elabExpr
x2 = [1, 2, 3]

-- check that zero does not leak, should not typecheck

T' : Type
T' = %runElab elabExpr


module Foo

public export
foo : Nat -> Nat
foo = S


module TypeTrans.AST

import Data.Vect

-- Define Type Aliases
Rule : Type
Rule = String

Name : Type
Name = String

Value : Type
Value = String

Assoc : Type
Assoc = Bool

Performance : Type
Performance = Float

Cost : Type
Cost = Float

data Variant = Par | Seq | Stream | Tree

implementation Show Variant where
  show Par = "Par"
  show Seq = "Seq"
  show Stream = "Stream"
  show Tree = "Tree"

data TypeT =
    Vec Nat TypeT |
    Tuple (List TypeT) |
    IntT |
    ByteT |
    BitT |
    LongT |
    FloatT |
    DoubleT |
    BoolT |
    T1 |
    T2 |
    T3

implementation Show TypeT where
  show (Vec i t) = "Vec " ++ show i ++ " (" ++ show t ++ ")"
  show (Tuple xs) = "Tuple " ++ show xs
  show IntT = "Int"
  show ByteT = "Byte"
  show BitT = "Bit"
  show LongT = "Long"
  show FloatT = "Float"
  show DoubleT = "Double"
  show BoolT = "Bool"
  show T1 = "T1"
  show T2 = "T2"
  show T3 = "T3"

-- Vector with description of its dimensions in the type
--NVec : Vect n Nat -> TypeT -> TypeT
--NVec Nil t = t
--NVec (v::vs) t = Vec v (NVec vs t)

-- Calculate the dimension of the given type
getDimension : TypeT -> Nat
getDimension (Vec i t) = (S Z) + getDimension t
getDimension _ = Z -- Non vector types have dimension 0

mutual
-- Argument is not a very good name. I mean something of type a as opposed to a -> b for the actions
  data Argument =
       Arg Name TypeT |
       Val Value TypeT |
       Res Action Argument |
       Let (List (Argument,Argument)) Argument --  let like this is not an action, it's only an action if I do  \x -> let ... x ... in ... i.e. Lambda x (let ...)

  implementation Show Argument where
    show (Arg n t) = "Arg " ++ n ++ " " ++ show t
    show (Val v t) = "Val " ++ v ++ " " ++ show t
    show (Res act arg) = "Res " ++ show act ++ " " ++ show arg
    show (Let xs arg) = "Let " ++ show xs ++ " " ++ show arg

  data Action =
      Opaque Name (List Argument) Argument TypeT (Performance,Cost) | -- [Type] is for constant args to map or fold, the first Type is the input arg, the last Type the return type
      OpaqueBin Assoc Name (List Argument) Argument Argument (Performance,Cost) |
      Map Variant Action |
      Fold Variant Action Argument | -- Argument here is the accumulator, and action must be a binary operation, not unary
      Compose (List Action) |
      -- Lambda (List Argument) (Action) ?
      Lambda (List Argument) Argument | -- (\(x,y) -> map (g x) y) becomes Lambda [x,y] (Map g x) y so the last Argument is usually a Res
      Loop Action Action |
      Split Int |
      Merge Int |
      Distr Int Int |
      Group (List (Argument, List Rule)) |
      Ungroup (List (Argument, List Rule)) |
      Zip (List TypeT) | -- this should really only work on a set of vectors and return a Vec (Tuple [Type]) Int
      Unzip TypeT  -- This should really only work on a Tuple [Vec Type Int]

  implementation Show Action where
    show (Opaque n xs arg t pc) = "Opaque " ++ n ++ " " ++ show xs ++ " " ++
                                  show arg ++ " "++ show t ++ " " ++ show pc
    show (OpaqueBin a n xs arg1 arg2 pc) = "Opaque " ++ show a ++ " " ++ n ++ " " ++
                                         show arg1 ++ " " ++ show arg2 ++ " " ++ show pc
    show (Map v act) = "Map " ++ show v ++ " " ++ show act
    show (Fold v act arg) = "Fold " ++ show v ++ " " ++ show act ++ " " ++ show arg
    show (Compose xs) = "Compose " ++ show xs
    show (Lambda xs act) = "Lambda " ++ show xs ++ " " ++ show act
    show (Loop act1 act2) = "Loop " ++  show act1 ++ " " ++ show act2
    show (Split i) = "Split " ++ show i
    show (Merge i) = "Merge " ++ show i
    show (Distr i1 i2) = "Distr " ++ show i1 ++ " " ++ show i2
    show (Group xs) = "Group " ++ show xs
    show (Ungroup xs) = "Ungroup " ++ show xs
    show (Zip xs) = "Zip " ++ show xs
    show (Unzip t) = "Unzip " ++ show t

-- We also need Zip, Unzip and Let
--data FoldAction =  deriving Show-- No need for return type as it's b -> a  -> b

data Program = Prog Action Argument  -- So actually Prog is identical to Res

implementation Show Program where
  show (Prog act arg) = "Prog " ++ show act ++ " " ++ show arg

-- I also need to represent a while-loop
-- We assume we have a loop primitive in the language
-- let loop cond action v  = (let res = action v in if (cond res) then res else loop cond action res)
-- This becomes Loop (Opaque "cond" [] (Arg "res" T2) BoolT) (Opaque "action" [] (Arg "v" T1))
-- and a way to extract values from a tuple, maybe a let?
{-

let
    (err, p', p_avg) = fold (0, [], 0) sor p
in
    map (stage3 p_avg) p'
    rather than simply (map stage3) $ (fold acc stage2) $ (map stage1) p
 this would be
 (\(v_in,stage1,stage2) -> let  (err, p', p_avg) = fold (0, [], 0) stage1 v_in in map (stage2 p_avg) p') $ map stage1 p
 The best way is to add a Lambda action

(\(x,y) -> map (g x) y) . (foldl f acc ) $ v -- [4,5,6]
-}

-- (Tuple [IntT,Vec IntT 3])
{-
p : Program
p = Prog  (Compose [
            Lambda [Arg "x" IntT, Arg "y" (Vec 3 IntT)]
                   (Map Seq (Opaque "g" [Arg "x" IntT] (Arg "a1" IntT) IntT (0,0)))
                   ]
          ) {- (Arg "y" (Vec IntT 3)),
        Fold Seq (OpaqueBin True "f" [] (Arg "acc" (Tuple [IntT,Vec IntT 3])) (Arg "a2" IntT) (0,0)) (Arg "acc" (Tuple [IntT,Vec IntT 3]))
        ])  -}
    (Arg "v" (Vec 3 IntT))

-}


module Libraries.Data.IMaybe

%default total

public export
data IMaybe : Bool -> Type -> Type where
  Nothing : IMaybe False a
  Just : a -> IMaybe True a

export
Functor (IMaybe b) where
  map f Nothing = Nothing
  map f (Just x) = Just (f x)

export
fromJust : IMaybe True a -> a
fromJust (Just x) = x


module Main

import System

----------------------------------------------------------------------
-- Hilffunktionen

readNumber : IO (Maybe Nat)
readNumber = do
  input <- getLine
  if all isDigit (unpack input) then
    pure (Just (cast input))
  else
    pure Nothing

----------------------------------------------------------------------
-- Projekt

-- Gesucht ist eine zufällige Zahl Z zwischen 1 und 100
-- (Hinweis: `System.time : IO Integer`)
-- Der Spieler hat n Versuche (Vorschlag: n=7)
-- Zunächst gibt das Spiel die Anzahl der verbliebenen Versuche aus
-- Dann wird der Spieler aufgefordert eine Zahl zu nennen
-- Hat er keine Zahl eingegeben wiederholt sich der letzt Schritt
-- (nach Ausgabe einer Warnung)
-- Hat der Spieler Z eraten hat er gewonnen
--    eine entsprechende Meldung wird ausgegeben und das Spiel ist beendet
-- Sonst erhält der Spieler eine Meldung (zu klein/zu groß) und das Spiel
-- geht mit einem Versuch weniger (n-1) oben weiter

-- Implementiere dazu diese Funktionen entsprechend:

rate : (ziel : Nat) -> (versuche : Nat) -> IO ()

zufallsZahl : IO Nat

main : IO ()
main = do
  ziel <- zufallsZahl
  rate ziel 7


||| Various utility combinators.
|||
||| A note on arrow operators: Arrow operators in this module are
||| of the form `i>o`, where `i` is either `>`, `^`, `!`, or `?`.
||| and `o` is either `>`, `^`, `!`, or `-`. Each of these symbols
||| describe a different type of arrow-like function at the
||| corresponding end of the operator:
|||
||| The following table lists the meaning of symbols
|||
||| | Symbol      | Meaning                  | Example                    |
||| |-------------|--------------------------|----------------------------|
||| | `>`         | An MSF                   | arr (*2) >>> arrM printLn  |
||| | `^`         | a pure function          | (*2) ^>> printLn           |
||| | `!`         | an effectful computation | arr (*2) >>! printLn       |
|||
||| In addition, symbol `?` corresponds to an event stream input, and
||| symbol `-` describes fanning out to a list of sinks:
|||
||| ```idris example
||| when (> 10) ?>- [ arrM printLn, put ]
||| ```
module Data.MSF.Util

import Data.List
import Data.MSF.Core
import Data.MSF.Event
import Data.SOP

--------------------------------------------------------------------------------
--          Sequencing Utilities
--------------------------------------------------------------------------------

infixr 1 ^>>, >>^, >>!, !>>, ?>>, >>-, ^>-, !>-, ?>-

||| Sequencing of an MSF and a pure function
export %inline
(>>^) : MSF m i o -> (o -> o2) -> MSF m i o2
sf >>^ f = sf >>> arr f

||| Sequencing of a pure function and an MSF
export %inline
(^>>) : (i -> i2) -> MSF m i2 o -> MSF m i o
f ^>> sf = arr f >>> sf

||| Sequencing of an MSF and an effectful computation
export %inline
(>>!) : MSF m i o -> (o -> m o2) -> MSF m i o2
sf >>! f = sf >>> arrM f

||| Sequencing of an effectful computation and an MSF
export %inline
(!>>) : (i -> m i2) -> MSF m i2 o -> MSF m i o
f !>> sf = arrM f >>> sf

--------------------------------------------------------------------------------
--          Paralellising Utilities
--------------------------------------------------------------------------------

||| Like `fan` but discards the results.
||| This is mainly useful for broadcasting to data sinks
||| (streaming functions that do not produce any interesting
||| output).
|||
||| TODO: Should we require a proof here that `os` is a list
|||       of `Unit`?
export %inline
fan_ : FanList m i os -> MSF m i ()
fan_ sfs = Fan sfs >>> Const ()

||| Broadcasting an MSF to a list of sinks
export %inline
(>>-) : MSF m i x -> FanList m x os -> MSF m i ()
sf >>- sfs = sf >>> fan_ sfs

||| Broadcasting a pure function to a list of sinks
export %inline
(^>-) : (i -> x) -> FanList m x os -> MSF m i ()
f ^>- sfs = arr f >>> fan_ sfs

||| Broadcasting an effectful computation to a list of sinks
export %inline
(!>-) : (i -> m x) -> FanList m x os -> MSF m i ()
f !>- sfs = arrM f >>> fan_ sfs

||| Extract the first argument from an MSF taking a pair
||| of input values.
export
firstArg : MSF m (NP I [x,i]) o -> x -> MSF m i o
firstArg sf vx = fan [const vx, id] >>> sf

||| Extract the second argument from an MSF taking a pair
||| of input values.
export
secondArg : MSF m (NP I [i,x]) o -> x -> MSF m i o
secondArg sf vx = fan [id, const vx] >>> sf

||| Extract the first value of an n-ary product
export
hd : MSF m (NP I (i :: t)) i
hd = arr hd

||| Extract the tail of an n-ary product
export
tl : MSF m (NP I (i :: t)) (NP I t)
tl = arr tl

||| Extract the second value of an n-ary product
export
snd : MSF m (NP I (i :: i2 :: t)) i2
snd = arr $ \(_ :: v :: _) => v

||| Swaps a pair of input values
export
swap : MSF m (NP I [a,b]) (NP I [b,a])
swap = arr $ \[va,vb] => [vb,va]

--------------------------------------------------------------------------------
--          Selecting Utilities
--------------------------------------------------------------------------------

||| Convert an `Either` input to a binary sum, which
||| can then be sequenced with a call to `choice` or `collect`.
export
either : MSF m (Either i1 i2) (NS I [i1,i2])
either = arr $ either Z (S . Z)

||| Run the given MSF only if the input is a `Left`.
export
ifLeft : Monoid o => MSF m i o -> MSF m (Either i a) o
ifLeft sf = either >>> collect [sf, neutral]

||| Run the given MSF only if the input is a `Right`.
export
ifRight : Monoid o => MSF m i o -> MSF m (Either a i) o
ifRight sf = either >>> collect [neutral, sf]

||| Convert an `Maybe` input to a binary sum, which
||| can then be sequenced with a call to `choice` or `collect`.
export
maybe :  MSF m (Maybe i) (NS I [i,()])
maybe = arr $ maybe (S $ Z ()) Z

||| Run the given MSF only if the input is a `Just`.
export
ifJust : Monoid o => MSF m i o -> MSF m (Maybe i) o
ifJust sf = maybe >>> collect [sf, neutral]

||| Run the given MSF only if the input is a `Nothing`.
export
ifNothing : Monoid o => MSF m () o -> MSF m (Maybe i) o
ifNothing sf = maybe >>> collect [neutral, sf]

||| Convert an input to a binary sum, depending on whether
||| the given predicate returns `True` or `False`. The result
||| can then be sequenced with a call to `choice` or `collect`.
export
bool : (f : i -> Bool) -> MSF m i (NS I [i,i])
bool f = arr $ \vi => if f vi then Z vi else (S $ Z vi)

||| Run the given MSF only if the predicate holds for the input.
export
ifTrue : Monoid o => (f : i -> Bool) -> MSF m i o -> MSF m i o
ifTrue f sf = bool f >>> collect [sf, neutral]

||| Run the given MSF only if the predicate does not hold for the input.
export
ifFalse : Monoid o => (f : i -> Bool) -> MSF m i o -> MSF m i o
ifFalse f sf = bool f >>> collect [neutral, sf]

||| Run the given MSF only if the input equlas the given value
export
ifIs : Eq i => Monoid o => (v : i) -> MSF m i o -> MSF m i o
ifIs v = ifTrue (v ==)

||| Run the given MSF only if the input does not equal the given value
export
ifIsNot : Eq i => Monoid o => (v : i) -> MSF m i o -> MSF m i o
ifIsNot v = ifFalse (v ==)

--------------------------------------------------------------------------------
--          Looping Utilities
--------------------------------------------------------------------------------

||| Uses the given value as a seed for feeding back output
||| of the MSF back to its input.
export
feedback_ : s -> MSF m (NP I [s,i]) s -> MSF m i ()
feedback_ v sf = feedback v $ sf >>^ (:: [()])

||| Delay a stream by one sample.
export %inline
iPre : o -> MSF m o o
iPre v = feedback v swap

||| Applies a function to the input and an accumulator,
||| outputting the updated accumulator.
export
accumulateWith : (i -> o -> o) -> o -> MSF m i o
accumulateWith f ini = feedback ini (arr g)
  where g : NP I [o,i] -> NP I [o,o]
        g [acc,inp] = let acc' = f inp acc in [acc',acc']

||| Counts the number of scans of the signal function.
export
count : Num n => MSF m i n
count = const 1 >>> accumulateWith (+) 0

||| Accumulate the inputs, starting from an initial value.
export
appendFrom : Semigroup v => v -> MSF m v v
appendFrom = accumulateWith (<+>)

||| Accumulate the inputs, starting from `neutral`
export
append : Monoid n => MSF m n n
append = appendFrom neutral

||| Applies a transfer function to the input and an accumulator,
||| returning the updated accumulator and output.
export
mealy : (i -> s -> NP I [s,o]) -> s -> MSF m i o
mealy f s0 = feedback s0 (arr $ \[s,i] => f i s)

||| Unfolds a function over an initial state
||| value.
export
unfold : (s -> NP I [s,o]) -> s -> MSF m i o
unfold f ini = feedback ini (arr $ f . hd)

||| Generates output using a step-wise generation function and an initial
||| value. Version of 'unfold' in which the output and the new accumulator
||| are the same.
export
repeatedly : (o -> o) -> o -> MSF m i o
repeatedly f = unfold $ \vo => let vo2 = f vo in [vo2,vo2]

||| Cycles through the given non-empty list of values.
export
cycle : (vs : List o) -> {auto 0 prf : NonEmpty vs} -> MSF m i o
cycle (h :: t) = unfold next (h :: t)
  where next : List o -> NP I [List o, o]
        next Nil        = [t,h]
        next (h' :: t') = [t',h']

--------------------------------------------------------------------------------
--          Observing Streaming Functions
--------------------------------------------------------------------------------

||| Observe input values through the given MSF, discarding
||| its output.
export
observeWith : MSF m i o -> MSF m i i
observeWith sf = fan [id,sf] >>> hd

||| Run the given effectful computation on each input.
export %inline
withEffect : (i -> m ()) -> MSF m i i
withEffect = observeWith . arrM

||| Run the given monadic action on each input.
export %inline
runEffect : m () -> MSF m i i
runEffect = withEffect . const

--------------------------------------------------------------------------------
--          Event Streams
--------------------------------------------------------------------------------

||| The empty event stream that never fires an event
export
never : MSF m i (Event o)
never = const NoEv

||| Convert an event stream to a streaming function
||| holding the value of the last event fired starting
||| from the given initial value.
export
hold : o -> MSF m (Event o) o
hold = accumulateWith (\ev,v => fromEvent v ev)

||| Fire the given event `n` times.
export
ntimes : Nat -> o -> MSF m i (Event o)
ntimes n vo = Switch (feedback n $ arr next) (const never)
  where next : NP I [Nat,i] -> NP I [Nat,Either () (Event o)]
        next [0,_]   = [0, Left ()]
        next [S k,_] = [k, Right $ Ev vo]

||| Fire the given event exactly once on the first
||| evaluation step.
export
once : o -> MSF m i (Event o)
once = ntimes 1

||| Fire an event whenever the given predicate holds.
export
when : (i -> Bool) -> MSF m i (Event i)
when f = arr $ \vi => toEvent (f vi) vi

||| Like `when` but discard the input.
export
when_ : (i -> Bool) -> MSF m i (Event ())
when_ f = arr $ \vi => toEvent (f vi) ()

||| Fire an event whenever the input equals the given value.
export
is : Eq i => i -> MSF m i (Event i)
is v = when (v ==)

||| Fire an event whenever the input does not equal the given value.
export
isNot : Eq i => i -> MSF m i (Event i)
isNot v = when (v /=)

||| Fire an event if the input is a `Left`.
export
whenLeft : MSF m (Either a b) (Event a)
whenLeft = arr $ either Ev (const NoEv)

||| Fire an event if the input is a `Right`.
export
whenRight : MSF m (Either a b) (Event b)
whenRight = arr $ either (const NoEv) Ev

||| Fire an event if the input is a `Just`.
export
whenJust : MSF m (Maybe a) (Event a)
whenJust = arr maybeToEvent

||| Fire an event if the input is a `Nothing`.
export
whenNothing : MSF m (Maybe a) (Event ())
whenNothing = arr $ maybe (Ev ()) (const NoEv)

||| Convert an `Event` input to a binary sum, which
||| can then be sequenced with a call to `choice` or `collect`.
export
event :  MSF m (Event i) (NS I [i,()])
event = arr $ event (S $ Z ()) Z

||| Run the given MSF only if the input fired an event.
export
ifEvent : Monoid o => MSF m i o -> MSF m (Event i) o
ifEvent sf = event >>> collect [sf, const neutral]

||| Broadcast an event to a list of sinks.
export %inline
(?>-) : MSF m i (Event x) -> FanList m x os -> MSF m i ()
ef ?>- sfs = ef >>> ifEvent (fan_ sfs)

||| Run the given MSF if the input stream fires and event.
export %inline
(?>>) : Monoid o => MSF m i (Event x) -> MSF m x o -> MSF m i o
ef ?>> sf = ef >>> ifEvent sf

||| Run the given MSF only if the input fired no event.
export
ifNoEvent : Monoid o => MSF m () o -> MSF m (Event i) o
ifNoEvent sf = event >>> collect [const neutral, sf]

||| Fire an event whenever the input value changed.
||| Always fires on first input.
export
onChange : Eq i => MSF m i (Event i)
onChange = mealy accum  NoEv
  where accum : i -> Event i -> NP I [Event i, Event i]
        accum v old =
          let ev = Ev v
           in if ev == old then [ev,NoEv] else [ev,ev]

||| Fires the first input as an event whenever the
||| second input fires.
export
onEvent : MSF m (NP I [a, Event e]) (Event a)
onEvent = arr $ \case [va,e] => e $> va

||| Combines the first input with the event fired by the
||| second input.
export
onEventWith : (a -> e -> b) -> MSF m (NP I [a, Event e]) (Event b)
onEventWith f = arr $ \case [va,e] => f va <$> e

||| Combines an input event stream with a stream function
||| holding an `Either` trying to extract a `Left` whenever
||| an event is fired.
export
leftOnEvent : MSF m (NP I [Either a b, Event e]) (Event a)
leftOnEvent = arr $ \case [Left va,e] => e $> va
                          _           => NoEv

||| Combines an input event stream with a stream function
||| holding an `Either` trying to extract a `Right` whenever
||| an event is fired.
export
rightOnEvent : MSF m (NP I [Either a b, Event e]) (Event b)
rightOnEvent = arr $ \case [Right vb,e] => e $> vb
                           _            => NoEv

||| Combines an input event stream with a stream function
||| holding a `Maybe` trying to extract the value from a `Just` whenever
||| an event is fired.
export
justOnEvent : MSF m (NP I [Maybe a, Event e]) (Event a)
justOnEvent = arr $ \case [Just va,e] => e $> va
                          _           => NoEv

--------------------------------------------------------------------------------
--          Merging Event Streams
--------------------------------------------------------------------------------

||| Fires an event whenever one of the two given
||| event streams fire. Uses the given function
||| to combine simultaneously occuring events.
export
unionWith : (o -> o -> o)
          -> MSF m i (Event o)
          -> MSF m i (Event o)
          -> MSF m i (Event o)
unionWith = elementwise2 . unionWith

||| Left-biased union of event streams.
||| In case of simultaneously occuring events, the
||| event from the first event stream is fired.
|||
||| This is the same behavior as `(<|>)` from
||| the MSFs `Alternative` implementation
export
unionL : MSF m i (Event o) -> MSF m i (Event o) -> MSF m i (Event o)
unionL = elementwise2 unionL

||| Right-biased union of event streams.
||| In case of simultaneously occuring events, the
||| event from the second event stream is fired.
export
unionR : MSF m i (Event o) -> MSF m i (Event o) -> MSF m i (Event o)
unionR = elementwise2 unionR

||| Union of event streams using a `Semigroup` to
||| merge values in case of simultaneously occuring events.
|||
||| This is an alias for `(<+>)`.
export %inline
union :  Semigroup o
      => MSF m i (Event o)
      -> MSF m i (Event o)
      -> MSF m i (Event o)
union = (<+>)

export
(<|>) : Alternative f => MSF m i (f o) -> MSF m i (f o) -> MSF m i (f o)
x <|> y = fan [x,y] >>> arr (\[vx,vy] => vx <|> vy)

--------------------------------------------------------------------------------
--          Filtering Event Streams
--------------------------------------------------------------------------------

||| Filters an event stream, letting pass only values,
||| fow which the given predicate holds.
export
filter : (o -> Bool) -> MSF m (Event o) (Event o)
filter = arr . filter

||| Filters an event stream, letting pass only values,
||| fow which the given function returns a `Just`.
export
mapMaybe : (i -> Maybe o) -> MSF m (Event i) (Event o)
mapMaybe = arr . mapMaybe

--------------------------------------------------------------------------------
--          Accumulating Events
--------------------------------------------------------------------------------

||| Applies a function to the input and an accumulator,
||| outputting the updated accumulator whenever an
||| event is fire.
export
accumulateWithE : (i -> o -> o) -> o -> MSF m (Event i) (Event o)
accumulateWithE f ini = feedback ini (arr g)
  where g : NP I [o,Event i] -> NP I [o,Event o]
        g [acc,NoEv]  = [acc,NoEv]
        g [acc,Ev vi] = let acc' = f vi acc in [acc',Ev acc']

||| Count the number of occurences of an event
export
countE : MSF m (Event i) (Event Nat)
countE = accumulateWithE (\_,n => n + 1) 0

--------------------------------------------------------------------------------
--          Handling with n-ary Products
--------------------------------------------------------------------------------

||| N-ary function type calculated from a list of n types.
public export
0 Fun : List Type -> Type -> Type
Fun [] r        = r
Fun (t :: ts) r = t -> Fun ts r

||| Converts an n-ary function to one taking an n-ary
||| product as input.
export
uncurryNP : {0 is : _} -> Fun is o -> NP I is -> o
uncurryNP r []        = r
uncurryNP f (v :: vs) = uncurryNP (f v) vs

||| Alias for `arr . uncurryNP`.
export
np : {0 is : _} -> Fun is o -> MSF m (NP I is) o
np = arr . uncurryNP


module Core.Primitives

import Core.Context
import Core.TT
import Core.Value
import Libraries.Utils.String

import Data.Vect

%default covering

public export
record Prim where
  constructor MkPrim
  {arity : Nat}
  fn : PrimFn arity
  type : ClosedTerm
  totality : Totality

binOp : (Constant -> Constant -> Maybe Constant) ->
        {vars : _} -> Vect 2 (NF vars) -> Maybe (NF vars)
binOp fn [NPrimVal fc x, NPrimVal _ y]
    = map (NPrimVal fc) (fn x y)
binOp _ _ = Nothing

unaryOp : (Constant -> Maybe Constant) ->
          {vars : _} -> Vect 1 (NF vars) -> Maybe (NF vars)
unaryOp fn [NPrimVal fc x]
    = map (NPrimVal fc) (fn x)
unaryOp _ _ = Nothing

castString : Vect 1 (NF vars) -> Maybe (NF vars)
castString [NPrimVal fc (I i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I8 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I16 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I32 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (I64 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (BI i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B8 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B16 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B32 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (B64 i)] = Just (NPrimVal fc (Str (show i)))
castString [NPrimVal fc (Ch i)] = Just (NPrimVal fc (Str (stripQuotes (show i))))
castString [NPrimVal fc (Db i)] = Just (NPrimVal fc (Str (show i)))
castString _ = Nothing

castInteger : Vect 1 (NF vars) -> Maybe (NF vars)
castInteger [NPrimVal fc (I i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (I8 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (I16 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (I32 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (I64 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B8 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B16 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B32 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (B64 i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (Ch i)] = Just (NPrimVal fc (BI (cast (cast {to=Int} i))))
castInteger [NPrimVal fc (Db i)] = Just (NPrimVal fc (BI (cast i)))
castInteger [NPrimVal fc (Str i)] = Just (NPrimVal fc (BI (cast i)))
castInteger _ = Nothing

castInt : Vect 1 (NF vars) -> Maybe (NF vars)
castInt [NPrimVal fc (I8 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (I16 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (I32 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (I64 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (BI i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (B8 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (B16 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (B32 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (B64 i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (Db i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (Ch i)] = Just (NPrimVal fc (I (cast i)))
castInt [NPrimVal fc (Str i)] = Just (NPrimVal fc (I (cast i)))
castInt _ = Nothing

constantIntegerValue : Constant -> Maybe Integer
constantIntegerValue (I i)   = Just $ cast i
constantIntegerValue (I8 i)   = Just $ cast i
constantIntegerValue (I16 i)   = Just $ cast i
constantIntegerValue (I32 i)   = Just $ cast i
constantIntegerValue (I64 i)   = Just $ cast i
constantIntegerValue (BI i)  = Just i
constantIntegerValue (B8 i)  = Just $ cast i
constantIntegerValue (B16 i) = Just $ cast i
constantIntegerValue (B32 i) = Just $ cast i
constantIntegerValue (B64 i) = Just $ cast i
constantIntegerValue _       = Nothing

castBits8 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits8 [NPrimVal fc constant] =
    NPrimVal fc . B8 . cast <$> constantIntegerValue constant
castBits8 _ = Nothing

castBits16 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits16 [NPrimVal fc constant] =
    NPrimVal fc . B16 . cast <$> constantIntegerValue constant
castBits16 _ = Nothing

castBits32 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits32 [NPrimVal fc constant] =
    NPrimVal fc . B32 . cast <$> constantIntegerValue constant
castBits32 _ = Nothing

castBits64 : Vect 1 (NF vars) -> Maybe (NF vars)
castBits64 [NPrimVal fc constant] =
    NPrimVal fc . B64 . cast <$> constantIntegerValue constant
castBits64 _ = Nothing

castInt8 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt8 [NPrimVal fc constant] =
    NPrimVal fc . I8 . cast <$> constantIntegerValue constant
castInt8 _ = Nothing

castInt16 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt16 [NPrimVal fc constant] =
    NPrimVal fc . I16 . cast <$> constantIntegerValue constant
castInt16 _ = Nothing

castInt32 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt32 [NPrimVal fc constant] =
    NPrimVal fc . I32 . cast <$> constantIntegerValue constant
castInt32 _ = Nothing

castInt64 : Vect 1 (NF vars) -> Maybe (NF vars)
castInt64 [NPrimVal fc constant] =
    NPrimVal fc . I64 . cast <$> constantIntegerValue constant
castInt64 _ = Nothing

castDouble : Vect 1 (NF vars) -> Maybe (NF vars)
castDouble [NPrimVal fc (I i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I8 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I16 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I32 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (I64 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (B8 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (B16 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (B32 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (B64 i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (BI i)] = Just (NPrimVal fc (Db (cast i)))
castDouble [NPrimVal fc (Str i)] = Just (NPrimVal fc (Db (cast i)))
castDouble _ = Nothing

castChar : Vect 1 (NF vars) -> Maybe (NF vars)
castChar [NPrimVal fc (I i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (I8 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (I16 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (I32 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (I64 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (B8 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (B16 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (B32 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (B64 i)] = Just (NPrimVal fc (Ch (cast i)))
castChar [NPrimVal fc (BI i)] = Just (NPrimVal fc (Ch (cast i)))
castChar _ = Nothing

strLength : Vect 1 (NF vars) -> Maybe (NF vars)
strLength [NPrimVal fc (Str s)] = Just (NPrimVal fc (I (cast (length s))))
strLength _ = Nothing

strHead : Vect 1 (NF vars) -> Maybe (NF vars)
strHead [NPrimVal fc (Str "")] = Nothing
strHead [NPrimVal fc (Str str)]
    = Just (NPrimVal fc (Ch (assert_total (prim__strHead str))))
strHead _ = Nothing

strTail : Vect 1 (NF vars) -> Maybe (NF vars)
strTail [NPrimVal fc (Str "")] = Nothing
strTail [NPrimVal fc (Str str)]
    = Just (NPrimVal fc (Str (assert_total (prim__strTail str))))
strTail _ = Nothing

strIndex : Vect 2 (NF vars) -> Maybe (NF vars)
strIndex [NPrimVal fc (Str str), NPrimVal _ (I i)]
    = if i >= 0 && integerToNat (cast i) < length str
         then Just (NPrimVal fc (Ch (assert_total (prim__strIndex str i))))
         else Nothing
strIndex _ = Nothing

strCons : Vect 2 (NF vars) -> Maybe (NF vars)
strCons [NPrimVal fc (Ch x), NPrimVal _ (Str y)]
    = Just (NPrimVal fc (Str (strCons x y)))
strCons _ = Nothing

strAppend : Vect 2 (NF vars) -> Maybe (NF vars)
strAppend [NPrimVal fc (Str x), NPrimVal _ (Str y)]
    = Just (NPrimVal fc (Str (x ++ y)))
strAppend _ = Nothing

strReverse : Vect 1 (NF vars) -> Maybe (NF vars)
strReverse [NPrimVal fc (Str x)]
    = Just (NPrimVal fc (Str (reverse x)))
strReverse _ = Nothing

strSubstr : Vect 3 (NF vars) -> Maybe (NF vars)
strSubstr [NPrimVal fc (I start), NPrimVal _ (I len), NPrimVal _ (Str str)]
    = Just (NPrimVal fc (Str (prim__strSubstr start len str)))
strSubstr _ = Nothing

add : Constant -> Constant -> Maybe Constant
add (BI x) (BI y) = pure $ BI (x + y)
add (I x) (I y) = pure $ I (x + y)
add (I8 x) (I8 y) = pure $ I8 (x + y)
add (I16 x) (I16 y) = pure $ I16 (x + y)
add (I32 x) (I32 y) = pure $ I32 (x + y)
add (I64 x) (I64 y) = pure $ I64 (x + y)
add (B8 x) (B8 y) = pure $ B8 (x + y)
add (B16 x) (B16 y) = pure $ B16 (x + y)
add (B32 x) (B32 y) = pure $ B32 (x + y)
add (B64 x) (B64 y) = pure $ B64 (x + y)
add (Ch x) (Ch y) = pure $ Ch (cast (cast {to=Int} x + cast y))
add (Db x) (Db y) = pure $ Db (x + y)
add _ _ = Nothing

sub : Constant -> Constant -> Maybe Constant
sub (BI x) (BI y) = pure $ BI (x - y)
sub (I x) (I y) = pure $ I (x - y)
sub (I8 x) (I8 y) = pure $ I8 (x - y)
sub (I16 x) (I16 y) = pure $ I16 (x - y)
sub (I32 x) (I32 y) = pure $ I32 (x - y)
sub (I64 x) (I64 y) = pure $ I64 (x - y)
sub (B8 x) (B8 y) = pure $ B8 (x - y)
sub (B16 x) (B16 y) = pure $ B16 (x - y)
sub (B32 x) (B32 y) = pure $ B32 (x - y)
sub (B64 x) (B64 y) = pure $ B64 (x - y)
sub (Ch x) (Ch y) = pure $ Ch (cast (cast {to=Int} x - cast y))
sub (Db x) (Db y) = pure $ Db (x - y)
sub _ _ = Nothing

mul : Constant -> Constant -> Maybe Constant
mul (BI x) (BI y) = pure $ BI (x * y)
mul (B8 x) (B8 y) = pure $ B8 (x * y)
mul (B16 x) (B16 y) = pure $ B16 (x * y)
mul (B32 x) (B32 y) = pure $ B32 (x * y)
mul (B64 x) (B64 y) = pure $ B64 (x * y)
mul (I x) (I y) = pure $ I (x * y)
mul (I8 x) (I8 y) = pure $ I8 (x * y)
mul (I16 x) (I16 y) = pure $ I16 (x * y)
mul (I32 x) (I32 y) = pure $ I32 (x * y)
mul (I64 x) (I64 y) = pure $ I64 (x * y)
mul (Db x) (Db y) = pure $ Db (x * y)
mul _ _ = Nothing

div : Constant -> Constant -> Maybe Constant
div (BI x) (BI 0) = Nothing
div (BI x) (BI y) = pure $ BI (assert_total (x `div` y))
div (I x) (I 0) = Nothing
div (I x) (I y) = pure $ I (assert_total (x `div` y))
div (I8 x) (I8 0) = Nothing
div (I8 x) (I8 y) = pure $ I8 (assert_total (x `div` y))
div (I16 x) (I16 0) = Nothing
div (I16 x) (I16 y) = pure $ I16 (assert_total (x `div` y))
div (I32 x) (I32 0) = Nothing
div (I32 x) (I32 y) = pure $ I32 (assert_total (x `div` y))
div (I64 x) (I64 0) = Nothing
div (I64 x) (I64 y) = pure $ I64 (assert_total (x `div` y))
div (B8 x) (B8 0) = Nothing
div (B8 x) (B8 y) = pure $ B8 (assert_total (x `div` y))
div (B16 x) (B16 0) = Nothing
div (B16 x) (B16 y) = pure $ B16 (assert_total (x `div` y))
div (B32 x) (B32 0) = Nothing
div (B32 x) (B32 y) = pure $ B32 (assert_total (x `div` y))
div (B64 x) (B64 0) = Nothing
div (B64 x) (B64 y) = pure $ B64 (assert_total (x `div` y))
div (Db x) (Db y) = pure $ Db (x / y)
div _ _ = Nothing

mod : Constant -> Constant -> Maybe Constant
mod (BI x) (BI 0) = Nothing
mod (BI x) (BI y) = pure $ BI (assert_total (x `mod` y))
mod (I x) (I 0) = Nothing
mod (I x) (I y) = pure $ I (assert_total (x `mod` y))
mod (I8 x) (I8 0) = Nothing
mod (I8 x) (I8 y) = pure $ I8 (assert_total (x `mod` y))
mod (I16 x) (I16 0) = Nothing
mod (I16 x) (I16 y) = pure $ I16 (assert_total (x `mod` y))
mod (I32 x) (I32 0) = Nothing
mod (I32 x) (I32 y) = pure $ I32 (assert_total (x `mod` y))
mod (I64 x) (I64 0) = Nothing
mod (I64 x) (I64 y) = pure $ I64 (assert_total (x `mod` y))
mod (B8 x) (B8 0) = Nothing
mod (B8 x) (B8 y) = pure $ B8 (assert_total (x `mod` y))
mod (B16 x) (B16 0) = Nothing
mod (B16 x) (B16 y) = pure $ B16 (assert_total (x `mod` y))
mod (B32 x) (B32 0) = Nothing
mod (B32 x) (B32 y) = pure $ B32 (assert_total (x `mod` y))
mod (B64 x) (B64 0) = Nothing
mod (B64 x) (B64 y) = pure $ B64 (assert_total (x `mod` y))
mod _ _ = Nothing

shiftl : Constant -> Constant -> Maybe Constant
shiftl (I x) (I y) = pure $ I (prim__shl_Int x y)
shiftl (I8 x) (I8 y) = pure $ I8 (prim__shl_Int8 x y)
shiftl (I16 x) (I16 y) = pure $ I16 (prim__shl_Int16 x y)
shiftl (I32 x) (I32 y) = pure $ I32 (prim__shl_Int32 x y)
shiftl (I64 x) (I64 y) = pure $ I64 (prim__shl_Int64 x y)
shiftl (BI x) (BI y) = pure $ BI (prim__shl_Integer x y)
shiftl (B8 x) (B8 y) = pure $ B8 (prim__shl_Bits8 x y)
shiftl (B16 x) (B16 y) = pure $ B16 (prim__shl_Bits16 x y)
shiftl (B32 x) (B32 y) = pure $ B32 (prim__shl_Bits32 x y)
shiftl (B64 x) (B64 y) = pure $ B64 (prim__shl_Bits64 x y)
shiftl _ _ = Nothing

shiftr : Constant -> Constant -> Maybe Constant
shiftr (I x) (I y) = pure $ I (prim__shr_Int x y)
shiftr (I8 x) (I8 y) = pure $ I8 (prim__shr_Int8 x y)
shiftr (I16 x) (I16 y) = pure $ I16 (prim__shr_Int16 x y)
shiftr (I32 x) (I32 y) = pure $ I32 (prim__shr_Int32 x y)
shiftr (I64 x) (I64 y) = pure $ I64 (prim__shr_Int64 x y)
shiftr (B8 x) (B8 y) = pure $ B8 $ (prim__shr_Bits8 x y)
shiftr (B16 x) (B16 y) = pure $ B16 (prim__shr_Bits16 x y)
shiftr (B32 x) (B32 y) = pure $ B32 (prim__shr_Bits32 x y)
shiftr (B64 x) (B64 y) = pure $ B64 (prim__shr_Bits64 x y)
shiftr _ _ = Nothing

band : Constant -> Constant -> Maybe Constant
band (I x) (I y) = pure $ I (prim__and_Int x y)
band (I8 x) (I8 y) = pure $ I8 (prim__and_Int8 x y)
band (I16 x) (I16 y) = pure $ I16 (prim__and_Int16 x y)
band (I32 x) (I32 y) = pure $ I32 (prim__and_Int32 x y)
band (I64 x) (I64 y) = pure $ I64 (prim__and_Int64 x y)
band (BI x) (BI y) = pure $ BI (prim__and_Integer x y)
band (B8 x) (B8 y) = pure $ B8 (prim__and_Bits8 x y)
band (B16 x) (B16 y) = pure $ B16 (prim__and_Bits16 x y)
band (B32 x) (B32 y) = pure $ B32 (prim__and_Bits32 x y)
band (B64 x) (B64 y) = pure $ B64 (prim__and_Bits64 x y)
band _ _ = Nothing

bor : Constant -> Constant -> Maybe Constant
bor (I x) (I y) = pure $ I (prim__or_Int x y)
bor (I8 x) (I8 y) = pure $ I8 (prim__or_Int8 x y)
bor (I16 x) (I16 y) = pure $ I16 (prim__or_Int16 x y)
bor (I32 x) (I32 y) = pure $ I32 (prim__or_Int32 x y)
bor (I64 x) (I64 y) = pure $ I64 (prim__or_Int64 x y)
bor (BI x) (BI y) = pure $ BI (prim__or_Integer x y)
bor (B8 x) (B8 y) = pure $ B8 (prim__or_Bits8 x y)
bor (B16 x) (B16 y) = pure $ B16 (prim__or_Bits16 x y)
bor (B32 x) (B32 y) = pure $ B32 (prim__or_Bits32 x y)
bor (B64 x) (B64 y) = pure $ B64 (prim__or_Bits64 x y)
bor _ _ = Nothing

bxor : Constant -> Constant -> Maybe Constant
bxor (I x) (I y) = pure $ I (prim__xor_Int x y)
bxor (B8 x) (B8 y) = pure $ B8 (prim__xor_Bits8 x y)
bxor (B16 x) (B16 y) = pure $ B16 (prim__xor_Bits16 x y)
bxor (B32 x) (B32 y) = pure $ B32 (prim__xor_Bits32 x y)
bxor (B64 x) (B64 y) = pure $ B64 (prim__xor_Bits64 x y)
bxor (I8 x) (I8 y) = pure $ I8 (prim__xor_Int8 x y)
bxor (I16 x) (I16 y) = pure $ I16 (prim__xor_Int16 x y)
bxor (I32 x) (I32 y) = pure $ I32 (prim__xor_Int32 x y)
bxor (I64 x) (I64 y) = pure $ I64 (prim__xor_Int64 x y)
bxor (BI x) (BI y) = pure $ BI (prim__xor_Integer x y)
bxor _ _ = Nothing

neg : Constant -> Maybe Constant
neg (BI x) = pure $ BI (-x)
neg (I x) = pure $ I (-x)
neg (I8 x) = pure $ I8 (-x)
neg (I16 x) = pure $ I16 (-x)
neg (I32 x) = pure $ I32 (-x)
neg (I64 x) = pure $ I64 (-x)
neg (B8 x) = pure $ B8 (-x)
neg (B16 x) = pure $ B16 (-x)
neg (B32 x) = pure $ B32 (-x)
neg (B64 x) = pure $ B64 (-x)
neg (Db x) = pure $ Db (-x)
neg _ = Nothing

toInt : Bool -> Constant
toInt True = I 1
toInt False = I 0

lt : Constant -> Constant -> Maybe Constant
lt (I x) (I y) = pure $ toInt (x < y)
lt (I8 x) (I8 y) = pure $ toInt (x < y)
lt (I16 x) (I16 y) = pure $ toInt (x < y)
lt (I32 x) (I32 y) = pure $ toInt (x < y)
lt (I64 x) (I64 y) = pure $ toInt (x < y)
lt (BI x) (BI y) = pure $ toInt (x < y)
lt (B8 x) (B8 y) = pure $ toInt (x < y)
lt (B16 x) (B16 y) = pure $ toInt (x < y)
lt (B32 x) (B32 y) = pure $ toInt (x < y)
lt (B64 x) (B64 y) = pure $ toInt (x < y)
lt (Str x) (Str y) = pure $ toInt (x < y)
lt (Ch x) (Ch y) = pure $ toInt (x < y)
lt (Db x) (Db y) = pure $ toInt (x < y)
lt _ _ = Nothing

lte : Constant -> Constant -> Maybe Constant
lte (I x) (I y) = pure $ toInt (x <= y)
lte (I8 x) (I8 y) = pure $ toInt (x <= y)
lte (I16 x) (I16 y) = pure $ toInt (x <= y)
lte (I32 x) (I32 y) = pure $ toInt (x <= y)
lte (I64 x) (I64 y) = pure $ toInt (x <= y)
lte (BI x) (BI y) = pure $ toInt (x <= y)
lte (B8 x) (B8 y) = pure $ toInt (x <= y)
lte (B16 x) (B16 y) = pure $ toInt (x <= y)
lte (B32 x) (B32 y) = pure $ toInt (x <= y)
lte (B64 x) (B64 y) = pure $ toInt (x <= y)
lte (Str x) (Str y) = pure $ toInt (x <= y)
lte (Ch x) (Ch y) = pure $ toInt (x <= y)
lte (Db x) (Db y) = pure $ toInt (x <= y)
lte _ _ = Nothing

eq : Constant -> Constant -> Maybe Constant
eq (I x) (I y) = pure $ toInt (x == y)
eq (I8 x) (I8 y) = pure $ toInt (x == y)
eq (I16 x) (I16 y) = pure $ toInt (x == y)
eq (I32 x) (I32 y) = pure $ toInt (x == y)
eq (I64 x) (I64 y) = pure $ toInt (x == y)
eq (BI x) (BI y) = pure $ toInt (x == y)
eq (B8 x) (B8 y) = pure $ toInt (x == y)
eq (B16 x) (B16 y) = pure $ toInt (x == y)
eq (B32 x) (B32 y) = pure $ toInt (x == y)
eq (B64 x) (B64 y) = pure $ toInt (x == y)
eq (Str x) (Str y) = pure $ toInt (x == y)
eq (Ch x) (Ch y) = pure $ toInt (x == y)
eq (Db x) (Db y) = pure $ toInt (x == y)
eq _ _ = Nothing

gte : Constant -> Constant -> Maybe Constant
gte (I x) (I y) = pure $ toInt (x >= y)
gte (I8 x) (I8 y) = pure $ toInt (x >= y)
gte (I16 x) (I16 y) = pure $ toInt (x >= y)
gte (I32 x) (I32 y) = pure $ toInt (x >= y)
gte (I64 x) (I64 y) = pure $ toInt (x >= y)
gte (BI x) (BI y) = pure $ toInt (x >= y)
gte (B8 x) (B8 y) = pure $ toInt (x >= y)
gte (B16 x) (B16 y) = pure $ toInt (x >= y)
gte (B32 x) (B32 y) = pure $ toInt (x >= y)
gte (B64 x) (B64 y) = pure $ toInt (x >= y)
gte (Str x) (Str y) = pure $ toInt (x >= y)
gte (Ch x) (Ch y) = pure $ toInt (x >= y)
gte (Db x) (Db y) = pure $ toInt (x >= y)
gte _ _ = Nothing

gt : Constant -> Constant -> Maybe Constant
gt (I x) (I y) = pure $ toInt (x > y)
gt (I8 x) (I8 y) = pure $ toInt (x > y)
gt (I16 x) (I16 y) = pure $ toInt (x > y)
gt (I32 x) (I32 y) = pure $ toInt (x > y)
gt (I64 x) (I64 y) = pure $ toInt (x > y)
gt (BI x) (BI y) = pure $ toInt (x > y)
gt (B8 x) (B8 y) = pure $ toInt (x > y)
gt (B16 x) (B16 y) = pure $ toInt (x > y)
gt (B32 x) (B32 y) = pure $ toInt (x > y)
gt (B64 x) (B64 y) = pure $ toInt (x > y)
gt (Str x) (Str y) = pure $ toInt (x > y)
gt (Ch x) (Ch y) = pure $ toInt (x > y)
gt (Db x) (Db y) = pure $ toInt (x > y)
gt _ _ = Nothing

doubleOp : (Double -> Double) -> Vect 1 (NF vars) -> Maybe (NF vars)
doubleOp f [NPrimVal fc (Db x)] = Just (NPrimVal fc (Db (f x)))
doubleOp f _ = Nothing

doubleExp : Vect 1 (NF vars) -> Maybe (NF vars)
doubleExp = doubleOp exp

doubleLog : Vect 1 (NF vars) -> Maybe (NF vars)
doubleLog = doubleOp log

doublePow : {vars : _ } -> Vect 2 (NF vars) -> Maybe (NF vars)
doublePow = binOp pow'
    where pow' : Constant -> Constant -> Maybe Constant
          pow' (Db x) (Db y) = pure $ Db (pow x y)
          pow' _ _ = Nothing

doubleSin : Vect 1 (NF vars) -> Maybe (NF vars)
doubleSin = doubleOp sin

doubleCos : Vect 1 (NF vars) -> Maybe (NF vars)
doubleCos = doubleOp cos

doubleTan : Vect 1 (NF vars) -> Maybe (NF vars)
doubleTan = doubleOp tan

doubleASin : Vect 1 (NF vars) -> Maybe (NF vars)
doubleASin = doubleOp asin

doubleACos : Vect 1 (NF vars) -> Maybe (NF vars)
doubleACos = doubleOp acos

doubleATan : Vect 1 (NF vars) -> Maybe (NF vars)
doubleATan = doubleOp atan

doubleSqrt : Vect 1 (NF vars) -> Maybe (NF vars)
doubleSqrt = doubleOp sqrt

doubleFloor : Vect 1 (NF vars) -> Maybe (NF vars)
doubleFloor = doubleOp floor

doubleCeiling : Vect 1 (NF vars) -> Maybe (NF vars)
doubleCeiling = doubleOp ceiling

-- Only reduce for concrete values
believeMe : Vect 3 (NF vars) -> Maybe (NF vars)
believeMe [_, _, val@(NDCon _ _ _ _ _)] = Just val
believeMe [_, _, val@(NTCon _ _ _ _ _)] = Just val
believeMe [_, _, val@(NPrimVal _ _)] = Just val
believeMe [_, _, NType fc u] = Just (NType fc u)
believeMe [_, _, val] = Nothing

constTy : Constant -> Constant -> Constant -> ClosedTerm
constTy a b c
    = let arr = fnType emptyFC in
    PrimVal emptyFC a `arr` (PrimVal emptyFC b `arr` PrimVal emptyFC c)

constTy3 : Constant -> Constant -> Constant -> Constant -> ClosedTerm
constTy3 a b c d
    = let arr = fnType emptyFC in
    PrimVal emptyFC a `arr`
         (PrimVal emptyFC b `arr`
             (PrimVal emptyFC c `arr` PrimVal emptyFC d))

predTy : Constant -> Constant -> ClosedTerm
predTy a b = let arr = fnType emptyFC in
             PrimVal emptyFC a `arr` PrimVal emptyFC b

arithTy : Constant -> ClosedTerm
arithTy t = constTy t t t

cmpTy : Constant -> ClosedTerm
cmpTy t = constTy t t IntType

doubleTy : ClosedTerm
doubleTy = predTy DoubleType DoubleType

pi : (x : String) -> RigCount -> PiInfo (Term xs) -> Term xs ->
     Term (UN (Basic x) :: xs) -> Term xs
pi x rig plic ty sc = Bind emptyFC (UN (Basic x)) (Pi emptyFC rig plic ty) sc

believeMeTy : ClosedTerm
believeMeTy
    = pi "a" erased Explicit (TType emptyFC (MN "top" 0)) $
      pi "b" erased Explicit (TType emptyFC (MN "top" 0)) $
      pi "x" linear Explicit (Local emptyFC Nothing _ (Later First)) $
      Local emptyFC Nothing _ (Later First)

crashTy : ClosedTerm
crashTy
    = pi "a" erased Explicit (TType emptyFC (MN "top" 0)) $
      pi "msg" top Explicit (PrimVal emptyFC StringType) $
      Local emptyFC Nothing _ (Later First)

castTo : Constant -> Vect 1 (NF vars) -> Maybe (NF vars)
castTo IntType = castInt
castTo Int8Type = castInt8
castTo Int16Type = castInt16
castTo Int32Type = castInt32
castTo Int64Type = castInt64
castTo IntegerType = castInteger
castTo Bits8Type = castBits8
castTo Bits16Type = castBits16
castTo Bits32Type = castBits32
castTo Bits64Type = castBits64
castTo StringType = castString
castTo CharType = castChar
castTo DoubleType = castDouble
castTo _ = const Nothing

export
getOp : {0 arity : Nat} -> PrimFn arity ->
        {vars : List Name} -> Vect arity (NF vars) -> Maybe (NF vars)
getOp (Add ty) = binOp add
getOp (Sub ty) = binOp sub
getOp (Mul ty) = binOp mul
getOp (Div ty) = binOp div
getOp (Mod ty) = binOp mod
getOp (Neg ty) = unaryOp neg
getOp (ShiftL ty) = binOp shiftl
getOp (ShiftR ty) = binOp shiftr

getOp (BAnd ty) = binOp band
getOp (BOr ty) = binOp bor
getOp (BXOr ty) = binOp bxor

getOp (LT ty) = binOp lt
getOp (LTE ty) = binOp lte
getOp (EQ ty) = binOp eq
getOp (GTE ty) = binOp gte
getOp (GT ty) = binOp gt

getOp StrLength = strLength
getOp StrHead = strHead
getOp StrTail = strTail
getOp StrIndex = strIndex
getOp StrCons = strCons
getOp StrAppend = strAppend
getOp StrReverse = strReverse
getOp StrSubstr = strSubstr

getOp DoubleExp = doubleExp
getOp DoubleLog = doubleLog
getOp DoublePow = doublePow
getOp DoubleSin = doubleSin
getOp DoubleCos = doubleCos
getOp DoubleTan = doubleTan
getOp DoubleASin = doubleASin
getOp DoubleACos = doubleACos
getOp DoubleATan = doubleATan
getOp DoubleSqrt = doubleSqrt
getOp DoubleFloor = doubleFloor
getOp DoubleCeiling = doubleCeiling

getOp (Cast _ y) = castTo y
getOp BelieveMe = believeMe

getOp _ = const Nothing

prim : String -> Name
prim str = UN $ Basic $ "prim__" ++ str

export
opName : {0 arity : Nat} -> PrimFn arity -> Name
opName (Add ty) = prim $ "add_" ++ show ty
opName (Sub ty) = prim $ "sub_" ++ show ty
opName (Mul ty) = prim $ "mul_" ++ show ty
opName (Div ty) = prim $ "div_" ++ show ty
opName (Mod ty) = prim $ "mod_" ++ show ty
opName (Neg ty) = prim $ "negate_" ++ show ty
opName (ShiftL ty) = prim $ "shl_" ++ show ty
opName (ShiftR ty) = prim $ "shr_" ++ show ty
opName (BAnd ty) = prim $ "and_" ++ show ty
opName (BOr ty) = prim $ "or_" ++ show ty
opName (BXOr ty) = prim $ "xor_" ++ show ty
opName (LT ty) = prim $ "lt_" ++ show ty
opName (LTE ty) = prim $ "lte_" ++ show ty
opName (EQ ty) = prim $ "eq_" ++ show ty
opName (GTE ty) = prim $ "gte_" ++ show ty
opName (GT ty) = prim $ "gt_" ++ show ty
opName StrLength = prim "strLength"
opName StrHead = prim "strHead"
opName StrTail = prim "strTail"
opName StrIndex = prim "strIndex"
opName StrCons = prim "strCons"
opName StrAppend = prim "strAppend"
opName StrReverse = prim "strReverse"
opName StrSubstr = prim "strSubstr"
opName DoubleExp = prim "doubleExp"
opName DoubleLog = prim "doubleLog"
opName DoublePow = prim "doublePow"
opName DoubleSin = prim "doubleSin"
opName DoubleCos = prim "doubleCos"
opName DoubleTan = prim "doubleTan"
opName DoubleASin = prim "doubleASin"
opName DoubleACos = prim "doubleACos"
opName DoubleATan = prim "doubleATan"
opName DoubleSqrt = prim "doubleSqrt"
opName DoubleFloor = prim "doubleFloor"
opName DoubleCeiling = prim "doubleCeiling"
opName (Cast x y) = prim $ "cast_" ++ show x ++ show y
opName BelieveMe = prim $ "believe_me"
opName Crash = prim $ "crash"

integralTypes : List Constant
integralTypes = [ IntType
                , Int8Type
                , Int16Type
                , Int32Type
                , Int64Type
                , IntegerType
                , Bits8Type
                , Bits16Type
                , Bits32Type
                , Bits64Type
                ]

numTypes : List Constant
numTypes = integralTypes ++ [DoubleType]

primTypes : List Constant
primTypes = numTypes ++ [StringType, CharType]

export
allPrimitives : List Prim
allPrimitives =
    map (\t => MkPrim (Add t) (arithTy t) isTotal)     numTypes ++
    map (\t => MkPrim (Sub t) (arithTy t) isTotal)     numTypes ++
    map (\t => MkPrim (Mul t) (arithTy t) isTotal)     numTypes ++
    map (\t => MkPrim (Neg t) (predTy t t) isTotal)    numTypes ++
    map (\t => MkPrim (Div t) (arithTy t) notCovering) numTypes ++
    map (\t => MkPrim (Mod t) (arithTy t) notCovering) integralTypes ++

    map (\t => MkPrim (ShiftL t) (arithTy t) isTotal)  integralTypes ++
    map (\t => MkPrim (ShiftR t) (arithTy t) isTotal)  integralTypes ++
    map (\t => MkPrim (BAnd t) (arithTy t) isTotal)    integralTypes ++
    map (\t => MkPrim (BOr t) (arithTy t) isTotal)     integralTypes ++
    map (\t => MkPrim (BXOr t) (arithTy t) isTotal)    integralTypes ++

    map (\t => MkPrim (LT t) (cmpTy t) isTotal)  primTypes ++
    map (\t => MkPrim (LTE t) (cmpTy t) isTotal) primTypes ++
    map (\t => MkPrim (EQ t) (cmpTy t) isTotal)  primTypes ++
    map (\t => MkPrim (GTE t) (cmpTy t) isTotal) primTypes ++
    map (\t => MkPrim (GT t) (cmpTy t) isTotal)  primTypes ++

    [MkPrim StrLength (predTy StringType IntType) isTotal,
     MkPrim StrHead (predTy StringType CharType) notCovering,
     MkPrim StrTail (predTy StringType StringType) notCovering,
     MkPrim StrIndex (constTy StringType IntType CharType) notCovering,
     MkPrim StrCons (constTy CharType StringType StringType) isTotal,
     MkPrim StrAppend (arithTy StringType) isTotal,
     MkPrim StrReverse (predTy StringType StringType) isTotal,
     MkPrim StrSubstr (constTy3 IntType IntType StringType StringType) isTotal,
     MkPrim BelieveMe believeMeTy isTotal,
     MkPrim Crash crashTy notCovering] ++

    [MkPrim DoubleExp doubleTy isTotal,
     MkPrim DoubleLog doubleTy isTotal,
     MkPrim DoublePow (arithTy DoubleType) isTotal,
     MkPrim DoubleSin doubleTy isTotal,
     MkPrim DoubleCos doubleTy isTotal,
     MkPrim DoubleTan doubleTy isTotal,
     MkPrim DoubleASin doubleTy isTotal,
     MkPrim DoubleACos doubleTy isTotal,
     MkPrim DoubleATan doubleTy isTotal,
     MkPrim DoubleSqrt doubleTy isTotal,
     MkPrim DoubleFloor doubleTy isTotal,
     MkPrim DoubleCeiling doubleTy isTotal] ++

    -- support all combinations of primitive casts with the following
    -- exceptions: String -> Char, Double -> Char, Char -> Double
    [ MkPrim (Cast t1 t2) (predTy t1 t2) isTotal
    | t1 <- primTypes
    , t2 <- primTypes
    , t1 /= t2                         &&
      (t1,t2) /= (StringType,CharType) &&
      (t1,t2) /= (DoubleType,CharType) &&
      (t1,t2) /= (CharType,DoubleType)
    ]


--   Copyright 2017-2018 The Lathe Authors
--
--   Licensed under the Apache License, Version 2.0 (the "License");
--   you may not use this file except in compliance with the License.
--   You may obtain a copy of the License at
--
--       http://www.apache.org/licenses/LICENSE-2.0
--
--   Unless required by applicable law or agreed to in writing,
--   software distributed under the License is distributed on an
--   "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
--   either express or implied. See the License for the specific
--   language governing permissions and limitations under the License.

Let's represent towers as towers of one less degree where the highest-degree holes are now contained in the islands.

So

  ^`( ~`( ,( ,( ) ) ) )

is to be represented like so:

  `( something ,( ) something )

Islands must have an overall balanced structure to them. The first "something" island opens the higher-degree hole, and the second "something" closes it. A single island may close and open many holes, and it may even dip into a hole without closing it, like the middle part of this:

  ^`( ~`( ,( ,( ) ) ,( ,( ) ) ) )
   `( ------ ,( ) ---- ,( ) --- )

As a lower-degree example,

  `( ,( ) )

is to be represented like so:

  ( something )

Clearly, everything at that degree will be represented as "( something )" for some value of "something," so that can be the base case of our representation.

exprOf : Nat -> Type -> Type
exprOf d i = Expr d 0 (\_ _ -> ()) i

exprBranchType :
  (d : Nat) -> (c : Nat -> Nat -> Type) -> (i : Type) -> Type
exprBranchType =
  (nextStartingDepth : Nat) *
  (i * exprOf d (Expr (1 + d) nextStartingDepth c i))

exprMap :
  (d : Nat) ->
  (startingDepth : Nat) ->
  (c : Nat -> Nat -> Type) ->
  (i : Type) ->
  (i' : type) ->
  (i -> i') ->
  Expr d startingDepth c i ->
  Expr d startingDepth c i'
exprMap d startingDepth c i i' f expr = case expr of
  exprNil d'' s'' c'' i'' content'' =>
    exprNil d'' s'' c'' i' content''
  exprCons d'' startingDepth'' c'' i'' branches'' content'' =>
    exprCons d'' startingDepth'' c'' i'
      (exprMap d'' startingDepth'' c''
        (exprBranchType d'' c'' i'')
        (exprBranchType d'' c'' i')
        (\(nextStartingDepth * (iVal * branches)) ->
          nextStartingDepth *
          (f iVal *
            exprMap d'' 0 (\_ _ -> ())
              (Expr d nextStartingDepth c'' i'')
              (Expr d nextStartingDepth c'' i')
              (exprMap d nextStartingDepth c'' i'' i' f)
              branches))
        branches'')

type Expr
  (degree : Nat)
  (startingDepth : Nat)
  (content : Nat -> exprOf d Nat -> Type)
  (interpolation : Type)
where
  exprNil :
    (d : Nat) ->
    (s : Nat) ->
    (c : Nat -> exprOf d Nat -> Type) ->
    (i : Type) ->
    c s (exprNil d 0 (\_ _ -> ()) Nat) ->
    Expr (1 + d) s c i
  exprCons :
    (d : Nat) ->
    (startingDepth : Nat) ->
    (c : Nat -> Nat -> Type) ->
    (i : Type) ->
    (branches : exprOf d (exprBranchType d c i)) ->
    c startingDepth
      (exprMap d 0 (\_ _ -> ()) (exprBranchType d c i) Nat
        (\(nextStartingDepth * _) -> nextStartingDepth)
        branches) ->
    Expr (1 + d) startingDepth c i

-- TODO: Whoops, the above `Expr` has no constructors for degree 0,
-- and its constructors for degrees greater than 0 aren't using island
-- content values to represent higher-degree holes. Finish making a
-- version of expr which does this, below.

vec : Nat -> Type -> Type
vec n t = case n of
  0 => () * ()
  1 + n' => t * vec n' t

exprInfoType : Nat -> Type
exprInfoType degree = case degree of
  0 =>
    (balanceStateType : Type) *
    let bl = List balanceStateType in
    (bl -> () -> Type) *
    (bl -> () -> Type)
  1 + degree' =>
    (balanceStateType : Type) *
    let bl = List balanceStateType in
    (bl -> exprOf degree' bl -> Type) *
    (bl -> exprOf degree' bl -> Type)

type List (a : Type) where
  nil : (a : Type) -> List a
  cons : (a : Type) -> a -> List a -> List a

exprInfo :
  (degree : Nat) ->
  (balanceStateType0 : Type) ->
  (List balanceStateType0 -> Type) ->
  (List balanceStateType0 -> Type) ->
  exprInfoType degree
exprInfo degree balanceStateType0 i0 l0 = case degree of
  0 =>
    balanceStateType0 *
    (\currentBalance () -> i0 currentBalance) *
    (\currentBalance () -> l0 currentBalance)
  1 + degree' =>
    let
      balanceStateTypeN * iN * lN =
        exprInfo degree' balanceStateType0 i0 l0
    in
    List balanceStateTypeN *
    (\currentBalance edge ->
      Expr degree'
        (balanceStateTypeN * iN *
          (\currentBalance edge ->
            (case currentBalance of
              nil subBalanceType => Bot
              cons subBalanceType subBalance subBalances =>
                exprOf degree'
                  ( (E) +
                    ())) +
            ())
        (nil balanceStateTypeN)) *
    (\currentBalance edge -> ())

island : Nat -> (balanceStateType : Type) -> balanceStateType -> Type
island degree balanceStateType startingBalance =
  Expr degree Nat c'

type Expr
  (degree : Nat)
  (balanceStateType * i * l * ti : exprInfoType degree)
  List balanceStateType
where
  expr :
    (d : Nat) ->
    (balanceStateType : Type) ->
    (balanceStateType * i * l * ti : exprInfoType d) ->
    (startingBalance : List balanceStateType) ->
    (case d of
      0 => () * i startingBalance ()
      1 + d' =>
        let balanceStateType' * i' * l' * ti' = ti in
        (e : Expr d' ti
          (
          -- TODO: Implement island.
          (island d' balanceStateType c (lakeType * lakeTypes)
            startingBalance)
          lakeTypes
          0) *
        i startingBalance
          -- TODO: Implement exprMap, and pass it whatever other
          -- arguments it needs here.
          (exprMap
            (\newStartingBalance lake -> newStartingBalance)
            e)) ->
    Expr d balanceStateType c (lakeType * lakeTypes) startingBalance

 that degree we only have a single "something" in the representation no


module Test

import Lambdapants.Command
import Lambdapants.Command.Parser
import Lambdapants.Term
import Lambdapants.Term.Parser
import Lambdapants.Term.Reduction
import Lightyear
import Lightyear.Strings

partial parseUnsafe_ : String -> Term
parseUnsafe_ input =
  case parse term input of
       Right t => t

export test : IO ()
test = do

  -- Test reductions

  putStrLn (show (isLeft (parse term "\\x.x )))")))
  putStrLn (show (isRight (parse term "\\x.x")))

  let t0 = parseUnsafe_ "(\\x.\\y.x y) y"
  putStrLn (show (parseUnsafe_ "\\z.y z" `alphaEq` nor t0))

  let t0_1 = parseUnsafe_ "(\\x.\\y.\\z.x y z) z"
  putStrLn (show (parseUnsafe_ "\\y.\\z0.z y z0" `alphaEq` nor t0_1))

  let t0_2 = parseUnsafe_ "(\\x.\\y.\\z.\\a.x y z a) (z a)"
  putStrLn (show (parseUnsafe_ "\\y.\\z0.\\a0.(z a) y z0 a0" `alphaEq` nor t0_2))

  let t1 = parseUnsafe_ "(\\a.\\b.a) c ((\\d.e) d)"
  let t2 = parseUnsafe_ "(\\b.c) ((\\d.e) d)"
  putStrLn (show (t2 `alphaEq` nor t1))
  let t3 = parseUnsafe_ "c"
  putStrLn (show (t3 `alphaEq` nor t2))
  --
  let t4 = parseUnsafe_ "(\\a.\\b.a) c ((\\d.e) d)"
  let t5 = parseUnsafe_ "(\\a.\\b.a) c e"
  putStrLn (show (t5 `alphaEq` aor t4))
  let t6 = parseUnsafe_ "(\\b.c) e"
  putStrLn (show (t6 `alphaEq` aor t5))
  putStrLn (show (t3 `alphaEq` aor t6))
  --
  let t7 = parseUnsafe_ "(\\x.a)((\\x.x x)(\\y.y y))"
  putStrLn (show (parseUnsafe_ "a" `alphaEq` nor t7))
  --
  let t8 = parseUnsafe_ "(\\x.a)((\\y.y y)(\\y.y y))"
  putStrLn (show (t8 `alphaEq` aor t7))
  --
  let t9 = parseUnsafe_ "((\\a.x) ((\\a.a a)(\\a.((\\b.a b) a))))"
  putStrLn (show (Var "x" `alphaEq` nor t9))
  --
  let t10 = parseUnsafe_ "(\\x.\\i0.y) c (\\z.(\\w.(\\b.(\\a.a) c) z) f)"
  let t11 = parseUnsafe_ "(\\x.y) (\\z.(\\w.(\\b.(\\a.a) c) z) f)"
  putStrLn (show (t11 `alphaEq` nor t10))
  putStrLn (show (Var "y" `alphaEq` nor t11))
  --
  let t12 = parseUnsafe_ "((\\a.x) ((\\a.a a) (\\a.a a)))"
  putStrLn (show (t12 `alphaEq` aor t9))
  putStrLn (show (t12 `alphaEq` aor (aor t9)))
  --
  let t13 = parseUnsafe_ "((\\x.\\x.y) c (\\z.(\\w.(\\b.(\\a.a) c) z) f))"
  let t14 = parseUnsafe_ "(\\x.\\i0.y) c (\\z.(\\b.(\\a.a) c) z)"
  putStrLn (show (t14 `alphaEq` aor t13))
  let t15 = parseUnsafe_ "(\\x.\\i0.y) c (\\z.(\\a.a) c)"
  putStrLn (show (t15 `alphaEq` aor t14))
  let t16 = parseUnsafe_ "(\\x.\\i0.y) c (\\z.c)"
  putStrLn (show (t16 `alphaEq` aor t15))
  let t17 = parseUnsafe_ "(\\x.y) (\\z.c)"
  putStrLn (show (t17 `alphaEq` aor t16))
  let t18 = parseUnsafe_ "y"
  putStrLn (show (t18 `alphaEq` aor t17))
  --

  -- Test repl expressions

  putStrLn (show (parseCmd "env"        == Right Env))
  putStrLn (show (parseCmd "env  "      == Right Env))
  putStrLn (show (isLeft (parseCmd "envxx")))
  putStrLn (show (isLeft (parseCmd "env mu")))
  putStrLn (show (isLeft (parseCmd "env   baz")))

  putStrLn (show (parseCmd "h "         == Right Help))
  putStrLn (show (parseCmd "h"          == Right Help))
  putStrLn (show (parseCmd "help  "     == Right Help))
  putStrLn (show (parseCmd "help"       == Right Help))
  putStrLn (show (isLeft (parseCmd "hp")))
  putStrLn (show (isLeft (parseCmd "helpo")))
  putStrLn (show (parseCmd "? "         == Right Help))
  putStrLn (show (parseCmd "?"          == Right Help))
  putStrLn (show (isLeft (parseCmd "?elp")))

  putStrLn (show (parseCmd "aq (\\x.x) Y" == Right (AlphaEq (Lam "x" (Var "x")) (Var "Y"))))
  putStrLn (show (parseCmd "aq X Y"     == Right (AlphaEq (Var "X") (Var "Y"))))
  putStrLn (show (isLeft (parseCmd "aqX Y")))
  putStrLn (show (parseCmd "aq X"       == Left "Usage is :aq <term> <term>"))
  putStrLn (show (parseCmd "aq"         == Left "Usage is :aq <term> <term>"))
  putStrLn (show (parseCmd "aq "        == Left "Usage is :aq <term> <term>"))
  putStrLn (show (parseCmd "aq (\\x.x)" == Left "Usage is :aq <term> <term>"))

  putStrLn (show (parseCmd "eq X Y"     == Right (Eq (Var "X") (Var "Y"))))
  putStrLn (show (isLeft (parseCmd "eqX Y")))
  putStrLn (show (parseCmd "eq X"       == Left "Usage is :eq <term> <term>"))

  putStrLn (show (parseCmd "reduce"     == Left "Usage is :reduce <term>"))
  putStrLn (show (parseCmd "reduce  "   == Left "Usage is :reduce <term>"))
  putStrLn (show (parseCmd "r"          == Left "Usage is :r <term>"))
  putStrLn (show (isLeft (parseCmd "reducex")))
  putStrLn (show (parseCmd "reduce X"   == Right (Reduce (Var "X"))))

  putStrLn (show (parseCmd "whatis"     == Left "Usage is :whatis <term>"))
  putStrLn (show (parseCmd "whatis  "   == Left "Usage is :whatis <term>"))
  putStrLn (show (parseCmd "w"          == Left "Usage is :w <term>"))
  putStrLn (show (isLeft (parseCmd "whatisx")))
  putStrLn (show (parseCmd "whatis X"     == Right (Whatis (Var "X"))))
  putStrLn (show (parseCmd "whatis (X Y)" == Right (Whatis (App (Var "X") (Var "Y")))))
  putStrLn (show (parseCmd "w (X Y)"      == Right (Whatis (App (Var "X") (Var "Y")))))

  putStrLn (show (parseCmd "unset "     == Left "Usage is :unset <symbol>"))
  putStrLn (show (parseCmd "unset"      == Left "Usage is :unset <symbol>"))
  putStrLn (show (parseCmd "unset  "    == Left "Usage is :unset <symbol>"))
  putStrLn (show (parseCmd "u "         == Left "Usage is :u <symbol>"))
  putStrLn (show (parseCmd "u"          == Left "Usage is :u <symbol>"))
  putStrLn (show (isLeft (parseCmd "uz")))
  putStrLn (show (isLeft (parseCmd "uns del")))
  putStrLn (show (isLeft (parseCmd "uns wat")))
  putStrLn (show (parseCmd "u baz"      == Right (Unset "baz")))
  putStrLn (show (parseCmd "unset baz"  == Right (Unset "baz")))
  putStrLn (show (parseCmd "unset fez_baz"
                                        == Right (Unset "fez_baz")))
  putStrLn (show (parseCmd "u fez_baz"  == Right (Unset "fez_baz")))

  putStrLn (show (parseCmd "limit 3"    == Right (Limit 3)))
  putStrLn (show (parseCmd "limit 300"  == Right (Limit 300)))
  putStrLn (show (parseCmd "limit"      == Left "Usage is :limit <number>"))
  putStrLn (show (parseCmd "limit "     == Left "Usage is :limit <number>"))
  putStrLn (show (parseCmd "limit foo"  == Left "Usage is :limit <number>"))
  putStrLn (show (parseCmd "limit 30x"  == Left "Usage is :limit <number>"))
  putStrLn (show (parseCmd "limit f3"   == Left "Usage is :limit <number>"))
  putStrLn (show (isLeft (parseCmd "limits")))

  putStrLn (show (parseCmd "q "         == Right Quit))
  putStrLn (show (parseCmd "q"          == Right Quit))
  putStrLn (show (parseCmd "quit "      == Right Quit))
  putStrLn (show (parseCmd "quit"       == Right Quit))
  putStrLn (show (isLeft (parseCmd "qu")))
  putStrLn (show (isLeft (parseCmd "quitquit")))

  putStrLn (show (isLeft (parseCmd "setup")))
  putStrLn (show (parseCmd "set"               == Left "Usage is :set <symbol> <term>"))
  putStrLn (show (parseCmd "set "              == Left "Usage is :set <symbol> <term>"))
  putStrLn (show (parseCmd "set baz"           == Left "Usage is :set <symbol> <term>"))
  putStrLn (show (parseCmd "set baz \\x.("     == Left "Usage is :set <symbol> <term>"))
  putStrLn (show (parseCmd "set foo foo"       == Right (Set "foo" (Var "foo"))))
  putStrLn (show (parseCmd "set id (\\x.x)"    == Right (Set "id" (Lam "x" (Var "x")))))
  putStrLn (show (parseCmd "set id    (\\x.x)" == Right (Set "id" (Lam "x" (Var "x")))))
  putStrLn (show (parseCmd "set x_x (A B)"     == Right (Set "x_x" (App (Var "A") (Var "B")))))
  putStrLn (show (parseCmd "set  why (\\g.(\\x.g (x x)) (\\x.g (x x)))"
                                               == Right (Set "why" (Lam "g" (App (Lam "x" (App (Var "g") (App (Var "x") (Var "x")))) (Lam "x" (App (Var "g") (App (Var "x") (Var "x")))))))))


import DepPairs
import Do
import Hello
import Loops
import PrintLength
import ReadNum
import ReadVect


module Idris.Codegen.ExtSTG.GHCPrimOp

import Idris.Codegen.ExtSTG.Prelude
import Idris.Codegen.ExtSTG.Representation

public export
data PrimOp : (name: String) -> (args : List PrimRep) -> (ret : PrimRep) -> Type where
  PlusInt      : PrimOp "+#"            [IntRep   , IntRep   ] IntRep
  PlusWord8    : PrimOp "plusWord8#"    [Word8Rep , Word8Rep ] Word8Rep
  PlusWord16   : PrimOp "plusWord16#"   [Word16Rep, Word16Rep] Word16Rep
  PlusWord     : PrimOp "plusWord3"     [WordRep  , WordRep  ] WordRep
  PlusDouble   : PrimOp "+##"           [DoubleRep, DoubleRep] DoubleRep
  SubInt       : PrimOp "-#"            [IntRep   , IntRep   ] IntRep
  SubWord8     : PrimOp "subWord8#"     [Word8Rep , Word8Rep ] Word8Rep
  SubWord16    : PrimOp "subWord16#"    [Word16Rep, Word16Rep] Word16Rep
  SubWord      : PrimOp "subWord#"      [WordRep  , WordRep  ] WordRep
  SubDouble    : PrimOp "-##"           [DoubleRep, DoubleRep] DoubleRep
  TimesInt     : PrimOp "*#"            [IntRep   , IntRep   ] IntRep
  TimesWord8   : PrimOp "timesWord8#"   [Word8Rep , Word8Rep ] Word8Rep
  TimesWord16  : PrimOp "timesWord16#"  [Word16Rep, Word16Rep] Word16Rep
  TimesWord    : PrimOp "timesWord#"    [WordRep  , WordRep  ] WordRep
  TimesDouble  : PrimOp "timesDouble#"  [DoubleRep, DoubleRep] DoubleRep
  QuotInt      : PrimOp "qoutInt#"      [IntRep   , IntRep   ] IntRep
  QuotWord8    : PrimOp "quotWord8#"    [Word8Rep , Word8Rep ] Word8Rep
  QuotWord16   : PrimOp "quotWord16#"   [Word16Rep, Word16Rep] Word16Rep
  QuotWord     : PrimOp "quotWord#"     [WordRep  , WordRep  ] WordRep
  QuotDouble   : PrimOp "/##"           [DoubleRep, DoubleRep] DoubleRep
  RemInt       : PrimOp "remInt#"       [IntRep   , IntRep   ] IntRep
  RemWord8     : PrimOp "remWord8#"     [Word8Rep , Word8Rep ] Word8Rep
  RemWord16    : PrimOp "remWord16#"    [Word16Rep, Word16Rep] Word16Rep
  RemWord      : PrimOp "remWord#"      [WordRep  , WordRep  ] WordRep
  AndInt       : PrimOp "andI#"         [IntRep   , IntRep   ] IntRep
  AndWord      : PrimOp "and#"          [WordRep  , WordRep  ] WordRep
  OrInt        : PrimOp "orI#"          [IntRep   , IntRep   ] IntRep
  OrWord       : PrimOp "or#"           [WordRep  , WordRep  ] WordRep
  XOrInt       : PrimOp "xorI#"         [IntRep   , IntRep   ] IntRep
  XOrWord      : PrimOp "xor#"          [WordRep  , WordRep  ] WordRep
  LTInt        : PrimOp "<#"            [IntRep   , IntRep   ] IntRep
  LTWord8      : PrimOp "ltWord8#"      [Word8Rep , Word8Rep ] IntRep
  LTWord16     : PrimOp "ltWord16#"     [Word16Rep, Word16Rep] IntRep
  LTWord       : PrimOp "ltWord#"       [WordRep  , WordRep  ] IntRep
  LTDouble     : PrimOp "<##"           [DoubleRep, DoubleRep] IntRep
  LTEInt       : PrimOp "<=#"           [IntRep   , IntRep   ] IntRep
  LTEWord8     : PrimOp "leWord8#"      [Word8Rep , Word8Rep ] IntRep
  LTEWord16    : PrimOp "leWord16#"     [Word16Rep, Word16Rep] IntRep
  LTEWord      : PrimOp "leWord#"       [WordRep  , WordRep  ] IntRep
  LTEDouble    : PrimOp "<=##"          [DoubleRep, DoubleRep] IntRep
  EQInt        : PrimOp "==#"           [IntRep   , IntRep   ] IntRep
  EQWord8      : PrimOp "eqWord8#"      [Word8Rep , Word8Rep ] IntRep
  EQWord16     : PrimOp "eqWord16#"     [Word16Rep, Word16Rep] IntRep
  EQWord       : PrimOp "eqWord"        [WordRep  , WordRep  ] IntRep
  EQDouble     : PrimOp "==##"          [DoubleRep, DoubleRep] IntRep
  GTEInt       : PrimOp ">=#"           [IntRep   , IntRep   ] IntRep
  GTEWord8     : PrimOp "geWord8#"      [Word8Rep , Word8Rep ] IntRep
  GTEWord16    : PrimOp "geWord16#"     [Word16Rep, Word16Rep] IntRep
  GTEWord      : PrimOp "geWord"        [WordRep  , WordRep  ] IntRep
  GTEDouble    : PrimOp ">=##"          [DoubleRep, DoubleRep] IntRep
  GTInt        : PrimOp ">#"            [IntRep   , IntRep   ] IntRep
  GTWord8      : PrimOp "gtWord8#"      [Word8Rep , Word8Rep ] IntRep
  GTWord16     : PrimOp "gtWord16#"     [Word16Rep, Word16Rep] IntRep
  GTWord       : PrimOp "gtWord"        [WordRep  , WordRep  ] IntRep
  GTDouble     : PrimOp ">##"           [DoubleRep, DoubleRep] IntRep
  NegateInt    : PrimOp "negateInt#"    [IntRep   ] IntRep
  NegateDouble : PrimOp "negateDouble#" [DoubleRep] DoubleRep
  ExpDouble    : PrimOp "expDouble"     [DoubleRep] DoubleRep
  LogDouble    : PrimOp "logDouble"     [DoubleRep] DoubleRep
  SinDouble    : PrimOp "sinDouble"     [DoubleRep] DoubleRep
  CosDouble    : PrimOp "cosDouble"     [DoubleRep] DoubleRep
  TanDouble    : PrimOp "tanDouble"     [DoubleRep] DoubleRep
  ASinDouble   : PrimOp "asinDouble"    [DoubleRep] DoubleRep
  ACosDouble   : PrimOp "acosDouble"    [DoubleRep] DoubleRep
  ATanDouble   : PrimOp "atanDouble"    [DoubleRep] DoubleRep
  SqrtDouble   : PrimOp "sqrtDouble"    [DoubleRep] DoubleRep
  IShiftLInt   : PrimOp "uncheckedIShiftL#"  [IntRep, IntRep] IntRep
  IShiftLRInt  : PrimOp "uncheckedIShiftRL#" [IntRep, IntRep] IntRep

  IndexWord8OffAddr : PrimOp "indexWord8OffAddr#" [AddrRep, IntRep] Word8Rep
  IndexWord8Array   : PrimOp "indexWord8Array#" [ByteArrayRep, IntRep] Word8Rep
  SizeOfByteArray   : PrimOp "sizeofByteArray#" [ByteArrayRep] IntRep
  ByteArrayContents : PrimOp "byteArrayContents#" [ByteArrayRep] AddrRep

  -- State ignoring PrimOps:
  -- Int# -> State# s -> (# State# s, MutableByteArray# s #)
  NewByteArray : PrimOp "newByteArray#" [IntRep] MutableByteArrayRep
  -- Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
  CopyAddrToByteArray : PrimOp "copyAddrToByteArray#" [AddrRep, MutableByteArrayRep, IntRep, IntRep] VoidRep
  -- MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)
  UnsafeFreezeByteArray : PrimOp "unsafeFreezeByteArray#" [MutableByteArrayRep] ByteArrayRep
  -- MutableByteArray# s -> Int# -> Word# -> State# s -> State# s
  WriteWord8Array : PrimOp "writeWord8Array#" [MutableByteArrayRep,IntRep,Word8Rep] VoidRep

namespace PrimOp

  export
  name : {n : String} -> PrimOp n args r -> String
  name {n} _ = n

  export
  args : {as : List PrimRep} -> PrimOp n as r -> List PrimRep
  args {as} _ = as


module GRIN.Analysis.Inline

import Data.List
import Data.Num.Implementations
import Data.SortedMap as Map
import Data.SortedMap.Extra
import Data.SortedSet as Set

import GRIN.AST
import GRIN.GrinM

[SemigroupMergeLeft] Semigroup (SortedMap k v) where
    (<+>) = mergeLeft

[MonoidMergeLeft] Ord k => Monoid (SortedMap k v) using SemigroupMergeLeft where
    neutral = empty

simpleDef : Ord name => Def name -> SortedMap name (Def name)
simpleDef (MkDef fn _ (SimpleExp (Do _)) _) = empty
simpleDef def@(MkDef fn _ (SimpleExp _) _) = singleton fn def
simpleDef _ = empty

export
inlineSimpleDefs : Ord name => Monad m => GrinT name m ()
inlineSimpleDefs = do
    MkProg _ defs m <- gets prog
    modify $ record { toInline =
        delete m $ foldMap @{%search} @{MonoidMergeLeft} simpleDef defs }

calledSExp : Eq name => name -> SExp name -> Nat
calledExp : Eq name => name -> Exp name -> Nat

calledSExp fn (Do e) = calledExp fn e
calledSExp fn (App fn' _) = if fn == fn' then 1 else 0
calledSExp _ _ = 0

calledExp fn (SimpleExp e) = calledSExp fn e
calledExp fn (Bind _ rhs rest) = calledSExp fn rhs + calledExp fn rest
calledExp fn (Case _ alts) = foldMap @{%search} @{Additive} (calledExp fn . altExp) alts

export
inlineUsedOnce : Ord name => Monad m => GrinT name m ()
inlineUsedOnce = do
    ds <- gets $ defs . prog
    cg <- getCalls
    let toInline = foldr (addOne ds) empty $ Map.toList cg
    modify $ record { toInline = toInline }
  where
    addOne : SortedMap name (Def name) -> (name, SortedSet name) -> SortedMap name (Def name) -> SortedMap name(Def name)
    addOne ds (fn, callers) ins = case Set.toList callers of
        [caller] => case lookup caller ds of
            Just callerDef => if calledExp fn (callerDef.body) <= 1
                then case lookup fn ds of
                    Just def => insert fn def ins
                    Nothing => ins
                else ins
            Nothing => ins
        _ => ins


module TestClock

import System.Clock

clockSmall : Clock type -> Bool
clockSmall (MkClock {type} s n) = MkClock {type} s n < MkClock 1 0

clockBig : Clock type -> Bool
clockBig (MkClock {type} s n) = MkClock {type} s n > MkClock 1600000000 0

main : IO ()
main = do
    utc <- clockTime UTC
    monotonicStart <- clockTime Monotonic
    process <- clockTime Process
    thread <- clockTime Thread

    monotonicEnd <- clockTime Monotonic

    putStrLn $ show $ [
        clockBig utc,
        monotonicStart < monotonicEnd,
        clockSmall process,
        clockSmall thread
    ]


module Main

import public Eval
import public Lexer as L
import public Parser as P
import public Syntax

import Control.Monad.Identity
import Lightyear
import Lightyear.Strings

quit : String
quit = ":q"

prompt : String
prompt = "calc> "

welcome : String
welcome = "A simple arithmetic calculator. Use " ++ quit ++ " or ^D to quit."

farewell : String
farewell = "Goodbye."

implementation Layout (List Lexeme) where
  lineLengths xs = map (toIntNat . Prelude.Strings.length) . lines $ show xs

lex : String -> Either String (List Lexeme)
lex i = let Id r = execParserT L.lexer i in
  case r of
    Success "" lexemes => Right lexemes
    Success left _     => Left $ "Unexpected EOS while lexing: " ++ (show left)
    Failure es         => Left $ formatError i es

parse : List Lexeme -> Either String Expression
parse i = let Id r = execParserT P.toplevel i in
  case r of
    Success [] expr    => Right expr
    Success lexemes _  => Left ("Unexpected EOS while parsing: " ++ (show lexemes))
    Failure es         => Left $ formatError i es

evaluate : String -> Either String Integer
evaluate s = do
  lexemes <- lex s
  expression <- parse lexemes
  return (eval expression)

repl : IO ()
repl = do
  putStr prompt
  line <- getLine
  isEof <- fEOF stdin
  when (isEof) $ putStrLn ""
  when (isEof == False && line /= quit) (do
    when (line /= "") (
      case evaluate line of
        Left err => putStrLn $ "Error: " ++ err
        Right n  => putStrLn $ show n
      )
    repl
  )

main : IO ()
main = do
  putStrLn welcome
  repl
  putStrLn farewell


module LightClick.Env

import Data.List
import Data.Vect

import Toolkit.Data.DList
import Toolkit.Data.DVect
import Toolkit.Data.DList.DeBruijn
import Toolkit.Data.Location
import Toolkit.Data.Rig
import Toolkit.Decidable.Equality.Indexed

import Language.SystemVerilog.Utilities

import LightClick.Connection
import LightClick.Error

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

import LightClick.Values

%default total

namespace TheType

   public export
   data TheType : (String, MTy) -> Type where
     MkTheType : (s : String) -> Ty ty -> TheType (s,ty)

   public export
   Equals : {a,b : Pair String MTy}
         -> (x : TheType a)
         -> (y : TheType b)
              -> Type
   Equals = Equals (String,MTy) TheType

   typesDiffer : (Types.Equality.Equals tyA tyB -> Void)
              -> TheType.Equals (MkTheType l tyA) (MkTheType l tyB)
              -> Void
   typesDiffer contra (Same Refl Refl) = contra (Same Refl Refl)

   decEq : (x : TheType a)
        -> (y : TheType b)
        -> (prf : a = b)
        -> Dec (Equals x y)
   decEq (MkTheType l tyA) (MkTheType l tyB) Refl with (decEq tyA tyB Refl)
     decEq (MkTheType l tyA) (MkTheType l tyA) Refl | Yes (Same Refl Refl) = Yes (Same Refl Refl)
     decEq (MkTheType l tyA) (MkTheType l tyB) Refl | No contra = No (typesDiffer contra)

   export
   DecEqIdx (String, MTy) TheType where
     decEq = TheType.decEq

public export
data Entry : Pair String MTy -> Type where
  MkEntry : (value : Value (interp ty))
         -> (type  : TheType (s,ty))
                 -> Entry (s,ty)

public export
Env : Context -> Type
Env = DeBruijn.Env (Pair String MTy) Entry

export
free : Env context -> List (Pair String (List String))
free [] = Nil
free ((MkEntry value (MkTheType name type)) :: rest) with (free type)
  free ((MkEntry value (MkTheType name type)) :: rest) | []
    = free rest
  free ((MkEntry value (MkTheType name type)) :: rest) | (x :: xs)
    = (name,x::xs) :: free rest

-- [ EOF ]