module Typedefs.Test.ReasonMLTests

import Typedefs.Names
import Typedefs.Typedefs
import Typedefs.Backend
import Typedefs.Backend.Utils
import Typedefs.Backend.ReasonML

import Typedefs.Test

import Text.PrettyPrint.WL
import Specdris.Spec

import Data.NEList
import Data.Vect

%access public export

x0 : Doc
x0 = text "'x0"

x1 : Doc
x1 = text "'x1"

x2 : Doc
x2 = text "'x2"

x3 : Doc
x3 = text "'x3"

eitherDoc : Doc
eitherDoc = text "type" |++| text "either" |+| tupled [x0,x1]
            |++| equals |++| text "Left" |+| parens x0 |++| pipe |++| text "Right" |+| parens x1 |+| semi

generate : TNamed n -> Maybe Doc
generate {n} tn = generateDefs ReasonML $ singleton (n ** tn)

testSuite : IO ()
testSuite = spec $ do

  describe "ReasonML code generation tests:" $ do
    let bitDoc = vsep2
                  [ preamble {def = ReasonML}
                  , eitherDoc
                  , text "type" |++| text "bit"
                    |++| equals |++| text "either" |+| tupled (replicate 2 (text "unit")) |+| semi
                  ]

    it "bit" $
      generate bit `shouldBe` (Just bitDoc)

    it "byte" $
      generate byte
        `shouldBe` (Just $ vsep2
                      [ bitDoc
                      , text "type" |++| text "byte"
                        |++| equals |++| tupled (replicate 8 (text "bit"))
                        |+| semi
                      ])

    let maybeDoc = vsep2
                     [ eitherDoc
                     , text "type" |++| text "maybe" |+| parens x0
                       |++| equals |++| text "either" |+| tupled [text "unit", x0]
                       |+| semi
                     ]

    it "maybe" $
      generate maybe `shouldBe` (Just $ vsep2 [preamble {def = ReasonML}, maybeDoc])

    let listDoc = text "type" |++| text "list" |+| parens x0
                  |++| equals |++| text "Nil"
                  |++| pipe   |++| text "Cons" |+| tupled [x0, text "list" |+| parens x0]
                  |+| semi

    it "list" $
      generate list `shouldBe` (Just $ vsep2 [preamble {def = ReasonML}, listDoc])

    let muMaybeDoc = text "type" |++| text "maybe2" |+| parens x0
                     |++| equals |++| text "Nothing"
                     |++| pipe   |++| text "Just" |+| parens x0
                     |+| semi

    it "maybe2" $
      generate maybe2 `shouldBe` (Just $ vsep2 [preamble {def = ReasonML}, muMaybeDoc])

    let natDoc = text "type" |++| text "nat"
                 |++| equals |++| text "Z"
                 |++| pipe   |++| text "S" |+| parens (text "nat")
                 |+| semi

    it "nat" $
      generate nat `shouldBe` (Just $ vsep2 [preamble {def = ReasonML}, natDoc])

    it "listNat" $
      generate listNat
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , natDoc
                      , text "type" |++| text "listNat"
                        |++| equals |++| text "NilN"
                        |++| pipe   |++| text "ConsN" |+| tupled [ text "nat", text "listNat" ]
                        |+| semi
                      ])

    it "parametricSynonym" $
      generate parametricSynonym
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , maybeDoc
                      , text "type" |++| text "parSyn" |+| parens x0
                        |++| equals |++| text "maybe" |+| parens x0
                        |+| semi
                      ])

    it "parametricSynonym2" $
      generate parametricSynonym2
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , muMaybeDoc
                      , text "type" |++| text "parSyn2" |+| parens x0
                        |++| equals |++| text "maybe2" |+| parens x0
                        |+| semi
                      ])

    it "aplusbpluscplusd" $
      generate aplusbpluscplusd
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , eitherDoc
                      , text "type" |++| text "aplusbpluscplusd" |+| tupled [x0,x1,x2,x3]
                        |++| equals |++| text "either" |+| tupled [x0,
                                            text "either" |+| tupled [x1,
                                              text "either" |+| tupled [x2, x3]]]
                        |+| semi
                      ])

    it "oneoneoneone" $
      generate oneoneoneone
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , eitherDoc
                      , text "type" |++| text "oneoneoneone"
                        |++| equals |++| text "either" |+| tupled [text "unit",
                                            text "either" |+| tupled [text "unit",
                                              text "either" |+| tupled [text "unit", text "unit"]]]
                        |+| semi
                      ])

    it "unusedFreeVars" $
      generate unusedFreeVars
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , text "type" |++| text "id" |+| parens x0
                        |++| equals |++| x0
                        |+| semi
                      ]) -- not "\ntype id('x0, 'x1, ..., 'x41) = 'x0\n"

    it "void or unit" $
      generate voidOrUnit
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , eitherDoc
                      , text "type" |++| text "void" |+| semi
                      , text "type" |++| text "voidOrUnit"
                        |++| equals |++| text "either" |+| tupled [text "void", text "unit"]
                        |+| semi
                      ])

    it "nonlinear variable usage" $
      generate nonlinear
        `shouldBe` (Just $ vsep2
                     [ preamble {def = ReasonML}
                     , text "type" |++| text "nonlinear" |+| parens x0
                       |++| equals |++| tupled [x0, x0]
                       |+| semi
                     ])

    it "nested Mu 1: List(Either(Alpha, Beta))" $
      generate nestedMu1
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , listDoc
                      , eitherDoc
                      , text "type" |++| text "nestedMu1" |+| tupled [x0,x1]
                        |++| equals |++| text "Foobar"
                                         |+| parens (text "list" |+| parens (text "either" |+| tupled [x0,x1]))
                        |+| semi
                      ])

    it "nested Mu 2: Maybe2(Alpha)" $
      generate nestedMu2
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , muMaybeDoc
                      , text "type" |++| text "nestedMu2" |+| parens x0
                        |++| equals |++| text "Foobar"
                                         |+| parens (text "maybe2" |+| parens x0)
                        |+| semi
                      ])

    it "nested Mu 3: Maybe2(Mu)" $
      generate nestedMu3
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}, muMaybeDoc
                      , text "type" |++| text "nestedMu3"
                        |++| equals |++| text "Foobar"
                                         |+| parens (text "maybe2" |+| parens (text "nestedMu3"))
                        |+| semi
                      ])

    let nestedMu4Doc =
      vsep2
        [ listDoc
        , eitherDoc
        , text "type" |++| text "nestedMu4" |+| parens x0
          |++| equals |++| text "Foobar"
                           |+| parens (text "list"
                                |+| parens (text "either"
                                     |+| tupled [ text "nestedMu4" |+| parens x0
                                                , x0 ]))
          |+| semi
        ]

    it "nested Mu 4: List(Either (Mu, Alpha))" $
      generate nestedMu4 `shouldBe` (Just $ vsep2 [preamble {def = ReasonML}, nestedMu4Doc])

    it "Nested mu 5: AnonList(Mu)" $
      generate nestedMu5
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}, text "type" |++| text "nilCons" |+| parens x0
                        |++| equals |++| text "Nil"
                        |++| pipe   |++| text "Cons"
                                         |+| tupled [ x0
                                                    , text "nilCons" |+| parens x0 ]
                        |+| semi
                      , text "type" |++| text "nestedMu5"
                        |++| equals |++| text "Foobar"
                                         |+| parens (text "nilCons" |+| parens (text "nestedMu5"))
                        |+| semi
                      ])

    it "nested Mu 6: NestedMu4(Maybe2(Either(Alpha, Nat)))" $
      generate nestedMu6
        `shouldBe` (Just $ vsep2
                      [ preamble {def = ReasonML}
                      , nestedMu4Doc
                      , muMaybeDoc
                      , natDoc
                      , text "type" |++| text "nestedMu6" |+| parens x0
                        |++| equals |++| text "Foobar"
                                         |+| parens (text "nestedMu4"
                                             |+| parens (text "maybe2"
                                                 |+| parens (text "either"
                                                     |+| tupled [ x0
                                                                , text "nat" ])))
                        |+| semi
                      ])

    it "list of definitions [bit, nibble, byte, char, hash, transitionId, data, previous, rootTx]" $
      generateDefs ReasonML listOfDefs
        `shouldBe` (Just $ vsep2
                      [ bitDoc
                      , text "type" |++| text "nibble"
                        |++| equals |++| tupled (replicate 4 (text "bit"))
                        |+| semi
                      , text "type" |++| text "byte"
                        |++| equals |++| tupled (replicate 2 (text "nibble"))
                        |+| semi
                      , text "type" |++| text "char"
                        |++| equals |++| text "byte"
                        |+| semi
                      , text "type" |++| text "hash"
                        |++| equals |++| text "byte"
                        |+| semi
                      , text "type" |++| text "transitionId"
                        |++| equals |++| text "byte"
                        |+| semi
                      , text "type" |++| text "data"
                        |++| equals |++| text "byte"
                        |+| semi
                      , text "type" |++| text "previous"
                        |++| equals |++| text "hash"
                        |+| semi
                      , text "type" |++| text "rootTx"
                        |++| equals |++| tupled [text "data", text "previous"]
                        |+| semi
                      ])


module Backprop

import public Backprop.CanBack
import public Backprop.Math
import public Backprop.Node
import public Data.List.Quantifiers


module Data.Either

import Data.List1

%default total

--------------------------------------------------------------------------------
-- Checking for a specific constructor

||| Extract the Left value, if possible
public export
getLeft : Either a b -> Maybe a
getLeft (Left a) = Just a
getLeft _ = Nothing

||| Extract the Right value, if possible
public export
getRight : Either a b -> Maybe b
getRight (Right b) = Just b
getRight _ = Nothing

||| True if the argument is Left, False otherwise
public export
isLeft : Either a b -> Bool
isLeft (Left _)  = True
isLeft (Right _) = False

||| True if the argument is Right, False otherwise
public export
isRight : Either a b -> Bool
isRight (Left _)  = False
isRight (Right _) = True

--------------------------------------------------------------------------------
-- Grouping values

||| Compress the list of Lefts and Rights by accumulating
||| all of the lefts and rights into non-empty blocks.
export
compress : List (Either a b) -> List (Either (List1 a) (List1 b))
compress [] = []
compress (Left x :: abs) = compressLefts (singleton x) abs where
  compressLefts : List1 a -> List (Either a b) -> List (Either (List1 a) (List1 b))
  compressLefts acc (Left a :: abs) = compressLefts (cons a acc) abs
  compressLefts acc abs = Left (reverse acc) :: compress abs
compress (Right y :: abs) = compressRights (singleton y) abs where
  compressRights : List1 b -> List (Either a b) -> List (Either (List1 a) (List1 b))
  compressRights acc (Right b :: abs) = compressRights (cons b acc) abs
  compressRights acc abs = Right (reverse acc) :: compress abs

||| Decompress a compressed list. This is the left inverse of `compress` but not its
||| right inverse because nothing forces the input to be maximally compressed!
export
decompress : List (Either (List1 a) (List1 b)) -> List (Either a b)
decompress = concatMap $ \case
  Left  as => map Left  $ forget as
  Right bs => map Right $ forget bs

||| Keep the payloads of all Left constructors in a list of Eithers
public export
lefts : List (Either a b) -> List a
lefts []              = []
lefts (Left  l :: xs) = l :: lefts xs
lefts (Right _ :: xs) = lefts xs

||| Keep the payloads of all Right constructors in a list of Eithers
public export
rights : List (Either a b) -> List b
rights []              = []
rights (Left  _ :: xs) = rights xs
rights (Right r :: xs) = r :: rights xs

||| Split a list of Eithers into a list of the left elements and a list of the right elements
public export
partitionEithers : List (Either a b) -> (List a, List b)
partitionEithers l = (lefts l, rights l)

||| Remove a "useless" Either by collapsing the case distinction
public export
fromEither : Either a a -> a
fromEither (Left l)  = l
fromEither (Right r) = r

||| Right becomes left and left becomes right
public export
mirror : Either a b -> Either b a
mirror (Left  x) = Right x
mirror (Right x) = Left x

--------------------------------------------------------------------------------
-- Bifunctor

export
pushInto : c -> Either a b -> Either (c, a) (c, b)
pushInto c = bimap (\ a => (c, a)) (\ b => (c, b))
  -- ^ not using sections to keep it backwards compatible

--------------------------------------------------------------------------------
-- Conversions
--------------------------------------------------------------------------------

||| Convert a Maybe to an Either by using a default value in case of Nothing
||| @ e the default value
public export
maybeToEither : (def : Lazy e) -> Maybe a -> Either e a
maybeToEither def (Just j) = Right j
maybeToEither def Nothing  = Left  def

||| Convert an Either to a Maybe from Right injection
public export
eitherToMaybe : Either e a -> Maybe a
eitherToMaybe (Left _) = Nothing
eitherToMaybe (Right x) = Just x

-- Injectivity of constructors

||| Left is injective
export
leftInjective : Left x = Left y -> x = y
leftInjective Refl = Refl

||| Right is injective
export
rightInjective : Right x = Right y -> x = y
rightInjective Refl = Refl


import Data.Vect

%default total

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

letters : String -> List Char
letters = nub . map toUpper . unpack

data GuessResult = Correct | Incorrect

data GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
    NewGame : (word : String) ->
              GameCmd () NotRunning (const (Running 6 (length (letters word))))
    Won : GameCmd () (Running (S guesses) 0) (const NotRunning)
    Lost : GameCmd () (Running 0 (S guesses)) (const NotRunning)

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

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

    Pure : (res : ty) -> GameCmd ty (stateFn res) stateFn
    (>>=) : GameCmd a state1 state2Fn ->
            ((res : a) -> GameCmd b (state2Fn res) state3Fn) ->
            GameCmd b state1 state3Fn

namespace Loop
    data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
        (>>=) : GameCmd a state1 state2Fn ->
                ((res : a) -> Inf (GameLoop b (state2Fn res) state3Fn)) ->
                GameLoop b state1 state3Fn
        Exit : GameLoop () NotRunning (const NotRunning)

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

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

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

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

data Fuel = Dry | More (Lazy Fuel)

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

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

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

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

%default partial

forever : Fuel
forever = More forever

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


module DepSec.File

import public DepSec.DIO
import public DepSec.Labeled

%access export

||| Secure file
data SecFile : {label : Type} -> (l : label) -> Type where
  ||| TCB
  MkSecFile : (path : String) -> SecFile l

||| Make a secure file from string
||| TCB
||| @ path path to file
makeFile : (path : String) -> SecFile l
makeFile = MkSecFile

||| Read a secure file
||| @ flow evidence that l may flow to l'
||| @ file secure file to read
readFile : Poset labelType
        => {l,l' : labelType}
        -> {auto flow : l `leq` l'}
        -> (file : SecFile l')
        -> DIO l (Labeled l' (Either FileError String))
readFile (MkSecFile path) = lift $ map MkLabeled $ readFile path

||| Write to a secure file
||| @ file secure file to write to
||| @ flow evidence that l may flow to l'
||| @ flow' evidence that l' may flow to l''
||| @ content labeled content to write
writeFile : Poset labelType
         => {l,l',l'' : labelType}
         -> {auto flow : l `leq` l'}
         -> (file : SecFile l'')
         -> {auto flow' : l' `leq` l''}
         -> (content : Labeled l' String)
         -> DIO l (Labeled l'' (Either FileError ()))
writeFile (MkSecFile path) (MkLabeled content)
  = lift $ map MkLabeled $ writeFile path content


module Data.String.Extra

%access public export

parseInteger : List Char -> Integer -> Maybe Integer
parseInteger []        acc = Just acc
parseInteger (c :: cs) acc =
  if (c >= '0' && c <= '9')
  then parseInteger cs ((acc * 10) + (cast ((ord c) - (ord '0'))))
  else Nothing


module Core.ConSig

import General

import Debug.Error

import Core.Variable

%language ElabReflection

--  oYYo _YYY_ 8o  0 oYYYo Y8Y  oYYo
-- 0   " 0   0 8Yo 8 %___   0  0  __
-- 0   , 0   0 8 Yo8 `"""p  0  0  "8
--  YooY "ooo" 0   8 YoooY o8o  YooY

public export
data ConSig a = ConSigNil a | ConSigCons Plict a (Scope a (ConSig a))

partial export
showConSig : Show a => (String -> a) -> ConSig a -> String
showConSig _ (ConSigNil a) = show a
showConSig f (ConSigCons plic a sc) with (length (names sc) == 1)
	| True = do
		let a0' = unwords (names sc) ++ " : " ++ show a
		let a' = case plic of
			Expl => "(" ++ a0' ++ ") "
			Impl => "{" ++ a0' ++ "} "
		a' ++ showConSig f (instantiate sc (map f (names sc)))
showConSig _ _ = error "ConSigs should have exactly one scope argument."

export
conSigLength : (String -> a) -> ConSig a -> Int
conSigLength _ (ConSigNil _) = 0
conSigLength f (ConSigCons _ _ sc) = 1 + conSigLength f (instantiate sc (map f (names sc)))

public export
Signature : Type -> Type
Signature a = SortedMap FullName (ConSig a)


-- Copyright (c) 2013 Radek Micek

module Common

infixr 1 ??, >=>

(??) : a -> (a -> b) -> b
a ?? f = f a

(>=>) : Monad m => (a -> m b) -> (b -> m c) -> a -> m c
f >=> g = \a => f a >>= g

filterM : Monad m => (a -> m Bool) -> List a -> m (List a)
filterM _ [] = return List.Nil
filterM p (x :: xs) = do
  b <- p x
  ys <- filterM p xs
  return (b ? List.(::) x ys : ys)

mapTupleM : Monad m => (a -> m b) -> (a, a) -> m (b, b)
mapTupleM f (x, y) = do
  x' <- f x
  y' <- f y
  return (x', y')

mapM_ : Monad m => (a -> m b) -> List a -> m ()
mapM_ f = sequence_ . map f

boolToInt : Bool -> Int
boolToInt b = b ? 1 : 0


-- Exercise_5_2.idr

-- Implement a guessing game fro numbers

module Main

import System
import ReadNum

||| Guessing game: Interactive dialogs to guess a given number.
||| @target the number to be guessed
||| @guesses the number of trials
guess : (target : Nat) -> (guesses : Nat) -> IO ()
guess target guesses =
  do putStr ("Guess my number " ++ "(" ++ (show guesses) ++ " trial): ")
     Just trial <- readNumber | Nothing => (putStrLn "Invalid input! Try again.." >>= \_ =>
                                          guess target guesses)
     case compare trial target of
          EQ => putStrLn "Correct!"
          LT => putStrLn "Too small, try again.." >>= \_ => guess target (S guesses)
          GT => putStrLn "Too large, try again.." >>= \_ => guess target (S guesses)

||| Mimic replWith function from Prelude module
myReplWith : (state : a) -> (prompt : String) -> (onInput : a -> String -> Maybe (String, a)) -> IO ()
myReplWith state prompt onInput = do
  putStr prompt
  input <- getLine
  let Just (output, newState) = onInput state input | Nothing => pure ()
  putStr output
  myReplWith newState prompt onInput

||| Mimic repl function from Prelude module
myRepl : (prompt : String) -> (onInput : String -> String) -> IO ()
myRepl prompt onInput = myReplWith () prompt (\(), input => Just (onInput input, ()))

main : IO ()
main = do
  tsecs <- time
  let target = tsecs `mod` 100
  guess (cast target) 1


-- ------------------------------------------------------------- [ Char.idr ]
-- Module      : Lightyear.Char
-- Description : Character-related parsers.
--
-- This code is distributed under the BSD 2-clause license.
-- See the file LICENSE in the root directory for its full text.
--
-- This code is (mostly) a port of Daan Leijen's Text.Parsec.Char library.
-- --------------------------------------------------------------------- [ EOH ]
module Lightyear.Char

import        Data.Strings
import public Data.Vect
import public Data.Fin

import public Control.Monad.Identity

import Lightyear.Core
import Lightyear.Combinators

-- Maybe somehow return proof that returned Char is the one passed as arg?
-- `char a <|> char b` should return `Either (c = a) (c = b)`
-- char : (Monad m, Stream Char str) => (c : Char) -> Covers (Subset Char (Equal c)) t => ParserT str m t
||| A parser that matches some particular character
export
char : (Monad m, Stream Char str) => Char -> ParserT str m Char
char c = satisfy (== c) <?> "character '" ++ singleton c ++ "'"

||| oneOf cs succeeds if the current character is in the supplied
||| list of characters @cs@. Returns the parsed character. See also
||| 'satisfy'.
|||
|||   vowel  = oneOf "aeiou"
export
oneOf : (Monad m, Stream Char str) => String -> ParserT str m Char
oneOf cs = satisfy (\c => elem c $ unpack cs)

||| As the dual of 'oneOf', @noneOf cs@ succeeds if the current
||| character /not/ in the supplied list of characters @cs@. Returns the
||| parsed character.
|||
|||  consonant = noneOf "aeiou"
export
noneOf :  (Monad m, Stream Char str) => String -> ParserT str m Char
noneOf cs = satisfy (\c => not $ elem c $ unpack cs)

||| Parses a white space character (any character which satisfies 'isSpace')
||| Returns the parsed character.
export
space : (Monad m, Stream Char s) => ParserT s m Char
space = satisfy isSpace <?> "space"

||| Skips /zero/ or more white space characters. See also 'skipMany'.
export
spaces : (Monad m, Stream Char s) => ParserT s m ()
spaces = skip (many Lightyear.Char.space)  <?> "white space"

||| Parses a newline character (\'\\n\'). Returns a newline character.
export
newline : (Monad m, Stream Char s) => ParserT s m Char
newline = char '\n' <?> "lf new-line"

||| Parses a carriage return character (\'\\r\') followed by a newline character (\'\\n\').
||| Returns a newline character.
export
crlf : (Monad m, Stream Char s) => ParserT s m Char
crlf = char '\r' *> char '\n' <?> "crlf new-line"

||| Parses a CRLF (see 'crlf') or LF (see 'newline') end-of-line.
||| Returns a newline character (\'\\n\').
|||
||| endOfLine = newline <|> crlf
export
endOfLine : (Monad m, Stream Char s) => ParserT s m Char
endOfLine           = newline <|> crlf       <?> "new-line"

||| Parses a tab character (\'\\t\'). Returns a tab character.
export
tab : (Monad m, Stream Char s) => ParserT s m Char
tab = char '\t'             <?> "tab"

||| Parses an upper case letter (a character between \'A\' and \'Z\').
||| Returns the parsed character.
export
upper : (Monad m, Stream Char s) => ParserT s m Char
upper = satisfy isUpper       <?> "uppercase letter"

||| Parses a lower case character (a character between \'a\' and \'z\').
||| Returns the parsed character.
export
lower : (Monad m, Stream Char s) => ParserT s m Char
lower = satisfy isLower       <?> "lowercase letter"

||| Parses a letter or digit (a character between \'0\' and \'9\').
||| Returns the parsed character.
export
alphaNum : (Monad m, Stream Char s) => ParserT s m Char
alphaNum            = satisfy isAlphaNum    <?> "letter or digit"

||| Parses a letter (an upper case or lower case character). Returns the
||| parsed character.
export
letter : (Monad m, Stream Char s) => ParserT s m Char
letter              = satisfy isAlpha       <?> "letter"

||| Matches a single digit
export
digit : (Monad m, Stream Char s) => ParserT s m (Fin 10)
digit = satisfyMaybe fromChar
  where fromChar : Char -> Maybe (Fin 10)
        fromChar '0' = Just FZ
        fromChar '1' = Just (FS (FZ))
        fromChar '2' = Just (FS (FS (FZ)))
        fromChar '3' = Just (FS (FS (FS (FZ))))
        fromChar '4' = Just (FS (FS (FS (FS (FZ)))))
        fromChar '5' = Just (FS (FS (FS (FS (FS (FZ))))))
        fromChar '6' = Just (FS (FS (FS (FS (FS (FS (FZ)))))))
        fromChar '7' = Just (FS (FS (FS (FS (FS (FS (FS (FZ))))))))
        fromChar '8' = Just (FS (FS (FS (FS (FS (FS (FS (FS (FZ)))))))))
        fromChar '9' = Just (FS (FS (FS (FS (FS (FS (FS (FS (FS (FZ))))))))))
        fromChar _   = Nothing

||| Matches an integer literal
export
integer : (Num n, Monad m, Stream Char s) => ParserT s m n
integer = do minus <- opt (char '-')
             ds <- some digit
             let theInt = getInteger ds
             case minus of
               Nothing => pure (fromInteger theInt)
               Just _  => pure (fromInteger ((-1) * theInt))
  where getInteger : List (Fin 10) -> Integer
        getInteger = foldl (\a => \b => 10 * a + cast b) 0

||| Parses a hexadecimal digit (a digit or a letter between \'a\' and
||| \'f\' or \'A\' and \'F\'). Returns the parsed character.
export
hexDigit : (Monad m, Stream Char s) => ParserT s m Char
hexDigit = satisfy isHexDigit <?> "hexadecimal digit"

||| Parses an octal digit (a character between \'0\' and \'7\'). Returns
||| the parsed character.
export
octDigit : (Monad m, Stream Char s) => ParserT s m Char
octDigit = satisfy isOctDigit <?> "octal digit"

||| This parser succeeds for any character. Returns the parsed character.
export
anyChar : (Monad m, Stream Char s) => ParserT s m Char
anyChar  = anyToken <?> "any character"


module Temp

import Data.List

safeHead : (l : List a) -> {auto pr : NonEmpty l} -> a
safeHead [] = absurd pr
safeHead (x::xs) = x

safeHead1 : (l : List a) -> {auto pr : NonEmpty l} -> a
safeHead1 @{pr} [] = absurd pr
safeHead1 (x::xs) = x

safeHead2 : (l : List a) -> {auto pr : NonEmpty l} -> a
safeHead2 @{t} [] = absurd t
safeHead2 (x::xs) = x


module Screen

import Data.Bits
import Data.Vect
import Effects
import Effect.SDL

import Constants
import Utilities

%default total

-- a bit represents a monochrome pixel
data Pixel = On | Off

Show Pixel where
  show On = "▓"
  show Off = "░"

xorOnePixel : (p1 : Pixel) -> (p2 : Pixel) -> Pixel
xorOnePixel On Off = On
xorOnePixel Off On = On
xorOnePixel _ _ = Off

-- track if any pixel was erased (so we can set VF in the CPU)
pixelWasErased : (p1 : Pixel) -> (p2 : Pixel) -> Bool
pixelWasErased On Off = True
pixelWasErased _ _ = False

-- for convenience
ScreenWidth : Nat
ScreenWidth = 64

ScreenHeight : Nat
ScreenHeight = 32

-- 64x32 monochrome pixel display
export
record Screen where
  constructor MkScreen
  Picture : Vect ScreenHeight (Vect ScreenWidth Pixel)
  WasErased : Bool -- track for VF

data Coord = MkCoord Int Int Pixel

export
wasErased : (screen : Screen) -> Bool
wasErased = WasErased

export
renderScreen : (screen : Screen) -> { [SDL_ON] } Eff ()
renderScreen screen =
  let (coords, _) = foldl pixelCoordsForRow ([], 0) (Picture screen) in
  do
    mapE renderPixel coords
    pure ()
  where
    pixelCoords : (accum : (List Coord, (Int, Int))) -> (pixel : Pixel) -> (List Coord, (Int, Int))
    pixelCoords (rects, (x, y)) pixel =
      MkPair (MkCoord x y pixel :: rects) (x + 1, y)
    pixelCoordsForRow : (accum : (List Coord, Int)) -> Vect ScreenWidth Pixel -> (List Coord, Int)
    pixelCoordsForRow (coords, y) row =
      let (newCoords, _) = foldl pixelCoords ([], (MkPair 0 y)) row in
      MkPair (coords ++ newCoords) (y + 1)
    renderPixel : Coord -> EffM m () [SDL_ON] (\_ => [SDL_ON])
    renderPixel (MkCoord x y pixel) =
      let color = case pixel of On => white; Off => black in
      rectangle color (x * Scale) (y * Scale) Scale Scale

export
Show Screen where
  show s = foldl drawRow "" (Picture s)
  where
    concatenate : (accum : String) -> (p : Pixel) -> String
    concatenate accum val = accum ++ show val
    drawRow : (accum : String) -> (row : Vect ScreenWidth Pixel) -> String
    drawRow accum row = accum ++ (foldl concatenate "" row) ++ "\n"

export
newScreen : Screen
newScreen =
  let picture = Vect.replicate ScreenHeight $ Vect.replicate ScreenWidth Off in
  MkScreen picture False

readPixelFromPicture : (s : Screen) -> (x : Fin ScreenWidth) -> (y : Fin ScreenHeight) -> Pixel
readPixelFromPicture s x y =
  let picture = Picture s in
  let row = Vect.index y picture in
  Vect.index x row

writePixelToPicture : (s : Screen) -> (p : Pixel) -> (x : Fin ScreenWidth) -> (y : Fin ScreenHeight) -> Screen
writePixelToPicture s p x y =
  let picture = Picture s in
  let row = Vect.index y picture in
  let newRow = replaceAt x p row in
  let newPicture = replaceAt y newRow picture in
  record { Picture = newPicture } s

writePixelToScreen : (s : Screen) -> (p : Pixel) -> (x : Int) -> (y : Int) -> Screen
writePixelToScreen s p x y =
  let realX = restrict (pred ScreenWidth) $ cast x in
  let realY = restrict (pred ScreenHeight) $ cast y in
  let pixel = readPixelFromPicture s realX realY in
  let newPixel = xorOnePixel pixel p in
  let newScreen = writePixelToPicture s newPixel realX realY in
  let wasErased = pixelWasErased pixel p || WasErased s in
  record { WasErased = wasErased } newScreen

explodeByte : (val : Bits8) -> Vect 8 Pixel
explodeByte val =
  let bits : Bits 8 = cast val in
  let booleans = map (flip getBit bits) [7, 6, 5, 4, 3, 2, 1, 0] in
  map convertPixel booleans
  where
    convertPixel : Bool -> Pixel
    convertPixel True = On
    convertPixel False = Off

writeSpriteLineToScreen : (screen : Screen) -> (val : Bits8) -> (x : Int) -> (y : Int) -> Screen
writeSpriteLineToScreen screen val x y =
  let pixels = explodeByte val in
  fst $ foldl (drawPixel y) (MkPair screen x) pixels
  where
    drawPixel : (y : Int) -> (accum : (Screen, Int)) -> (pixel : Pixel) -> (Screen, Int)
    drawPixel y (screen, x) p =
      let drawnScreen = writePixelToScreen screen p x y in
      let wasErased = wasErased screen || wasErased drawnScreen in
      let newScreen = record { WasErased = wasErased } drawnScreen in
      MkPair newScreen (x + 1)

export
writeSpriteToScreen : (screen : Screen) -> (sprite : Vect len Bits8) -> (x : Int) -> (y : Int) -> Screen
writeSpriteToScreen screen sprite x y =
  let resetScreen = record { WasErased = False } screen in
    fst $ foldl (drawLine x) (MkPair resetScreen y) sprite
  where
    drawLine : (x : Int) -> (accum : (Screen, Int)) -> (val : Bits8) -> (Screen, Int)
    drawLine x (screen, y) val =
      let drawnScreen = writeSpriteLineToScreen screen val x y in
      let wasErased = wasErased screen || wasErased drawnScreen in
      let newScreen = record { WasErased = wasErased } drawnScreen in
      MkPair newScreen (y + 1)

export
defaultSpriteStartingAddress : Fin 16 -> Bits16
defaultSpriteStartingAddress x =
  let spriteOffset = cast $ finToNat x in
  let offsetAddress = DefaultSpriteDataLength * spriteOffset in
  cast $ DefaultSpriteDataAddress + offsetAddress

-- 16 8x5 sprites for hexadecimal values
export
defaultSpriteData : List Bits8
defaultSpriteData = [
    0xf0, 0x90, 0x90, 0x90, 0xf0,
    0x20, 0x60, 0x20, 0x20, 0x70,
    0xf0, 0x10, 0xf0, 0x80, 0xf0,
    0xf0, 0x10, 0xf0, 0x10, 0xf0,
    0x90, 0x90, 0xf0, 0x10, 0x10,
    0xf0, 0x80, 0xf0, 0x10, 0xf0,
    0xf0, 0x80, 0xf0, 0x90, 0xf0,
    0xf0, 0x10, 0x20, 0x40, 0x40,
    0xf0, 0x90, 0xf0, 0x90, 0xf0,
    0xf0, 0x90, 0xf0, 0x10, 0xf0,
    0xf0, 0x90, 0xf0, 0x90, 0x90,
    0xe0, 0x90, 0xe0, 0x90, 0xe0,
    0xf0, 0x80, 0x80, 0x80, 0xf0,
    0xe0, 0x90, 0x90, 0x90, 0xe0,
    0xf0, 0x80, 0xf0, 0x80, 0xf0,
    0xf0, 0x80, 0xf0, 0x80, 0x80
  ]


{-
  An embeded DSL for prolog-style logic programming, based on the
  pure-prolog parser and interpreter originally written in Haskell

  Original author: Ken Friis Larsen      <kflarsen@diku.dk>
  Translated into Idris by Nathan Bedell <nbedell@tulane.edu>
-}

import Interp
import Ast
import Data.List

%default partial

public export
p : Term
p = Comp "p" []

public export
q : Term
q = Comp "q" []

public export
x : Term
x = Comp "x" []

public export
z : Term
z = Comp "z" []

public export
r : Term -> Term
r x = Comp "r" [x]

public export
n : Term -> Term
n x = Comp "n" [x]

public export
X : Term
X = Var "X"

public export
s : Term -> Term
s x = Comp "s" [x]

public export
f : Term -> Term -> Term
f x y = Comp "f" [x, y]

public export
%hint
program : Program
program = unDSL
  [ p
    , q :- [p]
    , (n z)
    , (n (s X)) :- [n X]
    , (f z z)
    , (f z (s z))
    , (f X X)
  ]

public export
result : List Solution
result = nub $ bfs $ makeReportTree program [f z X]

-- Note: I should make this more type-safe.
public export
getSolutions : List Solution -> List Term
getSolutions xs = concat $ map getSolution xs
  where getSolution : Solution -> List Term
        getSolution (MkSolution x) = map snd x

public export
f_val : Term -> List Term
f_val x = getSolutions $ nub $ bfs $ makeReportTree program [f x X]

public export
nat : Term -> Bool
nat t = query /= []
  where query : List Solution
        query = ?- n t

-- This is a version of f_val that runs on our embedded prolog
-- system, but only allows values of type Nat.
public export
f_val' : (x : Term) -> {auto p : True = nat x} -> List Term
f_val' x = getSolutions $ ?- f x X

-- An example. The following (should) compile.
-- However, the compiler doesn't like when I try to assert this total. It does strange things.
-- val : List Term
-- val = f_val' z

-- The following does not compile.
-- val' : List Term
-- val' = f_val' (s z)


||| Test if :typeat correctly shows types within !(...)

n : List a -> List a
n xs = pure !xs

f : (a -> List b) -> a -> (b -> List c) -> List c
f g a j = j !(g a)


even'' : Nat -> Bool
even'' Z = True
even'' (S k) = ?even_rhs

-- :t even_rhs
-- k : Nat
--------------
-- even_rhs : Bool

main : IO ()
main = putStrLn ?greeting

-- :l hole
-- :t greeting
--------------
-- greeting : String


module Main

import Data.Strings

%default total

-- the definitions are in calc.scm, run the program as:
-- $ idris2 -o Chez --directive extranRuntime=calc.scm ChezGenerator.idr

%foreign "scheme:my-add"
myAdd : Int -> Int -> Int

%foreign "scheme:my-sub"
mySub : Int -> Int -> Int

%foreign "scheme:my-mul"
myMul : Int -> Int -> Int

%foreign "scheme:my-div"
myDiv : Int -> Int -> Int

readNum : HasIO io => io (Maybe Int)
readNum = do input <- getLine
             case all isDigit (unpack input) of
                  False => pure Nothing
                  True => pure $ Just (cast input)

main : HasIO io => io ()
main = do Just x <- readNum
            | Nothing => do putStrLn "First number is invalid"
          Just y <- readNum
            | Nothing => do putStrLn "Second number is invalid"
          putStrLn $ "Sum = " ++ show (myAdd x y) ++ ", diff = " ++ show (mySub x y) ++
                            ", prod = " ++ show (myMul x y) ++ ", quot = " ++ show (myDiv x y)


module Rnd

import Effects

data Random : Effect where
     getRandom : Random Int Int (\v => Int)

using (m : Type -> Type)
  instance Handler Random m where
     handle seed getRandom k
              = let seed' = (1664525 * seed + 1013904223) `prim__sremInt` (pow 2 32) in
                    k seed' seed'

RND : EFFECT
RND = MkEff Int Random

rndInt : Int -> Int -> { [RND] } Eff m Int
rndInt lower upper = do v <- getRandom
                        return (abs (v `prim__sremInt` (upper - lower)) + lower)


import Data.Vect

||| Test if the type of local variables is correctly reported

-- Not meant to be called, just typechecked
partial
f : Nat -> Int -> Bool -> () -> z
f a b c d =

    -- Let with pattern match
    let (S a') = a

        -- Let without signature
        b' = b

        -- Let with signature
        c' : Bool
        c' = c

        -- In the type signature of the Let
        v1 : Vect a Nat
        v1 = ?vect1

    -- After the `in`
    -- It's good to include them all to test that they work regardless
    -- of how they were bound
    in ?result a' b' c' d' v1 v2
  where
    -- Where
    d' : ()
    d' = d

    -- In the type signature of the Where
    v2 : Vect x Nat
    v2 = ?vect2


module Main

palindrome : String -> Bool
palindrome str = let strLower = toLower str in
                     strLower == reverse strLower

main : IO ()
main = repl "Enter a string: " show_palindrome
  where
    show_palindrome : String -> String
    show_palindrome x = show (palindrome x) ++ "\n"


module Deque

%default total
%access private

public export
interface Deque (q : Type -> Type) where
  empty : q a
  isEmpty : q a -> Bool

  cons : a -> q a -> q a
  head : q a -> a
  tail : q a -> q a

  snoc : q a -> a -> q a
  last : q a -> a
  init : q a -> q a


-- ------------------------------------------------------------ [ DeBruijn.idr ]
-- Module    : DeBruijn.idr
-- Copyright : (c) 2015,2016 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Data structure to compute de Bruijn indices.
|||
||| Thanks to christiansen's Galois tutorials for the accessor and
||| mutator functions for environments/object store.
module Toolkit.Data.List.DeBruijn

import public Decidable.Equality

import public Data.List.Elem

import public Toolkit.Data.DList

%default total

-- A reverse cons operator.
infixr 6 +=

namespace List

  ||| Proof that the given list (`xs`) contains the given element
  ||| (`x`).
  |||
  |||
  public export
  Contains : List a -> a -> Type
  Contains xs x = Elem x xs

  ||| Append `x` to the head of `xs`.
  public export
  (+=) : List a -> a -> List a
  (+=) xs x = x :: xs

||| A De Bruijn Index.
|||
||| @T    The type of type's collected.
||| @ctxt The collection of types.
||| @t    The element collected at the current position.
public export
Index : (type : Type)
     -> (ctxt : List type)
     -> (t    : type)
             -> Type
Index _ ctxt t = Elem t ctxt

||| Sometimes it is bettern to think that we have this thing called an
||| environment and not a `DList`.
|||
||| @t    The Type for Types in our environment.
||| @obj  How we interpret the types in our DSL. Either this is a
|||       dependent type or a function that computes a type.
||| @ctxt The typing context.
public export
Env : (t : Type) -> (obj : t -> Type) -> (ctxt : List t) -> Type
Env ty obj ctxt = DList ty obj ctxt

||| Add an object from our typing environment.
||| @env The typing environment.
export
extend : {t : ty}
      -> (env : Env ty e ctxt)
      -> (obj : e t)
      -> Env ty e (t::ctxt)
extend env obj = obj :: env

||| Read an object from our typing environment.
|||
||| @idx The typing context.
||| @env The typing environment.
export
read : (idx : Index ty ctxt t)
    -> (env : Env ty e ctxt)
    -> e t
read Here      (obj::store) = obj
read (There x) (obj::store) = read x store

||| Add an object to our typnig environment.
|||
||| @idx The typing context.
||| @obj The object to add.
||| @env The environment to which the object is added.
export
update : (idx : Index ty ctxt t )
      -> (obj : e t)
      -> (env : Env ty e ctxt)
      -> Env ty e ctxt
update Here      obj (_    :: store) = obj  :: store
update (There x) obj (obj' :: store) = obj' :: update x obj store

namespace KV

  public export
  indexEmpty : {k : String}
            -> (t ** Index (String, type) [] (k, t))
            -> Void
  indexEmpty (MkDPair fst snd) impossible

  public export
  notInIndex : (keyContra : (k = a) -> Void)
           -> (index     : List (String, type))
           -> (kvContra  : (t : type ** Index (String, type)            xs  (k, t)) -> Void)
           -> (prf       : (t : type ** Index (String, type) ((a, b) :: xs) (k, t)))
                        -> Void
  notInIndex keyContra index kvContra (MkDPair b Here) = keyContra Refl
  notInIndex keyContra index kvContra (MkDPair fst (There x)) = kvContra (_ ** x)

  public export
  isIndex : DecEq type
         => (k : String)
         -> (ctxt : List (String, type))
         -> Dec (t : type ** Index (String, type) ctxt (k,t))
  isIndex k [] = No indexEmpty
  isIndex k ((a,b) :: xs) with (decEq k a)
    isIndex a ((a,b) :: xs) | (Yes Refl) = Yes (b ** Here)
    isIndex k ((a,b) :: xs) | (No contra) with (isIndex k xs)
      isIndex k ((a,b) :: xs) | (No contra) | (Yes (MkDPair fst snd))
        = Yes (_ ** There snd)
      isIndex k ((a,b) :: xs) | (No contra) | (No f) = No (notInIndex contra xs f)

namespace Renaming

  public export
  weaken : (func : Contains old type
                -> Contains new type)
        -> (Contains (old += type') type
         -> Contains (new += type') type)

  weaken func Here = Here
  weaken func (There rest) = There (func rest)

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

    var : {ty   : type}
       -> {ctxt : List type}
               -> Elem ty ctxt
               -> term ctxt ty

    weakens : {old, new : List type}
           -> (f : {ty  : type}
                       -> Contains old ty
                       -> term     new ty)
           -> ({ty,type' : type}
                  -> Contains (old += type') ty
                  -> term     (new += type') ty)
    weakens f Here = var Here
    weakens f (There rest) = rename There (f rest)

namespace Substitution

  namespace General
    public export
    interface Rename type term
           => Substitute (type : Type) (term : List type -> type -> Type) | term where

      subst : {old, new : List type}
           -> (f : {ty  : type}
                       -> Contains old ty
                       -> term     new ty)
           -> ({ty : type}
                  -> term old ty
                  -> term new ty)

  namespace Single

    apply : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => {ctxt   : List type}
         -> {typeA  : type}
         -> {typeB  : type}
         -> (this   : term      ctxt    typeB)
         -> (idx    : Contains (ctxt += typeB) typeA)
                   -> term      ctxt           typeA
    apply this Here = this
    apply this (There rest) = var rest

    export
    subst : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => Substitute type term
         => {ctxt          : List type}
         -> {typeA         : type}
         -> {typeB         : type}
         -> (this          : term  ctxt           typeB)
         -> (inThis        : term (ctxt += typeB) typeA)
                          -> term  ctxt           typeA
    subst {ctxt} {typeA} {typeB} this inThis
      = subst (apply this) inThis

  namespace Double

    public export
    apply : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => {ctxt          : List type}
         -> {typeA, typeB, typeC : type}
         -> (this    : term       ctxt                     typeA)
         -> (andThis : term       ctxt                     typeB)
         -> (idx     : Contains ((ctxt += typeA) += typeB) typeC)
                    -> term       ctxt                     typeC
    apply this andThis Here              = andThis
    apply this andThis (There Here)      = this
    apply this andThis (There (There x)) = var x

    public export
    subst : {type : Type}
         -> {term : List type -> type -> Type}
         -> Rename type term
         => Substitute type term
         => {ctxt          : List type}
         -> {typeA, typeB, typeC : type}
         -> (this    : term  ctxt                     typeA)
         -> (andThis : term  ctxt                     typeB)
         -> (inThis  : term ((ctxt += typeA) += typeB) typeC)
                    -> term   ctxt                     typeC
    subst {ctxt} {typeA} {typeB} {typeC} this andThis inThis
      = General.subst (apply this andThis) inThis

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


module India.Union

import public Data.List.AtIndex
import public Data.OpenUnion
import Text.Lexer

export
(t : _) =>
Show (elt t) =>
Show (Union elt [t]) where
  show = show . decomp0

export
(t : _) =>
Show (elt t) => Show (Union elt ts) =>
Show (Union elt (t::ts)) where
  show x = case decomp x of
                Left y  => show y
                Right y => show y

export
(t : _) =>
Eq (elt t) =>
Eq (Union elt [t]) where
  (==) = (==) `on` decomp0
  (/=) = (/=) `on` decomp0

export
(t : _) =>
Eq (elt t) => Eq (Union elt ts) =>
Eq (Union elt (t::ts)) where
  (==) = (==) `on` decomp
  (/=) = (/=) `on` decomp

export
(t : a) =>
TokenKind (elt t) =>
TokenKind (Union elt [t]) where
    TokType x = TokType $ decomp0 x
    tokValue x = tokValue $ decomp0 x

export
(t : a) =>
TokenKind (elt t) => TokenKind (Union elt ts) =>
TokenKind (Union elt (t::ts)) where
  TokType x with (decomp x)
    TokType x | (Left y) = TokType y
    TokType x | (Right y) = TokType y
  tokValue x str with (decomp x)
    tokValue x str | (Left y) = tokValue y str
    tokValue x str | (Right y) = tokValue y str


module Test

import NanoParsec.Parser
import NanoParsec.Combinator

test : Show a => Parser a -> String -> IO ()
test p input = case parse p input of
    Just x => printLn x
    Nothing => putStrLn $ "FAIL: " ++ input

listOf : Parser a -> Parser (List a)
listOf p = do
    string "["
    xs <- p `sepBy` (string ",")
    string "]"
    return xs

testListOf1 : IO ()
testListOf1 = test (listOf natural) "[1,2,3,4,5,666]"

testListOf2 : IO ()
testListOf2 = test (listOf natural) "This is not a list, awesome!"


module Test.Char

import Data.Prim.Char
import Data.SOP
import Hedgehog

allChar : Gen Char
allChar = unicodeAll

prop_ltMin : Property
prop_ltMin = property $ do
  b8 <- forAll allChar
  (b8 >= MinChar) === True

prop_comp : Property
prop_comp = property $ do
  [m,n] <- forAll $ np [allChar, allChar]
  toOrdering (comp m n) === compare m n

export
props : Group
props = MkGroup "Char"
  [ ("prop_ltMin",  prop_ltMin)
  , ("prop_comp",   prop_comp)
  ]


-- --------------------------------------------------------------- [ BTree.idr ]
-- Module    : BTree.idr
-- Copyright : (c) 2017 See CONTRIBUTORS.md
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]
||| Implementation of a Binary Tree as a Red-Black Binary Search Tree.
|||
||| The underlying Red-Black Tree is a Key-Value Tree, this library
||| just wraps this up as a simple Binary tree for values i.e. keys.
module Data.RedBlack.BTree

import Data.RedBlack.Tree

%default total
%access export

-- ------------------------------------------------------------- [ Definitions ]

||| A Binary Search Tree.
|||
||| @ty The type of the elements in the tree.
data BTree : (ty : Type) -> Type
    where
      MkTree : {a : Type} -> RBTree n B a Unit -> BTree a

-- --------------------------------------------------------------------- [ API ]

||| Return an empty BTree.
empty : Ord a => BTree a
empty = MkTree empty

||| Insert an element into the Tree.
insert : (Ord a) => a -> BTree a -> BTree a
insert a (MkTree t) = case Tree.insert a () t of
  (_ ** t') => MkTree t'

||| Does the tree contain the given element?
contains : (Ord a) => a -> BTree a -> Bool
contains a (MkTree t) = isJust (Tree.lookup a t)

||| How many nodes are in the tree?
size : BTree a -> Nat
size (MkTree t) = Tree.size t

||| Construct an ordered list containing the elements of the tree.
toList : BTree a -> List a
toList (MkTree t) = map fst $ Tree.toList t

||| Construct a tree from a list of elements.
fromList : (Ord a) => List a -> BTree a
fromList xs = (foldl (\t,k => BTree.insert k t) empty xs)

-- --------------------------------------------------------------- [ Instances ]

Foldable BTree where
  foldr f i (MkTree t) = foldr (\x,_,p => f x p) i t

-- Eq a => Eq (BTree a) where
--   (==) (MkTree t) (MkTree t') = t == t'

Show a => Show (BTree a) where
  show s = "{ " ++ (unwords . intersperse "," . map show . BTree.toList $ s) ++ " }"

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


-- exercises in "Type-Driven Development with Idris"
-- chapter 10

import DataStore

-- check that all functions are total
%default total

testStore : DataStore (SString .+. SString .+. SInt)
testStore = addToStore ("Mercury", "Mariner 10", 1974) $
            addToStore ("Venus", "Venera", 1961) $
            addToStore ("Uranus", "Voyager 2", 1986) $
            addToStore ("Pluto", "New Horizons", 2015) $
            empty

listItems : DataStore schema -> List (SchemaType schema)
listItems input with (storeView input)
  listItems input | SNil = []
  listItems (addToStore value store) | (SAdd rec)
    = value :: listItems store | rec

filterKeys : (test : SchemaType val_schema -> Bool) ->
             DataStore (SString .+. val_schema) -> List String
filterKeys test input with (storeView input)
  filterKeys test input | SNil = []
  filterKeys test (addToStore (key, value) store) | (SAdd rec)
    = if test value
        then key :: filterKeys test store | rec
        else filterKeys test store | rec

getValues : DataStore (SString .+. val_schema) ->
            List (SchemaType val_schema)
getValues input with (storeView input)
  getValues input | SNil = []
  getValues (addToStore (key, value) store) | (SAdd rec)
    = value :: getValues store | rec

testStore2 : DataStore (SString .+. SInt)
testStore2 = addToStore ("First", 1) $
             addToStore ("Second", 2) $
             empty


module Main

import Data.Vect
import System.REPL
import Data.String
import Data.List

infixr 5 .+.

data Schema = SString
            | SInt
            | SChar
            | (.+.) Schema Schema

SchemaType : Schema -> Type
SchemaType SString = String
SchemaType SInt = Int
SchemaType SChar = Char
SchemaType (x .+. y) = (SchemaType x, SchemaType y)

record DataStore where
     constructor MkData
     schema : Schema
     size : Nat
     items: Vect size (SchemaType schema)

-- Store commands

addToStore : (store : DataStore) -> SchemaType (schema store) -> DataStore
addToStore (MkData schema size items) newitem = MkData schema _ (addToData items)
    where
        addToData : Vect oldsize (SchemaType schema) -> Vect (S oldsize) (SchemaType schema)
        addToData [] = [newitem]
        addToData (item :: items) = item :: addToData items

display : {schema : _} -> SchemaType schema -> String
display {schema = SString} item = item
display {schema = SInt} item = show item
display {schema = SChar} item = show item
display {schema = (x .+. y)} (iteml, itemr) = display iteml ++ ", " ++ display itemr

getItem : Integer -> (store : DataStore) -> Maybe (String, DataStore)
getItem i store = case integerToFin i (size store) of
                    Nothing => Just ("Entry not found\n", store)
                    Just i => Just (display (index i (items store)) ++ "\n", store)

getAllItems : (store : DataStore) -> Maybe (String, DataStore)
getAllItems store = let all = printAll (items store) in if all /= ""
                                                           then Just (all, store)
                                                           else Just ("Store empty.\n", store) where
                              printAll : Vect n (SchemaType (schema store)) -> String
                              printAll [] = ""
                              printAll (x :: xs) = display x ++ "\n" ++ printAll xs

search : String -> DataStore -> Maybe (String, DataStore)
search substr store = Just (searchItems (items store), store) where
                            searchItems : Vect n (SchemaType (schema store)) -> String
                            searchItems [] = "No entries with " ++ substr ++ " found\n"
                            searchItems (x :: xs) = case isInfixOf substr (display x) of
                                                          False => searchItems xs
                                                          True => show (length xs) ++ ": " ++ display x ++ "\n"

setSchema : (store : DataStore) -> Schema -> Maybe DataStore
setSchema store schema = case size store of
                              Z => Just (MkData schema _ [])
                              (S k) => Nothing

-- -- REPL UI

data Command : Schema -> Type where
     SetSchema : (newSchema : Schema) -> Command schema
     Add : SchemaType schema -> Command schema
     Get : Maybe Integer -> Command schema
     Search : String -> Command schema
     Size : Command schema
     Quit : Command schema

parseBySchema : (schema : Schema) -> String -> Maybe (SchemaType schema)
parseBySchema schema input = case parsePrefix schema input of
                                  Nothing => Nothing
                                  Just (res, "") => Just res
                                  Just _ => Nothing where
                             parsePrefix : (schema : Schema) -> String -> Maybe (SchemaType schema, String)
                             parsePrefix SString input = getQuoted (unpack input) where
                                   getQuoted : List Char -> Maybe (String, String)
                                   getQuoted ('"' :: xs) = case span (/= '"') xs of
                                                                (quoted, '"' :: rest) => Just (pack quoted, ltrim (pack rest))
                                                                _ => Nothing
                                   getQuoted _ = Nothing
                             parsePrefix SInt input = case span isDigit input of
                                                           ("", rest) => Nothing
                                                           (num, rest) => Just (cast num, ltrim rest)
                             parsePrefix SChar input = map (\(ch, rest) => (ch, ltrim rest)) (strUncons input)
                             parsePrefix (x .+. y) input = do (l_val, input') <- parsePrefix x input
                                                              (r_val, input'') <-  parsePrefix y input'
                                                              Just ((l_val, r_val), input'')

parseSchema : List String -> Maybe Schema
parseSchema (x :: xs) = do ty <- case x of
                                      "String" => Just SString
                                      "Int" => Just SInt
                                      "Char" => Just SChar
                                      _ => Nothing
                           case xs of
                                [] => Just ty
                                _ => map (\s => ty .+. s) (parseSchema xs)
parseSchema _ = Nothing

parseCommand : (schema : Schema) -> String -> String -> Maybe (Command schema)
parseCommand schema cmd rest = case cmd of
                              "schema" => map SetSchema (parseSchema (words rest))
                              "add" => map Add (parseBySchema schema rest)
                              "get" => map Get (Just (parseInteger rest))
                              "search" => Just (Search rest)
                              "size" => Just Size
                              "quit" => Just Quit
                              _ => Nothing

parse : (schema : Schema) -> (input : String) -> Maybe (Command schema)
parse schema input = case span (/= ' ') input of
                          (cmd, args) => parseCommand schema cmd (ltrim args)

processCommand : (store : DataStore) -> Command (schema store) -> Maybe (String, DataStore)
processCommand store (SetSchema newSchema) = case setSchema store newSchema of
                                                  Nothing => Just ("Cannot update schema for non-empty store\n", store)
                                                  Just newStore => Just ("Schema updated\n", newStore)

processCommand store (Add item) = Just ("Added ID " ++ show (size store) ++ " to store\n", addToStore store item)
processCommand store (Get (Just i)) = getItem i store
processCommand store (Get Nothing) = getAllItems store
processCommand store Size = Just (show (size store) ++ " entries in store\n", store)
processCommand store (Search substr) = search substr store
processCommand _ Quit = Nothing

processInput : DataStore -> String -> Maybe (String, DataStore)
processInput store input = case parse (schema store) input of
                                Nothing => Just ("Invalid command\n", store)
                                Just cmd => processCommand store cmd

main : IO ()
main = replWith (MkData SString _ []) "Command: " processInput


module Effect.Memory

import Effects
import Control.IOExcept

%access public

abstract
data MemoryChunk : Nat -> Nat -> Type where
     CH : Ptr -> MemoryChunk size initialized

abstract
data RawMemory : Effect where
     Allocate   : (n : Nat) ->
                  RawMemory () () (\v => MemoryChunk n 0)
     Free       : RawMemory () (MemoryChunk n i) (\v => ())
     Initialize : Bits8 ->
                  (size : Nat) ->
                  so (i + size <= n) ->
                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))
     Peek       : (offset : Nat) ->
                  (size : Nat) ->
                  so (offset + size <= i) ->
                  RawMemory (Vect size Bits8)
                            (MemoryChunk n i) (\v => MemoryChunk n i)
     Poke       :  (offset : Nat) ->
                  (Vect size Bits8) ->
                  so (offset <= i && offset + size <= n) ->
                  RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size)))
     Move       : (src : MemoryChunk src_size src_init) ->
                  (dst_offset : Nat) ->
                  (src_offset : Nat) ->
                  (size : Nat) ->
                  so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->
                  so (src_offset + size <= src_init) ->
                  RawMemory () (MemoryChunk dst_size dst_init)
                            (\v => MemoryChunk dst_size (max dst_init (dst_offset + size)))
     GetRawPtr  : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i)

private
do_malloc : Nat -> IOExcept String Ptr
do_malloc size with (fromInteger (cast size) == size)
  | True  = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (fromInteger $ cast size)
               fail  <- ioe_lift $ nullPtr ptr
               if fail then ioe_fail "Cannot allocate memory"
               else return ptr
  | False = ioe_fail "The target architecture does not support adressing enough memory"

private
do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()
do_memset ptr offset c size
  = mkForeign (FFun "idris_memset" [FPtr, FInt, FByte, FInt] FUnit)
              ptr (fromInteger $ cast offset) c (fromInteger $ cast size)

private
do_free : Ptr -> IO ()
do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr

private
do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO ()
do_memmove dest src dest_offset src_offset size
  = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)
              dest src (fromInteger $ cast dest_offset) (fromInteger $ cast src_offset) (fromInteger $ cast size)

private
do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect size Bits8)
do_peek _   _       Z = return (Prelude.Vect.Nil)
do_peek ptr offset (S n)
  = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FByte) ptr (fromInteger $ cast offset)
       bs <- do_peek ptr (S offset) n
       Prelude.Monad.return (Prelude.Vect.(::) b bs)

private
do_poke : Ptr -> Nat -> Vect size Bits8 -> IO ()
do_poke _   _      []     = return ()
do_poke ptr offset (b::bs)
  = do mkForeign (FFun "idris_poke" [FPtr, FInt, FByte] FUnit) ptr (fromInteger $ cast offset) b
       do_poke ptr (S offset) bs

instance Handler RawMemory (IOExcept String) where
  handle () (Allocate n) k
    = do ptr <- do_malloc n
         k () (CH ptr)
  handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k
    = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)
  handle (CH ptr) (Free) k
    = ioe_lift (do_free ptr) $> k () ()
  handle (CH ptr) (Peek offset size _) k
    = do res <- ioe_lift (do_peek ptr offset size)
         k res (CH ptr)
  handle (CH ptr) (Poke offset content _) k
    = do ioe_lift (do_poke ptr offset content)
         k () (CH ptr)
  handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k
    = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)
         k () (CH dest_ptr)
  handle chunk (GetRawPtr) k
    = k chunk chunk

RAW_MEMORY : Type -> EFFECT
RAW_MEMORY t = MkEff t RawMemory

allocate : (n : Nat) ->
           Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])
allocate size = Allocate size

initialize : {i : Nat} ->
             {n : Nat} ->
             Bits8 ->
             (size : Nat) ->
             so (i + size <= n) ->
             Eff m () [RAW_MEMORY (MemoryChunk n i)]
                       (\v => [RAW_MEMORY (MemoryChunk n (i + size))])
initialize c size prf = Initialize c size prf

free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])
free = Free

peek : {i : Nat} ->
       (offset : Nat) ->
       (size : Nat) ->
       so (offset + size <= i) ->
       { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)
peek offset size prf = Peek offset size prf

poke : {n : Nat} ->
       {i : Nat} ->
       (offset : Nat) ->
       Vect size Bits8 ->
       so (offset <= i && offset + size <= n) ->
       Eff m () [RAW_MEMORY (MemoryChunk n i)]
              (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])
poke offset content prf = Poke offset content prf

private
getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)
getRawPtr = GetRawPtr

private
move' : {dst_size : Nat} ->
        {dst_init : Nat} ->
        {src_init : Nat} ->
        (src_ptr : MemoryChunk src_size src_init) ->
        (dst_offset : Nat) ->
        (src_offset : Nat) ->
        (size : Nat) ->
        so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->
        so (src_offset + size <= src_init) ->
        Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]
               (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])
move' src_ptr dst_offset src_offset size dst_bounds src_bounds
  = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

data MoveDescriptor = Dst | Src

move : {dst_size : Nat} ->
       {dst_init : Nat} ->
       {src_size : Nat} ->
       {src_init : Nat} ->
       (dst_offset : Nat) ->
       (src_offset : Nat) ->
       (size : Nat) ->
       so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->
       so (src_offset + size <= src_init) ->
       Eff m ()
              [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)
              , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]
              (\v =>
                [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))
                , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])
move dst_offset src_offset size dst_bounds src_bounds
  = do src_ptr <- Src :- getRawPtr
       Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds
       return ()


module Network.TLS.Wrapper

import Data.Nat
import Utils.Misc
import Data.Vect
import Data.List
import Network.TLS.Magic

public export
record Wrapper (mac_size : Nat) where
  constructor MkWrapper
  encrypted_data : List Bits8
  auth_tag : Vect mac_size Bits8

public export
to_application_data : Wrapper mac_size -> List Bits8
to_application_data x = x.encrypted_data <+> toList x.auth_tag

public export
from_application_data : {mac_size : _} -> (application_data : List Bits8) -> Maybe (Wrapper mac_size)
from_application_data xs =
  let xs' = fromList xs in
  case isLTE mac_size (length xs) of
    Yes prf =>
      let
        (encrypted_data, auth_tag) = splitAt (minus (length xs) mac_size) $ replace_vect (sym $ plusMinusLte _ _ prf) xs'
      in
        Just $ MkWrapper (toList encrypted_data) auth_tag
    No contra => Nothing

public export
record Wrapper2 (iv_size : Nat) (mac_size : Nat) where
  constructor MkWrapper2
  iv_data : Vect iv_size Bits8
  encrypted_data : List Bits8
  auth_tag : Vect mac_size Bits8

public export
to_application_data2 : Wrapper2 iv_size mac_size -> List Bits8
to_application_data2 x = toList x.iv_data <+> x.encrypted_data <+> toList x.auth_tag

public export
from_application_data2 : {iv_size : _} -> {mac_size : _} -> (application_data : List Bits8) -> Maybe (Wrapper2 iv_size mac_size)
from_application_data2 xs = do
  let (iv, ciphertext) = splitAt iv_size xs
  iv' <- exactLength iv_size $ fromList iv
  w <- from_application_data ciphertext
  pure $ MkWrapper2 iv' w.encrypted_data w.auth_tag

namespace WrappedRecord
  public export
  record WrappedRecord where
    constructor MkWrappedRecord
    record_type : RecordType
    wrapped_data : List Bits8

  public export
  to_application_data : WrappedRecord -> List Bits8
  to_application_data x = x.wrapped_data <+> [record_type_to_id x.record_type]


singleton : Vector xs t ->
            Vector (1::xs) t
singleton t = [t]

invSingleton : Vector (1::xs) t ->
               Vector xs t
invSingleton [t] = t


redDim : Vector (x1::x2::xs) t ->
         Vector (x1*x2::xs) t
redDim [] = []
redDim (v::vs) = v ++ redDim vs


module LightClick.Types.Usage

import Data.List
import Data.Vect

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

import LightClick.Error

import LightClick.Types
import LightClick.Types.Equality

%default total

public export
PortList : (p     : Nat)
        -> (names : Vect p String)
                 -> Type
PortList = DVect String (Ty . PORT)

namespace PortList

  public export
  data Division : (0 pred : (label : String) -> Ty (PORT label) -> Type)

               -> {ps    : Vect p String}
               -> {ns    : Vect n String}
               -> {names : Vect o String}

               -> (pos  : PortList p ps)
               -> (neg  : PortList n ns)
               -> (orig : PortList o names)
                       -> Type
    where
      Empty : Division pred Nil Nil Nil

      Pos : {0 pred : (label : String) -> Ty (PORT label) -> Type}
         -> {pos  : PortList p ps}
         -> {neg  : PortList n ns}
         -> {orig : PortList o os}

         -> {label : String}
         -> {port : Ty (PORT label)}

         -> (prf  : pred label port)
         -> (rest : Division pred        pos  neg        orig)
                 -> Division pred (port::pos) neg (port::orig)

      Neg : {0 pred : (label : String) -> Ty (PORT label) -> Type}
         -> {pos  : PortList p ps}
         -> {neg  : PortList n ns}
         -> {orig : PortList o os}

         -> {label : String}
         -> {port : Ty (PORT label)}

         -> (prf  : Not (pred label port))

         -> (rest : Division pred pos        neg         orig)
                 -> Division pred pos (port::neg) (port::orig)

  public export
  data State : (pred  : (label : String) -> (port : Ty (PORT label)) -> Type)
            -> (ports : PortList p names)
                     -> Type
    where

      MkState : {0 pred : (label : String) -> Ty (PORT label) -> Type}

             -> {os       : Vect     o String}
             -> {orig     : PortList o os}

             -> (ps       : Vect     p String)
             -> (pos      : PortList p ps)

             -> (ns       : Vect     n String)
             -> (neg      : PortList n ns)

             -> (division : Division pred pos neg orig)

                         -> State pred orig

  export
  state : (0 pred  : (label : String) -> (port : Ty (PORT label)) -> Type)

       -> (dec   : (label : String) -> (port : Ty (PORT label)) -> Dec (pred label port))
       -> (ports : PortList p ps)
                -> State pred ports
  state pred _ [] = MkState Nil Nil Nil Nil Empty

  state pred dec ((TyPort l d s w t u) :: ports) with (dec l (TyPort l d s w t u))
    state pred dec ((TyPort l d s w t u) :: ports) | (Yes prf) with (state pred dec ports)
      state pred dec ((TyPort l d s w t u) :: ports) | (Yes prf) | (MkState xs pos ns neg division)
        = MkState (l::xs) ((TyPort l d s w t u)::pos) ns neg (Pos prf division)

    state pred dec ((TyPort l d s w t u) :: ports) | (No contra) with (state pred dec ports)
      state pred dec ((TyPort l d s w t u) :: ports) | (No contra) | (MkState xs pos ns neg division)
        = MkState xs pos (l::ns) ((TyPort l d s w t u)::neg) (Neg contra division)

namespace Free

  namespace Port
    public export
    data Free : (l : String) -> (port : Ty (PORT l)) -> Type where
      FreePort : (label : String)
              -> (use : TyRig)
              -> (contra : Not (use = None))
              -> Free (label) (TyPort label dir sense ety type use)

    used : Free l (TyPort l d s w t None) -> Void
    used (FreePort l None contra) = contra Refl

    export
    free : (label : String)
        -> (type  : Ty (PORT label))
                 -> Dec (Free label type)
    free l (TyPort l d s w t None) = No used
    free l (TyPort l d s w t One) = Yes (FreePort l One (negEqSym noneNotOne))
    free l (TyPort l d s w t Tonne) = Yes (FreePort l Tonne (negEqSym noneNotTonne))

  namespace Types

    export
    free : (type : Ty m) -> List String
    free TyLogic = Nil
    free (TyArray type length) = Nil
    free (TyStruct kvs) = Nil
    free (TyUnion kvs) = Nil
    free TyUnit = Nil
    free TyConn = Nil
    free TyGate = Nil
    free (TyPort label dir sense wty type usage) with (free label (TyPort label dir sense wty type usage))
      free (TyPort label dir sense wty type usage) | Yes (FreePort label usage contra)
        = [label]
      free (TyPort label dir sense wty type usage) | No contra
        = Nil
    free (TyModule ports) with (state Port.Free Port.free ports)
      free (TyModule ports) | (MkState ps pos ns neg division) = toList ps

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


module Data.NFA

%default total
%access public export

record NFA s elem where
  constructor MkNFA
  init       : s
  transition : s -> elem -> List s
  terminal   : s -> Bool

accepts : Eq elem => NFA s elem -> List elem -> Bool
accepts (MkNFA init transition terminal) = any terminal . foldlM transition init

data State : Type -> Type where
  Match  :                                                State elem
  Split  : (left : State elem) -> (right : State elem) -> State elem
  Single : (out  : elem)       -> (next  : State elem) -> State elem

data Expression : Type -> Type where
  ELit : elem                                                                      -> Expression elem
  EUn  : (opname : String) -> (operation : State elem -> State elem)               -> Expression elem
  EBin : (opname : String) -> (operation : State elem -> State elem -> State elem) -> Expression elem

data ExprCompilationError = ECompErr String

private
compErr : String -> Either ExprCompilationError a
compErr = Left . ECompErr

-- compile : List (Expression elem) -> Either ExprCompilationError (State elem)
-- compile xs = go xs [] where
--   go : List (Expression elem) -> List (Frag elem) -> Either ExprCompilationError (State elem)
--   go [] [] = compErr "Nothing to compile"
--   go [] (s :: []) = case state s of
--                       Ready x     => Right x
--                       TempSplit _ =>
--                         compErr "Compilation error, state value not complete. Possibly a bug in the implementation."
--   go [] (s :: ss) = compErr "Compilation error, extra values remaining in stack. Probably a bug in the implementation."
--   go (ELit l :: xs) ys = go xs (MkFrag (Ready $ Single l) Nil :: ys)
--   go (EUn _ op :: xs) (o1 :: ys) = go xs (op o1 :: ys)
--   go (EUn name _ :: xs) ys       = compErr $ "Compilation error: operation [ " ++ name ++ " ] requires an operand."
--   go (EBin _ op :: xs) (o1 :: o2 :: ys) = go xs (op o1 o2 :: ys)
--   go (EBin name _ :: xs) ys = compErr $ "Compilation error: operation [ " ++ name ++ " ] requires two operands."


module Main

tstr : String
tstr = "abc123"

tlist : List Int
tlist = [1, 2, 3, 4, 5]

main : IO ()
main = do printLn (abs (-8))
          printLn (span isAlpha tstr)
          printLn (break isDigit tstr)
          printLn (span (\x => x < 3) tlist)
          printLn (break (\x => x > 2) tlist)


palindromeLowered : String -> Bool
palindromeLowered str =
  let loweredStr = toLower str in
  loweredStr == reverse loweredStr

palindrome : Nat -> String -> Bool
palindrome len str =
  if length str > len
    then palindromeLowered str
    else False


data DoorState = DoorClosed | DoorOpen

data DoorResult = OK | Jammed

data DoorCmd : (ty : Type) ->
               DoorState ->
               (ty -> DoorState) ->
               Type where
  Open :     DoorCmd DoorResult DoorClosed (\res => case res of
                                                         OK => DoorOpen
                                                         Jammed => DoorClosed)
  Close :    DoorCmd ()         DoorOpen   (const DoorClosed)
  RingBell : DoorCmd ()         DoorClosed (const DoorClosed)

  Display : String -> DoorCmd () state (const state)

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

logOpen : DoorCmd DoorResult DoorClosed
                             (\res => case res of
                                           OK => DoorOpen
                                           Jammed => DoorClosed)
logOpen = do Display "Trying to open the door"
             OK <- Open | Jammed => do Display "Jammed"
                                       Pure Jammed
             Display "Success"
             Pure OK

doorProg : DoorCmd () DoorClosed (const DoorClosed)
doorProg = do RingBell
              jam <- Open
              Display "Trying to open the door"
              case jam of
                   OK => do Display "Glad To Be Of Service"
                            Close
                   Jammed => Display "Door Jammed"

doorProg2 : DoorCmd () DoorClosed (const DoorClosed)
doorProg2 = do RingBell
               OK <- Open | Jammed => Display "Door Jammed"
               Display "Glad To Be Of Service"
               Close
               OK <- Open | Jammed => Display "Door Jammed"
               Display "Glad To Be Of Service"
               Close


-- -------------------------------------------------------------- [ PModel.idr ]
-- Module    : PModel.idr
-- Copyright : (c) Jan de Muijnck-Hughes
-- License   : see LICENSE
-- --------------------------------------------------------------------- [ EOH ]

module Sif.PModel

import public GRL.Common
import public GRL.IR
import public GRL.Model
import public GRL.Builder
import public GRL.Pretty

%access export
%default total

-- ------------------------------------------------------------------- [ Types ]

public export
data FTy = FuncTy | UsabTy  | ReliTy | PerfTy | SuppTy

public export
data ATy = CodeTy | ControlTy | ActionTy

public export
data LTy = ActLink | AffLink

public export
data PMTy = Req FTy | Act ATy | Link LTy | Sub GStructTy

-- ------------------------------------------------------- [ Meta Typing Rules ]

public export
data ValidLink : LTy -> PMTy -> PMTy -> Type where
  RAct : ValidLink ty (Req x) (Req y)
  MAct : ValidLink ty (Act x) (Req y)
  AAct : ValidLink ty (Act y) (Act y)

public export
data ValidDecomp : PMTy -> PMTy -> Type where
  SubR : ValidDecomp (Req x) (Req y)
  SubM : ValidDecomp (Act x) (Act y)

public export
data ValidDecomps : PMTy -> List PMTy -> Type where
  Nil  : ValidDecomps x Nil
  (::) : (x : PMTy)
      -> (y : PMTy)
      -> {auto prf : ValidDecomp x y}
      -> ValidDecomps x ys
      -> ValidDecomps z (y::ys)

-- ------------------------------------------ [ Abstract Syntax & Typing Rules ]

public export
data PModel : PMTy -> GTy -> Type where
  MkReq    : (ty : FTy) -> String -> PModel (Req ty) ELEM
  MkAction : (ty : ATy) -> String -> Maybe SValue -> PModel (Act ty) ELEM
  MkLink   : (ty : LTy)
          -> CValue
          -> PModel x ELEM
          -> PModel y ELEM
          -> {auto prf : ValidLink ty x y}
          -> PModel (Link ty) INTENT
  MkSub    : (ty : GStructTy)
          -> PModel x ELEM
          -> DList PMTy (\y => PModel y ELEM) ys
          -> {auto prf : ValidDecomps x ys}
          -> PModel (Sub ty) STRUCT

-- ----------------------------------------------------- [ Typing Type-Aliases ]

public export
FUNCTIONAL : Type
FUNCTIONAL = PModel (Req FuncTy) ELEM

public export
USABILITY : Type
USABILITY = PModel (Req UsabTy) ELEM

public export
RELIABILITY : Type
RELIABILITY = PModel (Req ReliTy) ELEM

public export
PERFORMANCE : Type
PERFORMANCE = PModel (Req PerfTy) ELEM

public export
SUPPORTABILITY : Type
SUPPORTABILITY = PModel (Req SuppTy) ELEM

public export
CODEACTION : Type
CODEACTION = PModel (Act CodeTy) ELEM

public export
CONTROL : Type
CONTROL = PModel (Act ControlTy) ELEM

public export
ACTION : Type
ACTION = PModel (Act ActionTy) ELEM

-- ---------------------------------------------------- [ Element Constructors ]

mkFunctional : String -> FUNCTIONAL
mkFunctional = MkReq FuncTy

mkUsability : String -> USABILITY
mkUsability = MkReq UsabTy

mkReliability : String -> RELIABILITY
mkReliability = MkReq ReliTy

mkPerformance : String -> PERFORMANCE
mkPerformance = MkReq PerfTy

mkSupportability : String -> SUPPORTABILITY
mkSupportability = MkReq SuppTy

mkControl : String -> Maybe SValue -> CONTROL
mkControl = MkAction ControlTy

mkCode : String -> Maybe SValue -> CODEACTION
mkCode = MkAction CodeTy

mkAction : String -> Maybe SValue -> ACTION
mkAction = MkAction ActionTy

-- -------------------------------------------------------- [ Operator Aliases ]

syntax [a] "==>" [b] "|" [c] = MkLink ActLink c a b
syntax [a] "~~>" [b] "|" [c] = MkLink AffLink c a b
syntax [a] "&=" [bs] = MkSub ANDty a bs
syntax [a] "X=" [bs] = MkSub XORty a bs
syntax [a] "|=" [bs] = MkSub IORty a bs

-- ------------------------------------------------------------- [ Interpreter ]

GRL (\ty => PModel x ty) where
  mkElem (MkReq ty  t)        = Elem GOALty t Nothing
  mkElem (MkAction ty t sval) = Elem TASKty t sval

  mkIntent (MkLink AffLink c a b) = ILink AFFECTSty c (mkElem a) (mkElem b)
  mkIntent (MkLink ActLink c a b) = ILink IMPACTSty  c (mkElem a) (mkElem b)

  mkStruct (MkSub ty x ys) = SLink ty (mkElem x) (mapDList (mkElem) ys)

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


module Main -- where

main : IO ()
main = do
  let f (x :: xs) = ((x + 1) :: f xs)
  printLn $ f [1,2,3,4,5]


module Main

import GLCore
import JSArrays
import Shaders

import JSMatrix.JSMatrix

-- Save time, just get the canvas directly by id
getElemById : String -> IO Element
getElemById s = do
  x <- mkForeign (FFun "document.getElementById(%0)" [FString] FPtr) s
  return (MkElem x)

getElemFloatProp : String -> Element -> IO Float
getElemFloatProp p (MkElem e) = mkForeign (FFun "%0[%1]" [FPtr,FString] FFloat) e p

getElemStringProp : String -> Element -> IO String
getElemStringProp p (MkElem e) = mkForeign (FFun "%0[%1]" [FPtr,FString] FString) e p

-- Retrieve the dimensions of the canvas element
canvasDimensions : Element -> IO (List Float)
canvasDimensions e = do
  w <- getElemFloatProp "width" e
  h <- getElemFloatProp "height" e
  return [w,h]

-- Shader Functions
getShader : String -> IO String
getShader e = getElemById e >>= getElemStringProp "textContent"

-- Pyramid
pyramidVertices : List Float
pyramidVertices = [0.0, 1.0, 0.0,
                   -1.0, 0.0, 1.0,
                   1.0, 0.0, 1.0,

                   0.0, 1.0, 0.0,
                   1.0, 0.0, 1.0,
                   1.0, 0.0, -1.0,

                   0.0, 1.0, 0.0,
                   1.0, 0.0, -1.0,
                   -1.0, 0.0, -1.0,

                   0.0, 1.0, 0.0,
                   -1.0, 0.0, -1.0,
                   -1.0, 0.0, 1.0]

pyramidColours : List Float
pyramidColours = [0, 0, 1, 1,
                  0, 0, 1, 1,
                  0, 0, 1, 1,

                  1, 1, 0, 1,
                  1, 1, 0, 1,
                  1, 1, 0, 1,

                  0, 1, 0, 1,
                  0, 1, 0, 1,
                  0, 1, 0, 1,

                  1, 0, 0, 1,
                  1, 0, 0, 1,
                  1, 0, 0, 1]

mvTranslateVect : Vect 3 Float
mvTranslateVect = [0.0,0.0,-4.0]

rotateVec : Vect 3 Float
rotateVec = [0.0,1.0,0.0]

-- Some basic settings for starting our GL env
baseGLInit : GLCxt -> IO GLCxt
baseGLInit c = do
  depthTest <- getGLProp "DEPTH_TEST" c
  clearColor [1.0, 1.0, 1.0, 1.0] c >>= enableGLSetting depthTest >>= glClear

prepareVerticesArray : List Float -> IO F32Array
prepareVerticesArray xs = createJSArray >>= fromFloatList xs >>= createF32Array

-- Wrapper for finding and init'ing our GL env and context
locateInitCanvas : IO GLCxt
locateInitCanvas = getElemById "canvas" >>= getGLCxt >>= baseGLInit

-- Wrapper for the process of assigning a shader variable the correct location
-- for our program to locate vertex information when the shader runs.
assignVertexPositionAttribs : String -> Int -> (GLProgram,GLCxt) -> IO (GLProgram,GLCxt)
assignVertexPositionAttribs attr n glProg = do
  loc <- getAttribLocation attr glProg
  enableVertexAttribArray glProg loc >>= setVertexAttribPointer n loc

translateMat : JSGLMat4 -> IO JSGLMat4
translateMat jsMat4 =
  createVec3FromVect mvTranslateVect >>= \v3 => translateM4 v3 jsMat4 jsMat4

printJunk : JSGLMat4 -> IO ()
printJunk (MkMat4 a) = mkForeign (FFun "console.log(%0)" [FPtr] FUnit) a

main : IO ()
main = do
  [w,h] <- getElemById "canvas" >>= canvasDimensions
  verticesF32 <- prepareVerticesArray pyramidVertices
  coloursF32 <- prepareVerticesArray pyramidColours

  (vBuffer,glCxt) <- locateInitCanvas >>= flip createBindBuffer verticesF32
  (cBuffer,glCxt') <- createBindBuffer glCxt coloursF32

  -- Set the viewport size
  setViewport w h glCxt'

  prgCxt <- createProg glCxt'

  -- Pull the shaders off the DOM
  vshader <- [| Vertex $ getShader "vshader" |]
  fshader <- [| Fragment $ getShader "fshader" |]

  -- JS Math.Pi Value
  mPI <- mathPI

  -- Create rotation vector
  rotationAxis <- createVec3
  rotationAxis' <- createVec3FromVect rotateVec >>= normaliseV3 rotationAxis

  -- Create our matrices
  mvMatrix <- createMat4 >>= translateMat
  mvMatrix' <- rotateM4 mvMatrix (mPI*2*33) rotationAxis' mvMatrix

  pjMatrix <- createMat4 >>= perspectiveM4 (mPI/4) (w/h) 1 100

  -- Pass our shader code to be built,compiled, and linked to the GL context
  prgCxt' <- compileAndLinkShaders [vshader, fshader] prgCxt >>= useProg

  prgCxt'' <- assignVertexPositionAttribs "vertPos" 3 prgCxt'
  nxtPrgCxt <- assignVertexPositionAttribs "vertColor" 4 prgCxt''

  mvLoc <- getUniformLocation "mvMatrix" nxtPrgCxt
  pjLoc <- getUniformLocation "pjMatrix" nxtPrgCxt

  nxtPrgCxt' <- uniformMatrix4v mvMatrix' mvLoc nxtPrgCxt >>= uniformMatrix4v pjMatrix pjLoc

  drawTriangles 0 12 nxtPrgCxt'

  putStrLn "It might have worked... who knows!"


module DataWAuto

data X : Int => Type -> Type where
  X0 : Int => X Int


data SnocList ty = Empty | Snoc (Main.SnocList ty) ty

reverseSnoc : Main.SnocList ty -> List ty
reverseSnoc Empty = []
reverseSnoc (Snoc xs x) = x :: reverseSnoc xs