module Hedgehog.Internal.Property

import Control.Monad.Either
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Writer
import Data.DPair
import Data.Lazy
import Data.SortedMap
import Generics.Derive
import Hedgehog.Internal.Gen
import Hedgehog.Internal.Util
import Text.Show.Diff
import Text.Show.Pretty

%language ElabReflection

%default total

--------------------------------------------------------------------------------
--          Tagged Primitives
--------------------------------------------------------------------------------

public export
data Tag = ConfidenceTag
         | CoverCountTag
         | CoverPercentageTag
         | GroupNameTag
         | LabelNameTag
         | PropertyCountTag
         | PropertyNameTag
         | ShrinkCountTag
         | ShrinkLimitTag
         | TestCountTag
         | TestLimitTag

public export
record Tagged (tag : Tag) (t : Type) where
  constructor MkTagged
  unTag : t

public export %inline
Show t => Show (Tagged tag t) where
  show = show . unTag

public export %inline
Eq t => Eq (Tagged tag t) where
  (==) = (==) `on` unTag

public export %inline
Ord t => Ord (Tagged tag t) where
  compare = compare `on` unTag

public export %inline
Num t => Num (Tagged tag t) where
  fromInteger = MkTagged . fromInteger
  MkTagged x + MkTagged y = MkTagged (x + y)
  MkTagged x * MkTagged y = MkTagged (x * y)

public export %inline
FromString t => FromString (Tagged tag t) where
  fromString = MkTagged . fromString

public export %inline
Semigroup (Tagged tag Nat) where (<+>) = (+)

public export %inline
Monoid (Tagged tag Nat) where neutral = 0

||| The total number of tests which are covered by a classifier.
|||
||| Can be constructed using numeric literals.
public export
0 CoverCount : Type
CoverCount = Tagged CoverCountTag Nat

||| The name of a group of properties.
public export
0 GroupName : Type
GroupName = Tagged GroupNameTag String

||| The number of properties in a group.
public export
0 PropertyCount : Type
PropertyCount = Tagged PropertyCountTag Nat

||| The numbers of times a property was able to shrink after a failing test.
public export
0 ShrinkCount : Type
ShrinkCount = Tagged ShrinkCountTag Nat

||| The number of shrinks to try before giving up on shrinking.
|||
||| Can be constructed using numeric literals:
public export
0 ShrinkLimit : Type
ShrinkLimit = Tagged ShrinkLimitTag Nat

||| The number of tests a property ran successfully.
public export
0 TestCount : Type
TestCount = Tagged TestCountTag Nat

||| The number of successful tests that need to be run before a property test
||| is considered successful.
|||
||| Can be constructed using numeric literals.
public export
0 TestLimit : Type
TestLimit = Tagged TestLimitTag Nat

||| The name of a property.
public export
0 PropertyName : Type
PropertyName = Tagged PropertyNameTag String

||| The acceptable occurrence of false positives
|||
||| Example, `the Confidence 1000000000` would mean that
||| you'd accept a false positive
||| for 1 in 10^9 tests.
public export
record Confidence where
  constructor MkConfidence
  confidence : Bits64
  0 inBound    : confidence >= 2 = True

public export %inline
Eq Confidence where (==) = (==) `on` confidence

public export %inline
Ord Confidence where compare = compare `on` confidence

public export %inline
Show Confidence where showPrec p = showPrec p . confidence

namespace Confidence
  public export
  fromInteger :  (n : Integer)
              -> {auto 0 prf : the Bits64 (fromInteger n) >= 2 = True}
              -> Confidence
  fromInteger n = MkConfidence (fromInteger n) prf

||| The relative number of tests which are covered by a classifier.
public export
0 CoverPercentage : Type
CoverPercentage = Tagged CoverPercentageTag Double

||| The name of a classifier.
public export
0 LabelName : Type
LabelName = Tagged LabelNameTag String

--------------------------------------------------------------------------------
--          Journal
--------------------------------------------------------------------------------

||| The difference between some expected and actual value.
public export
record Diff where
  constructor MkDiff
  diffPrefix  : String
  diffRemoved : String
  diffInfix   : String
  diffAdded   : String
  diffSuffix  : String
  diffValue   : ValueDiff

%runElab derive "Hedgehog.Internal.Property.Diff" [Generic,Meta,Show,Eq]

||| Whether a test is covered by a classifier, and therefore belongs to a
||| 'Class'.
public export
data Cover = NotCovered | Covered

%runElab derive "Cover" [Generic,Meta,Show,Eq,Ord]

public export
Semigroup Cover where
  NotCovered <+> NotCovered = NotCovered
  _          <+> _          = Covered

public export
Monoid Cover where
  neutral = NotCovered

public export
toCoverCount : Cover -> CoverCount
toCoverCount NotCovered = 0
toCoverCount Covered    = 1

||| The extent to which a test is covered by a classifier.
|||
||| When a classifier's coverage does not exceed the required minimum, the
||| test will be failed.
public export
record Label a where
  constructor MkLabel
  labelName       : LabelName
  labelMinimum    : CoverPercentage
  labelAnnotation : a

%runElab derive "Label" [Generic,Meta,Show,Eq]

public export
Functor Label where
  map f = {labelAnnotation $= f}

public export
Foldable Label where
  foldl f a l = f a l.labelAnnotation
  foldr f a l = f l.labelAnnotation a
  null _ = False

public export
Traversable Label where
  traverse f l = (\v => {labelAnnotation := v} l) <$>
                 f l.labelAnnotation

||| This semigroup is right biased. The name, location and percentage from the
||| rightmost `Label` will be kept. This shouldn't be a problem since the
||| library doesn't allow setting multiple classes with the same 'ClassifierName'.
export
Semigroup a => Semigroup (Label a) where
  ll <+> lr = { labelAnnotation $= (ll.labelAnnotation <+>) } lr

||| Log messages which are recorded during a test run.
public export
data Log = Annotation (Lazy String)
         | Footnote (Lazy String)
         | LogLabel (Label Cover)

%runElab derive "Log" [Generic,Meta,Show,Eq]

||| A record containing the details of a test run.
public export
record Journal where
  constructor MkJournal
  journalLogs : List (Lazy Log)

%runElab derive "Journal" [Generic,Meta,Show,Eq,Semigroup,Monoid]

||| Details on where and why a test failed.
public export
record Failure where
  constructor MkFailure
  message : String
  diff    : Maybe Diff

%runElab derive "Failure" [Generic,Meta,Show,Eq]

||| The extent to which all classifiers cover a test.
|||
||| When a given classification's coverage does not exceed the required/
||| minimum, the test will be failed.
public export
record Coverage a where
  constructor MkCoverage
  coverageLabels : SortedMap LabelName (Label a)

%runElab derive "Coverage" [Generic,Meta,Show,Eq]

export
Functor Coverage where
  map f = {coverageLabels $= map (map f) }

export
Foldable Coverage where
  foldl f acc (MkCoverage sm) = foldl (foldl f) acc sm
  foldr f acc (MkCoverage sm) = foldr (\l,a => foldr f a l) acc sm
  null = null . coverageLabels

export
Traversable Coverage where
  traverse f (MkCoverage sm) = MkCoverage <$> traverse (traverse f) sm

export
Semigroup a => Semigroup (Coverage a) where
  MkCoverage c0 <+> MkCoverage c1 = MkCoverage $ c0 <+> c1

export
Semigroup a => Monoid (Coverage a) where
  neutral = MkCoverage empty

--------------------------------------------------------------------------------
--          Config
--------------------------------------------------------------------------------

public export
data TerminationCriteria =
    EarlyTermination Confidence TestLimit
  | NoEarlyTermination Confidence TestLimit
  | NoConfidenceTermination TestLimit

%runElab derive "TerminationCriteria" [Generic,Meta,Show,Eq]

public export
unCriteria : TerminationCriteria -> (Maybe Confidence, TestLimit)
unCriteria (EarlyTermination c t)      = (Just c, t)
unCriteria (NoEarlyTermination c t)    = (Just c, t)
unCriteria (NoConfidenceTermination t) = (Nothing, t)

||| Configuration for a property test.
public export
record PropertyConfig where
  constructor MkPropertyConfig
  shrinkLimit         : ShrinkLimit
  terminationCriteria : TerminationCriteria

%runElab derive "PropertyConfig" [Generic,Meta,Show,Eq]

||| The minimum amount of tests to run for a 'Property'
public export
defaultMinTests : TestLimit
defaultMinTests = 100

||| The default confidence allows one false positive in 10^9 tests
public export
defaultConfidence : Confidence
defaultConfidence = Confidence.fromInteger 1000000000

||| The default configuration for a property test.
public export
defaultConfig : PropertyConfig
defaultConfig =
  MkPropertyConfig {
      shrinkLimit = 1000
    , terminationCriteria = NoConfidenceTermination defaultMinTests
    }

--------------------------------------------------------------------------------
--          Test
--------------------------------------------------------------------------------

||| A test monad transformer allows the assertion of expectations.
public export
0 TestT : (Type -> Type) -> Type -> Type
TestT m = EitherT Failure (WriterT Journal m)

public export
0 Test : Type -> Type
Test = TestT Identity

export
mkTestT : Functor m => m (Either Failure a, Journal) -> TestT m a
mkTestT = MkEitherT . writerT

export
mkTest : (Either Failure a, Journal) -> Test a
mkTest = mkTestT . Id

export
runTestT : TestT m a -> m (Either Failure a, Journal)
runTestT = runWriterT . runEitherT

export
runTest : Test a -> (Either Failure a, Journal)
runTest = runIdentity . runTestT

||| Log some information which might be relevant to a potential test failure.
export
writeLog : Applicative m => Lazy Log -> TestT m ()
writeLog x = mkTestT $ pure (Right (), MkJournal [x])

||| Fail the test with an error message, useful for building other failure
||| combinators.
export
failWith : Applicative m => Maybe Diff -> String -> TestT m a
failWith diff msg = mkTestT $ pure (Left $ MkFailure msg diff, neutral)

||| Annotates the source code with a message that might be useful for
||| debugging a test failure.
export
annotate : Applicative m => Lazy String -> TestT m ()
annotate v = writeLog $ Annotation v

||| Annotates the source code with a value that might be useful for
||| debugging a test failure.
export covering
annotateShow : (Applicative m, Show a) => a -> TestT m ()
annotateShow v = annotate $ ppShow v

||| Logs a message to be displayed as additional information in the footer of
||| the failure report.
export
footnote : Applicative m => Lazy String -> TestT m ()
footnote v = writeLog $ Footnote v

||| Logs a value to be displayed as additional information in the footer of
||| the failure report.
export covering
footnoteShow : (Applicative m, Show a) => a -> TestT m ()
footnoteShow v = writeLog (Footnote $ ppShow v)

||| Fails with an error that shows the difference between two values.
export covering
failDiff : (Applicative m, Show a, Show b) => a -> b -> TestT m ()
failDiff x y =
  case valueDiff <$> reify x <*> reify y of
    Nothing =>
        failWith Nothing $
        unlines $ [
            "Failed"
          , "━━ lhs ━━"
          , ppShow x
          , "━━ rhs ━━"
          , ppShow y
          ]

    Just vdiff@(Same _) =>
        failWith (Just $
          MkDiff "━━━ Failed ("  "" "no differences" "" ") ━━━" vdiff) ""

    Just vdiff =>
        failWith (Just $
          MkDiff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) ""

||| Causes a test to fail.
export
failure : Applicative m => TestT m a
failure = failWith Nothing ""

||| Another name for `pure ()`.
export
success : Monad m => TestT m ()
success = pure ()

||| Fails the test if the condition provided is 'False'.
export
assert : Monad m => Bool -> TestT m ()
assert ok = if ok then success else failure

||| Fails the test and shows a git-like diff if the comparison operation
||| evaluates to 'False' when applied to its arguments.
|||
||| The comparison function is the second argument, which may be
||| counter-intuitive to Haskell programmers. However, it allows operators to
||| be written infix for easy reading:
|||
||| This function behaves like the unix @diff@ tool, which gives a 0 exit
||| code if the compared files are identical, or a 1 exit code code
||| otherwise. Like unix @diff@, if the arguments fail the comparison, a
||| /diff is shown.
|||
export covering
diff :  (Monad m, Show a, Show b)
     => a -> (a -> b -> Bool) -> b -> TestT m ()
diff x op y = if x `op` y then success
                          else failDiff x y

infix 4 ===

||| Fails the test if the two arguments provided are not equal.
export covering
(===) : (Monad m, Eq a, Show a) => a -> a -> TestT m ()
(===) x y = diff x (==) y

infix 4 /==

||| Fails the test if the two arguments provided are equal.
export covering
(/==) : (Monad m, Eq a, Show a) => a -> a -> TestT m ()
(/==) x y = diff x (/=) y

||| Fails the test if the 'Either' is 'Left', otherwise returns the value in
||| the 'Right'.
export covering
evalEither : (Monad m, Show x) => Either x a -> TestT m a
evalEither (Left x)  = failWith Nothing (ppShow x)
evalEither (Right x) = pure x

||| Fails the test if the 'Maybe' is 'Nothing', otherwise returns the value in
||| the 'Just'.
export
evalMaybe : Monad m => Maybe a -> TestT m a
evalMaybe Nothing = failWith Nothing "the value was Nothing"
evalMaybe (Just x) = pure x

--------------------------------------------------------------------------------
--          PropertyT
--------------------------------------------------------------------------------

||| The property monad allows both the generation of test inputs
|||  and the assertion of expectations.
public export
0 PropertyT : Type -> Type
PropertyT = TestT Gen

||| Generates a random input for the test by running the provided generator.
|||
||| This is a the same as 'forAll' but allows the user to provide a custom
||| rendering function. This is useful for values which don't have a
||| 'Show' instance.
export
forAllWith : (a -> String) -> Gen a -> PropertyT a
forAllWith render gen = do x <- lift (lift gen)
                           annotate (render x)
                           pure x

||| Generates a random input for the test by running the provided generator.
export covering
forAll : Show a => Gen a -> PropertyT a
forAll = forAllWith ppShow

||| Lift a test in to a property.
export
test : Test a -> PropertyT a
test = mapEitherT $ mapWriterT (pure . runIdentity)

--------------------------------------------------------------------------------
--          Property
--------------------------------------------------------------------------------

||| A property test, along with some configurable limits like how many times
||| to run the test.
public export
record Property where
  constructor MkProperty
  config : PropertyConfig
  test   : PropertyT ()

namespace Property
  ||| Map a config modification function over a property.
  export
  mapConfig : (PropertyConfig -> PropertyConfig) -> Property -> Property
  mapConfig f p = { config $= f } p

  verifiedTermination : Property -> Property
  verifiedTermination =
    mapConfig $ \config =>
      let
        newTerminationCriteria = case config.terminationCriteria of
          NoEarlyTermination c tests    => EarlyTermination c tests
          NoConfidenceTermination tests => EarlyTermination defaultConfidence tests
          EarlyTermination c tests      => EarlyTermination c tests
      in { terminationCriteria := newTerminationCriteria } config

  ||| Adjust the number of times a property should be executed before it is considered
  ||| successful.
  export
  mapTests : (TestLimit -> TestLimit) -> Property -> Property
  mapTests f = mapConfig {terminationCriteria $= setLimit}
    where setLimit : TerminationCriteria -> TerminationCriteria
          setLimit (NoEarlyTermination c n)    = NoEarlyTermination c (f n)
          setLimit (NoConfidenceTermination n) = NoConfidenceTermination (f n)
          setLimit (EarlyTermination c n)      = EarlyTermination c (f n)

  ||| Set the number of times a property should be executed before it is considered
  ||| successful.
  |||
  ||| If you have a test that does not involve any generators and thus does not
  ||| need to run repeatedly, you can use @withTests 1@ to define a property that
  ||| will only be checked once.
  export
  withTests : TestLimit -> Property -> Property
  withTests = mapTests . const

  ||| Set the number of times a property is allowed to shrink before the test
  ||| runner gives up and prints the counterexample.
  export
  withShrinks : ShrinkLimit -> Property -> Property
  withShrinks n = mapConfig { shrinkLimit := n }

  ||| Make sure that the result is statistically significant in accordance to
  ||| the passed 'Confidence'
  export
  withConfidence : Confidence -> Property -> Property
  withConfidence c = mapConfig { terminationCriteria $= setConfidence }
    where setConfidence : TerminationCriteria -> TerminationCriteria
          setConfidence (NoEarlyTermination _ n)    = NoEarlyTermination c n
          setConfidence (NoConfidenceTermination n) = NoConfidenceTermination n
          setConfidence (EarlyTermination _ n)      = EarlyTermination c n

||| Creates a property with the default configuration.
export
property : PropertyT () -> Property
property = MkProperty defaultConfig

||| A named collection of property tests.
public export
record Group where
  constructor MkGroup
  name       : GroupName
  properties : List (PropertyName, Property)

namespace Group
  export
  mapProperty : (Property -> Property) -> Group -> Group
  mapProperty f = { properties $= map (mapSnd f) }

  ||| Map a config modification function over all
  ||| properties in a `Group`.
  export
  mapConfig : (PropertyConfig -> PropertyConfig) -> Group -> Group
  mapConfig = mapProperty . mapConfig

  ||| Set the number of times the properties in a `Group`
  ||| should be executed before they are considered
  ||| successful.
  export
  withTests : TestLimit -> Group -> Group
  withTests = mapProperty . withTests

  ||| Set the number of times the properties in a `Group`
  ||| are allowed to shrink before the test
  ||| runner gives up and prints the counterexample.
  export
  withShrinks : ShrinkLimit -> Group -> Group
  withShrinks = mapProperty . withShrinks

  ||| Make sure that the results of a `Group` are statistically
  ||| significant in accordance to the passed 'Confidence'
  export
  withConfidence : Confidence -> Group -> Group
  withConfidence = mapProperty . withConfidence

--------------------------------------------------------------------------------
--          Coverage
--------------------------------------------------------------------------------

export
coverPercentage : TestCount -> CoverCount -> CoverPercentage
coverPercentage (MkTagged tests) (MkTagged count) =
  let percentage  = the Double (cast count / cast tests * 100)
      thousandths = round {a = Double} $ percentage * 10
  in MkTagged (thousandths / 10)

export
labelCovered : TestCount -> Label CoverCount -> Bool
labelCovered tests (MkLabel _ min population) =
  coverPercentage tests population >= min

export
coverageFailures : TestCount -> Coverage CoverCount -> List $ Label CoverCount
coverageFailures tests (MkCoverage kvs) =
  filter (not . labelCovered tests) (values kvs)

||| All labels are covered
export
coverageSuccess : TestCount -> Coverage CoverCount -> Bool
coverageSuccess tests c = null $ coverageFailures tests c

||| Require a certain percentage of the tests to be covered by the
||| classifier.
|||
||| ```idris
|||    prop_with_coverage : Property
|||    prop_with_coverage =
|||      property $ do
|||        match <- forAll Gen.bool
|||        cover 30 "True" $ match
|||        cover 30 "False" $ not match
||| ```
|||
||| The example above requires a minimum of 30% coverage for both
||| classifiers. If these requirements are not met, it will fail the test.
export
cover : Monad m => CoverPercentage -> LabelName -> Bool -> TestT m ()
cover min name covered =
  let cover = if covered then Covered else NotCovered
   in writeLog $ LogLabel (MkLabel name min cover)

||| Records the proportion of tests which satisfy a given condition.
|||
||| ```idris example
|||    prop_with_classifier : Property
|||    prop_with_classifier =
|||      property $ do
|||        xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
|||        for_ xs $ \\x -> do
|||          classify "newborns" $ x == 0
|||          classify "children" $ x > 0 && x < 13
|||          classify "teens" $ x > 12 && x < 20
||| ```
export
classify : Monad m => LabelName -> Bool -> TestT m ()
classify name covered = cover 0 name covered

||| Add a label for each test run. It produces a table showing the percentage
||| of test runs that produced each label.
export
label : Monad m => LabelName -> TestT m ()
label name = cover 0 name True

||| Like 'label', but uses 'Show' to render its argument for display.
export
collect : (Monad m, Show a) => a -> TestT m ()
collect x = cover 0 (MkTagged $ show x) True

fromLabel : Label a -> Coverage a
fromLabel x = MkCoverage $ singleton (labelName x) x

unionsCoverage : Semigroup a => List (Coverage a) -> Coverage a
unionsCoverage = MkCoverage . concatMap coverageLabels

export
journalCoverage : Journal -> Coverage CoverCount
journalCoverage = map toCoverCount
                . unionsCoverage
                . (>>= fromLog)
                . journalLogs
  where fromLog : Lazy Log -> List (Coverage Cover)
        fromLog (LogLabel x)   = [fromLabel x]
        fromLog (Footnote _)   = []
        fromLog (Annotation _) = []

--------------------------------------------------------------------------------
--          Confidence
--------------------------------------------------------------------------------

-- not strictly true, but holds for the values we generate
-- in this module
times : InUnit -> InUnit -> InUnit
times (Element x _) (Element y _) =
  Element (x * y) (believe_me (Refl {x = True}))

oneMin : InUnit -> InUnit
oneMin (Element v _) = Element (1.0 - v) (believe_me (Refl {x = True} ))

half : InUnit -> InUnit
half = times (Element 0.5 Refl)

-- In order to get an accurate measurement with small sample sizes, we're
-- using the Wilson score interval
-- (<https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval wikipedia>) instead of a normal approximation interval.
wilsonBounds : Nat -> Nat -> InUnit -> (Double, Double)
wilsonBounds positives count acceptance =
  let
    p = the Double (cast positives / cast count)
    n = the Double (cast count)
    z = invnormcdf $ oneMin (half acceptance)

    midpoint = p + z * z / (2 * n)

    offset = z / (1 + z * z / n) * sqrt (p * (1 - p) / n + z * z / (4 * n * n))

    denominator = 1 + z * z / n

    low = (midpoint - offset) / denominator

    high = (midpoint + offset) / denominator
  in (low, high)

boundsForLabel : TestCount -> Confidence -> Label CoverCount -> (Double, Double)
boundsForLabel (MkTagged tests) (MkConfidence c ib) lbl =
  wilsonBounds (unTag lbl.labelAnnotation) tests (recipBits64 (Element c ib))

||| Is true when the test coverage satisfies the specified 'Confidence'
||| contstraint for all 'Coverage CoverCount's
export
confidenceSuccess : TestCount -> Confidence -> Coverage CoverCount -> Bool
confidenceSuccess tests confidence =
  all assertLow . values . coverageLabels
  where assertLow : Label CoverCount -> Bool
        assertLow cc =
          fst (boundsForLabel tests confidence cc) >=
          unTag cc.labelMinimum / 100.0

||| Is true when there exists a label that is sure to have failed according to
||| the 'Confidence' constraint
export
confidenceFailure : TestCount -> Confidence -> Coverage CoverCount -> Bool
confidenceFailure tests confidence =
  any assertHigh . values . coverageLabels
  where assertHigh : Label CoverCount -> Bool
        assertHigh cc =
          snd (boundsForLabel tests confidence cc) <
          (unTag cc.labelMinimum / 100.0)

export
multOf100 : TestCount -> Bool
multOf100 (MkTagged n) = natToInteger n `mod` 100 == 0

export
failureVerified : TestCount -> Coverage CoverCount -> Maybe Confidence -> Bool
failureVerified count cover conf =
  multOf100 count &&
  maybe False (\c => confidenceFailure count c cover) conf

export
successVerified : TestCount -> Coverage CoverCount -> Maybe Confidence -> Bool
successVerified count cover conf =
  multOf100 count &&
  maybe False (\c => confidenceSuccess count c cover) conf

export
abortEarly :  TerminationCriteria
           -> TestCount
           -> Coverage CoverCount
           -> Maybe Confidence
           -> Bool
abortEarly (EarlyTermination _ _) tests cover conf =
  let coverageReached     = successVerified tests cover conf
      coverageUnreachable = failureVerified tests cover conf
   in unTag tests >= unTag defaultMinTests &&
      (coverageReached || coverageUnreachable)

abortEarly _ _ _ _ = False


module Test

import Data.Vect
import System.File
import System
import Data.Buffer
import Data.String

test1 : Nat -> List String -> Vect n Int -> String
test1 1 (x :: xs) (y :: ys) = show 1 ++ show x ++ show xs ++ show y ++ show ys
test1 0 [] [x] = "m1 " ++ show x
test1 2 (x :: xs) (y :: []) = "m2 " ++ show x ++ show xs ++ show y
test1 (S k) d t = "m3 " ++ let x = test1 k (show k :: d) t in x
test1 k d t = "m4 " ++ show k ++ show d ++ show t

data MyDat = A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8

Show MyDat where
   show A1 = "A1"
   show A2 = "A2"
   show A3 = "A3"
   show A4 = "A4"
   show A5 = "A5"
   show A6 = "A6"
   show A7 = "A7"
   show A8 = "A8"

ansiColorStr : String -> Vect 3 Int -> String
ansiColorStr str [r, g, b] = "\x1b[38;2;" ++ show r ++ ";" ++ show g ++ ";" ++ show b ++  "m" ++ str ++ "\x1b[0m"

namespace Either
   public export
   ignoreErr : (Show a) => IO (Either a b) -> IO b
   ignoreErr io =
      do
         (Right ok) <- io
            | Left err =>
                        do
                           putStrLn $ show err
                           exitFailure
         pure ok

namespace Maybe
   public export
   ignoreErr : IO (Maybe a) -> IO a
   ignoreErr io =
      do
         (Just ok) <- io
            | Nothing =>
                        do
                           putStrLn "Got nothing"
                           exitFailure
         pure ok

main : IO ()
main = do
   let aα = the Nat 5
   putStrLn $ show aα
   putStrLn $ test1 1 ["a", "b"] [2, 3, 4, 5]
   putStrLn $ test1 0 [] [6]
   putStrLn $ test1 2 ["c", "d", "e"] [1]
   putStrLn $ test1 3 ["p", "t"] [0]
   putStrLn $ test1 4 ["a"] [0, 1, 2, 3]
   putChar 'c'
   putChar 'b'
   putChar '\n'
   putStrLn $ show A1
   putStrLn $ show A8
   putStrLn $ show A6
   f <- ignoreErr $ openFile "data4.txt" Read
   putStrLn $ show !(fGetLine f)
   putStrLn $ show !(fEOF f)
   ignore $ fPutStrLn stdout "\x1b[38;2;255;100;0mThis is error\x1b[0m"
   ignore $ closeFile f
   ignore $ writeFile "data.txt" $ ansiColorStr "red\n" [255, 0, 0]
     ++ ansiColorStr "green\n" [0, 255, 0]
     ++ ansiColorStr "blue" [0, 0, 255]
   putStrLn $ show (the Int 257)
   putStrLn $ show !(ignoreErr $ readFile "data.txt")
   buf <- ignoreErr $ createBufferFromFile "data.txt"
   size <- rawSize buf
   putStrLn $ "buf size " ++ show size
   putStrLn $ "buf contents:\n" ++ !(getString buf 0 size)
   let i64s = 8
   ibuf <- ignoreErr $ newBuffer (i64s * 10)
   putStrLn $ "init size" ++ show !(rawSize ibuf)
   let list = [0..9]
   traverse_ (\i => do setInt ibuf (i64s * i) i;putStrLn $ "next size" ++ show !(rawSize ibuf)) list
   --setInt31 ibuf 114 (-991133)
   setInt ibuf 114 (-567)
   setDouble ibuf 122 (-241.123456789)
   setString ibuf 80 "hi there !"
   setString ibuf 90 "русский язык"
   dat2 <- ignoreErr $ openFile "data2.txt" WriteTruncate
   ignore $ writeBufferData dat2 ibuf 0 !(rawSize ibuf)
   putStrLn $ show $ !(getInt ibuf 0 )
   putStrLn $ show $ !(getInt ibuf 8 )
   putStrLn $ show $ !(getInt ibuf (8 * 9) )
   ignore $ closeFile dat2
   ibuf <- ignoreErr $ createBufferFromFile "data2.txt"
   putStrLn $ show $ !(getInt ibuf 0 )
   putStrLn $ show $ !(getInt ibuf 8 )
   putStrLn $ show $ !(getInt ibuf (8 * 9) )
   putStrLn $ show !(rawSize ibuf)
   putStrLn !(getString ibuf 80 10)
   putStrLn !(getString ibuf 90 24)
   putStrLn $ show !(getInt ibuf 114)
   putStrLn $ show !(getDouble ibuf 122)


module Graphics.Rendering.Gl

import Data.Fin
import Graphics.Util.Mesh
import Graphics.Util.Transforms
import public Graphics.Rendering.Gl.Types
import public Graphics.Rendering.Gl.Buffers
import public Graphics.Rendering.Gl.Gl41
import Data.Matrix
import Data.Vect
import Control.Algebra

%include C "GL/glew.h"
%include C "gl_idris.h"
%link C "gl_idris.o"

%access public export

-- GLEW

||| initialises the GL function pointers
export
glewInit : IO Int
glewInit = foreign FFI_C "idr_init_glew" (IO Int)

-- ----------------------------------------------------------------- [ Helpers ]

||| upload a list of doubles to the GPU into an array buffer
export
loadDoubleData : BufferUsageARB -> List Double -> IO ()
loadDoubleData usage data' = do
  ds <- sizeofDouble
  ptr <- doublesToBuffer data'
  glBufferData GL_ARRAY_BUFFER (ds * (cast $ length data')) ptr usage
  free ptr
  pure ()

toList' : Vect n (Vect m a) -> List a
toList' [] = []
toList' (x :: xs) = (toList x) ++ toList' xs

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

||| location of a texture on the GPU
export
record Texture where
  constructor MkTexture
  textureLocation: Int

||| locations of a shading program
export
record Shader where
  constructor MkShader
  ||| location of the shader program
  program: Int
  ||| locations of all shaders for this program. minimum of two shaders is required (vertex and fragment shader)
  shaders: Vect (S (S n)) Int

||| create a shader from a pair of a shader type an a string containing the shader source
createShader : (GLenum, String) -> IO Int
createShader (shaderType, shaderSource) = do
  shaderLoc <- glCreateShader shaderType
  glShaderSource shaderLoc 1 [shaderSource] [(cast $ length shaderSource)]
  glCompileShader shaderLoc
  pure shaderLoc

||| creates and returns a shader program
||| @ shaderSpec a list of pairs of shader type and shader source
export
createShaders : (shaderSpec: Vect (S (S n)) (GLenum, String)) -> IO Shader
createShaders shaderSpec = do
  locs <- traverse createShader shaderSpec
  programLoc <- glCreateProgram
  traverse (glAttachShader programLoc) locs
  glLinkProgram programLoc
  glUseProgram 0
  pure $ MkShader programLoc locs

||| deletes the shader program
export
deleteShaders : Shader -> IO ()
deleteShaders (MkShader programLoc shaderLocs) = do
  glUseProgram 0
  traverse (glDetachShader programLoc) shaderLocs
  traverse glDeleteShader shaderLocs
  glDeleteProgram programLoc
  pure ()

||| the model on the GPU
|||
||| the minumum information needed is the location of the vertex array object (VAO)
||| and the locations of the vertex buffer objects (VBO)
||| textures are optional
export
data Model : Type where
  ||| creates a textured model
  ||| @ vao the location of the vertex array object
  ||| @ vbos the locations of the vertex buffer objects
  ||| @ indices the number of indices
  ||| @ textures locations of the textures for the model
  TexturedModel : (vao: Int) ->
                  (vbos: Vect (S n) Int) ->
                  (indices: Int) ->
                  (textures: Vect m Texture) -> Model

||| creates a model from a mesh and some texture locations
||| @ m the mesh. should be uv unwrapped
||| @ textures texture locations we need to bind when using the model
export
createModel : (m: Mesh) -> (textures: (Vect n Texture)) -> IO Model
createModel (UvMesh positions normals uvs indices) textures = do
  (vaoLoc :: _) <- glGenVertexArrays 1

  glBindVertexArray vaoLoc
  (positionBuffer :: normalBuffer :: uvBuffer :: indexBuffer :: _) <- glGenBuffers 4

  glBindBuffer GL_ARRAY_BUFFER positionBuffer
  loadDoubleData GL_STATIC_DRAW (toList' positions)
  glEnableVertexAttribArray 0
  glVertexAttribPointer 0 3 GL_DOUBLE GL_FALSE 0 prim__null

  glBindBuffer GL_ARRAY_BUFFER normalBuffer
  loadDoubleData GL_STATIC_DRAW (toList' normals)
  glEnableVertexAttribArray 1
  glVertexAttribPointer 1 3 GL_DOUBLE GL_FALSE 0 prim__null

  glBindBuffer GL_ARRAY_BUFFER uvBuffer
  loadDoubleData GL_STATIC_DRAW (toList' uvs)
  glEnableVertexAttribArray 2
  glVertexAttribPointer 2 2 GL_DOUBLE GL_FALSE 0 prim__null

  is <- sizeofInt
  glBindBuffer GL_ELEMENT_ARRAY_BUFFER indexBuffer
  ptr <- intsToBuffer indices
  glBufferData GL_ELEMENT_ARRAY_BUFFER (is * (cast $ length indices)) ptr GL_STATIC_DRAW
  free ptr

  glDisableVertexAttribArray 2 -- uvs
  glDisableVertexAttribArray 1 -- normals
  glDisableVertexAttribArray 0 -- positions

  glBindVertexArray 0

  pure $ TexturedModel vaoLoc [positionBuffer, normalBuffer, uvBuffer, indexBuffer] (cast $ length indices) textures

export
deleteModel : Model -> IO ()
deleteModel (TexturedModel vao vbos _ _) = do
  glDisableVertexAttribArray 2 -- uvs
  glDisableVertexAttribArray 1 -- normals
  glDisableVertexAttribArray 0 -- positions

  glBindBuffer GL_ARRAY_BUFFER 0
  glBindBuffer GL_ELEMENT_ARRAY_BUFFER 0

  glDeleteBuffers (cast $ length vbos) $ toList vbos

  glBindVertexArray 0

  glDeleteVertexArrays 1 [vao]
  pure ()

||| data type for entities.
||| an entity is like an instance of a model. it consists of the model an instance
||| specific data like location, rotation, etc.
|||
export
data Entity : Type -> Type where
  ||| a simple entity: model, shader, texture and instance data
  ||| @ model the model ('class') of the entity
  ||| @ shader shader program to use
  ||| @ position 3D position of the entity
  ||| @ rotation 3D rotation of the entity
  ||| @ location uniform location of the transform matrix in the shader program
  ||| @ val arbtitrary data
  SimpleEntity :  (model: Model)
               -> (shader: Shader)
               -> (position: Vec3)
               -> (rotation: Vect 3 Angle)
               -> (location: Int)
               -> (val: a)
               -> Entity a

export
render : Entity a -> (prepare: a -> IO ()) -> IO ()
render (SimpleEntity (TexturedModel vao _ numIndices textures) (MkShader prog _) entityPosition rotation location val) prepare = do
  glBindVertexArray vao
  glEnableVertexAttribArray 0
  glEnableVertexAttribArray 1
  glEnableVertexAttribArray 2

  glUseProgram prog

  prepare val

  traverse (\t => glBindTexture GL_TEXTURE_2D (textureLocation t)) textures

  glDrawElements GL_TRIANGLES numIndices GL_UNSIGNED_INT prim__null

  glDisableVertexAttribArray 2 -- uvs
  glDisableVertexAttribArray 1 -- normals
  glDisableVertexAttribArray 0 -- positions

  glBindVertexArray 0
  pure ()

||| load a png file to the currently bound texture
export
glLoadPNGTexture : Int -> Int -> String -> IO Int
glLoadPNGTexture target level filename = foreign FFI_C "png_texture" (Int -> Int -> String -> IO Int) target level filename

export
loadTexture : String -> Fin 30 -> IO Texture
loadTexture filename index = do
  putStrLn $ "Loading " ++ filename ++ " to texture unit " ++ (show $ finToNat index)
  glActiveTexture (GL_TEXTURE0 + (cast $ finToNat index))
  (texture :: _) <- glGenTextures 1
  glBindTexture GL_TEXTURE_2D texture

  ret <- glLoadPNGTexture (toGlInt Graphics.Rendering.Gl.GL41.TextureTarget.GL_TEXTURE_2D) 0 filename

  -- the texture is bound ... so we can set some params
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR
  pure $ MkTexture texture

export
deleteTextures : List Texture -> IO ()
deleteTextures xs = glDeleteTextures (cast $ length xs) $ map textureLocation xs

-- ----------------------------------------------------------------- [ Helper ]

export
printShaderLog : Int -> IO ()
printShaderLog id = foreign FFI_C "printShaderLog" (Int -> IO()) id

export
glGetInfo : IO String
glGetInfo = do vendor   <- glGetString GL_VENDOR
               renderer <- glGetString GL_RENDERER
               version  <- glGetString GL_VERSION
               pure $ foldl1 (++) (the (List String) ["Vendor = ", vendor, "\nRenderer = ", renderer, "\nVersion = ", version, "\n"])


module Keybindings

import Effects
import Effect.SDL
import Effect.StdIO
import Effect.State
import Data.Fin

import Chip8
import Cpu
import Keypad
import Utilities

%default total

updateKeydown : (pressedKey : Fin 16) -> { [Chip8 ::: STATE Chip8] } Eff Bool
updateKeydown pressedKey =
  do
    chip <- Chip8 :- get
    case State chip of
      Active =>
        let keypad = setKeyPress (Keys chip) pressedKey in
        do
          Chip8 :- put (record { Keys = keypad } chip)
          pure True
      WaitingForKey r =>
        let keypad = setKeyPress (Keys chip) pressedKey in
        let cpu = setRegister (Computer chip) r $ cast pressedKey in
        do
          Chip8 :- put (record { State = Active, Keys = keypad, Computer = incrementPC cpu } chip)
          pure True
      Halted =>
        pure False

updateKeyup : (releasedKey : Fin 16) -> { [Chip8 ::: STATE Chip8] } Eff Bool
updateKeyup releasedKey =
  do
    chip <- Chip8 :- get
    case State chip of
      Active =>
        let keypad = clearKeyPress (Keys chip) releasedKey in
        do
          Chip8 :- put (record { Keys = keypad } chip)
          pure True
      WaitingForKey _ =>
        pure True
      Halted =>
        pure False

export
processKeys : Maybe Event -> { [Chip8 ::: STATE Chip8, STDIO] } Eff Bool
processKeys (Just (KeyDown $ KeyAny '1')) = updateKeydown 0x1
processKeys (Just (KeyUp   $ KeyAny '1')) = updateKeyup   0x1
processKeys (Just (KeyDown $ KeyAny '2')) = updateKeydown 0x2
processKeys (Just (KeyUp   $ KeyAny '2')) = updateKeyup   0x2
processKeys (Just (KeyDown $ KeyAny '3')) = updateKeydown 0x3
processKeys (Just (KeyUp   $ KeyAny '3')) = updateKeyup   0x3
processKeys (Just (KeyDown $ KeyAny '4')) = updateKeydown 0xc
processKeys (Just (KeyUp   $ KeyAny '4')) = updateKeyup   0xc
processKeys (Just (KeyDown $ KeyAny 'q')) = updateKeydown 0x4
processKeys (Just (KeyUp   $ KeyAny 'q')) = updateKeyup   0x4
processKeys (Just (KeyDown $ KeyAny 'w')) = updateKeydown 0x5
processKeys (Just (KeyUp   $ KeyAny 'w')) = updateKeyup   0x5
processKeys (Just (KeyDown $ KeyAny 'e')) = updateKeydown 0x6
processKeys (Just (KeyUp   $ KeyAny 'e')) = updateKeyup   0x6
processKeys (Just (KeyDown $ KeyAny 'r')) = updateKeydown 0xd
processKeys (Just (KeyUp   $ KeyAny 'r')) = updateKeyup   0xd
processKeys (Just (KeyDown $ KeyAny 'a')) = updateKeydown 0x7
processKeys (Just (KeyUp   $ KeyAny 'a')) = updateKeyup   0x7
processKeys (Just (KeyDown $ KeyAny 's')) = updateKeydown 0x8
processKeys (Just (KeyUp   $ KeyAny 's')) = updateKeyup   0x8
processKeys (Just (KeyDown $ KeyAny 'd')) = updateKeydown 0x9
processKeys (Just (KeyUp   $ KeyAny 'd')) = updateKeyup   0x9
processKeys (Just (KeyDown $ KeyAny 'f')) = updateKeydown 0xe
processKeys (Just (KeyUp   $ KeyAny 'f')) = updateKeyup   0xe
processKeys (Just (KeyDown $ KeyAny 'z')) = updateKeydown 0xa
processKeys (Just (KeyUp   $ KeyAny 'z')) = updateKeyup   0xa
processKeys (Just (KeyDown $ KeyAny 'x')) = updateKeydown 0x0
processKeys (Just (KeyUp   $ KeyAny 'x')) = updateKeyup   0x0
processKeys (Just (KeyDown $ KeyAny 'c')) = updateKeydown 0xb
processKeys (Just (KeyUp   $ KeyAny 'c')) = updateKeyup   0xb
processKeys (Just (KeyDown $ KeyAny 'v')) = updateKeydown 0xf
processKeys (Just (KeyUp   $ KeyAny 'v')) = updateKeyup   0xf
processKeys (Just (KeyDown KeyEsc)) = pure False
processKeys (Just AppQuit) =
  do
    chip <- Chip8 :- get
    case isHalted chip of
      Just error => do
        putStrLn $ "Chip8 halted. Reason: " ++ error
        pure False
      _ =>
        pure False
processKeys _ = pure True


module Compiler.LLVM.Rapid.String

import Data.Vect

import Compiler.LLVM.IR
import Compiler.LLVM.Instruction
import Compiler.LLVM.Rapid.Object
import Control.Codegen
import Data.Utils

public export
data CompareOp = LT | LTE | EQ | GTE | GT

export
getStringLength : IRValue IRObjPtr -> Codegen (IRValue I32)
getStringLength strObj = do
  strLenBytes <- getStringByteLength strObj
  call {t=I32} "ccc" "@utf8_bytes_to_codepoints" [toIR !(getObjectPayloadAddr {t=I8} strObj), toIR strLenBytes]

export
stringCompare : CompareOp -> IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
stringCompare op o1 o2 = do
  l1 <- getObjectSize o1
  l2 <- getObjectSize o2

  minLength <- mkZext {to=I64} !(mkMin l1 l2)

  lblSizeCompare <- genLabel "strcompare_size"
  lblCmpStart <- genLabel "strcompare_start"
  lblPrefixEq <- genLabel "strcompare_prefix_eq"
  lblPrefixNotEq <- genLabel "strcompare_prefix_neq"
  lblEnd <- genLabel "strcompare_end"

  jump lblSizeCompare
  beginLabel lblSizeCompare
  lengthsEqual <- icmp "eq" l1 l2

  let startCommand = case op of
                          EQ => (branch lengthsEqual lblCmpStart lblEnd)
                          _ => (branch (Const I1 1) lblCmpStart lblEnd)

  startCommand
  beginLabel lblCmpStart

  str1 <- getObjectPayloadAddr {t=I8} o1
  str2 <- getObjectPayloadAddr {t=I8} o2
  cmpResult32 <- call {t=I32} "fastcc" "@rapid.memcmp" [toIR str1, toIR str2, toIR minLength]
  cmpResult <- mkSext cmpResult32
  cmpResultIsEq <- icmp "eq" cmpResult (ConstI64 0)
  branch cmpResultIsEq lblPrefixEq lblPrefixNotEq

  beginLabel lblPrefixEq
  string1Shorter <- icmp "slt" l1 l2
  string1ShorterOrEqual <- icmp "sle" l1 l2
  string2Shorter <- icmp "slt" l2 l1
  string2ShorterOrEqual <- icmp "sle" l2 l1
  let result : IRValue I1
      result =  case op of
                     LT  => string1Shorter
                     LTE => string1ShorterOrEqual
                     EQ  => lengthsEqual
                     GTE => string2ShorterOrEqual
                     GT  => string2Shorter
  jump lblEnd

  beginLabel lblPrefixNotEq
  cmpResultIsLt <- icmp "slt" cmpResult (Const I64 0)
  cmpResultIsGt <- icmp "sgt" cmpResult (Const I64 0)
  let result2 =  case op of
                      LT  => cmpResultIsLt
                      LTE => cmpResultIsLt
                      EQ  => Const I1 0
                      GT  => cmpResultIsGt
                      GTE => cmpResultIsGt
  jump lblEnd
  beginLabel lblEnd

  finalResult <- phi [(result, lblPrefixEq), (result2, lblPrefixNotEq), (Const I1 0, lblSizeCompare)]
  cgMkInt !(mkZext finalResult)

export
stringEqual : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue I1)
stringEqual obj1 obj2 = do
  lblStart <- genLabel "strcompare_hdr"
  lblEnd <- genLabel "strcompare_end"
  lblCompareContents <- genLabel "strcompare_content"
  appendCode $ "br " ++ toIR lblStart
  beginLabel lblStart
  h1 <- getObjectHeader obj1
  h2 <- getObjectHeader obj2
  headersEqual <- icmp "eq" h1 h2
  appendCode $ "br " ++ toIR headersEqual ++ ", " ++ toIR lblCompareContents ++ ", " ++ toIR lblEnd
  beginLabel lblCompareContents
  str1 <- getObjectPayloadAddr {t=I8} obj1
  str2 <- getObjectPayloadAddr {t=I8} obj2
  length <- mkAnd h1 (ConstI64 0xffffffff)
  contentsEqual <- (SSA I1) <$> assignSSA ("call fastcc i1 @mem_eq(" ++ (showSep ", " ([toIR str1, toIR str2, toIR length])) ++ ")")
  appendCode $ "br " ++ toIR lblEnd
  beginLabel lblEnd
  phi [(headersEqual, lblStart), (contentsEqual, lblCompareContents)]

export
mkSubstring : IRValue IRObjPtr -> IRValue I64 -> IRValue I64 -> Codegen (IRValue IRObjPtr)
mkSubstring strObj startIndexRaw length = do
  length32 <- mkTrunc {to=I32} !(mkMax length (Const I64 0))
  strLenBytes <- getStringByteLength strObj

  startIndex <- mkTrunc {to=I32} !(mkMax startIndexRaw (Const I64 0))
  strPayloadStart <- getObjectPayloadAddr {t=I8} strObj

  startOffset <- call {t=I32} "ccc" "@utf8_codepoints_bytelen" [toIR strPayloadStart, toIR startIndex, toIR strLenBytes]
  startAddr <- getElementPtr strPayloadStart startOffset
  maxLengthBytes <- mkMax !(mkSub strLenBytes startOffset) (Const I32 0)
  resultLength <- call {t=I32} "ccc" "@utf8_codepoints_bytelen" [toIR startAddr, toIR length32, toIR maxLengthBytes]

  newStr <- dynamicAllocate !(mkZext resultLength)
  newHeader <- mkHeader OBJECT_TYPE_ID_STR resultLength
  putObjectHeader newStr newHeader
  newStrPayload <- getObjectPayloadAddr {t=I8} newStr

  voidCall "ccc" "@llvm.memcpy.p1i8.p1i8.i64" [toIR newStrPayload, toIR startAddr, toIR !(mkZext {to=I64} resultLength), toIR (Const I1 0)]
  pure newStr

export
stringHead : IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
stringHead o1 = do
  strLength <- getStringByteLength o1
  strIsZero <- unlikely !(icmp "eq" (Const I32 0) strLength)

  mkIf (pure strIsZero) (do
        appendCode $ "call ccc void @idris_rts_crash(i64 1) noreturn"
        appendCode $ "unreachable"
        pure nullPtr
        ) (do
        payload <- getObjectPayloadAddr {t=I8} o1
        firstChar <- call {t=I32} "ccc" "@utf8_decode1" [toIR payload]
        cgMkChar firstChar
        )

export
stringTail : IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
stringTail o1 = do
  strLength <- getStringLength o1
  strIsZero <- unlikely !(icmp "eq" strLength (Const I32 0))

  mkIf (pure strIsZero) (do
    appendCode $ "call ccc void @idris_rts_crash(i64 17) noreturn"
    appendCode $ "unreachable"
    pure nullPtr
    ) (do
    mkSubstring o1 (Const I64 1) !(mkSub !(mkZext strLength) (Const I64 1))
    )

export
stringAppend : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
stringAppend o1 o2 = do
  l1 <- getObjectSize o1
  l2 <- getObjectSize o2
  newLength <- mkAddNoWrap l1 l2
  newStr <- dynamicAllocate !(mkZext newLength)
  newHeader <- mkHeader OBJECT_TYPE_ID_STR newLength

  str1 <- getObjectPayloadAddr {t=I8} o1
  str2 <- getObjectPayloadAddr {t=I8} o2

  l1_64 <- mkZext {to=I64} l1
  l2_64 <- mkZext {to=I64} l2
  newStrPayload1 <- getObjectPayloadAddr {t=I8} newStr
  newStrPayload2 <- getElementPtr newStrPayload1 l1_64

  appendCode $ "  call void @llvm.memcpy.p1i8.p1i8.i64(" ++ toIR newStrPayload1 ++ ", " ++ toIR str1 ++ ", " ++ toIR l1_64 ++ ", i1 false)"
  appendCode $ "  call void @llvm.memcpy.p1i8.p1i8.i64(" ++ toIR newStrPayload2 ++ ", " ++ toIR str2 ++ ", " ++ toIR l2_64 ++ ", i1 false)"

  putObjectHeader newStr newHeader
  pure newStr

export
stringReverse : IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
stringReverse strObj = do
  length <- getObjectSize strObj
  newStr <- dynamicAllocate !(mkZext length)
  newHeader <- mkHeader OBJECT_TYPE_ID_STR length

  origPayload <- getObjectPayloadAddr {t=I8} strObj
  newStrPayload <- getObjectPayloadAddr {t=I8} newStr

  length64 <- mkZext {to=I64} length
  appendCode $ "  call ccc void @rapid_strreverse(" ++ toIR newStrPayload ++ ", " ++ toIR origPayload ++ ", " ++ toIR length64 ++ ")"

  putObjectHeader newStr newHeader
  pure newStr

export
stringCons : IRValue IRObjPtr -> IRValue IRObjPtr -> Codegen (IRValue IRObjPtr)
stringCons charObj strObj = do
  charVal32 <- unboxChar' charObj
  l32 <- getStringByteLength strObj
  -- maximum length of one codepoint in UTF-8 is 4 bytes
  newLength <- mkAddNoWrap (Const I32 4) l32
  newStr <- dynamicAllocate !(mkZext newLength)
  putObjectHeader newStr !(mkHeader OBJECT_TYPE_ID_STR newLength)

  str2 <- getObjectPayloadAddr {t=I8} strObj

  newStrPayload1 <- getObjectPayloadAddr {t=I8} newStr

  charLength <- call {t=I32} "ccc" "@utf8_encode1" [toIR newStrPayload1, toIR charVal32]

  newStrPayload2 <- getElementPtr newStrPayload1 charLength
  appendCode $ "  call void @llvm.memcpy.p1i8.p1i8.i64(" ++ toIR newStrPayload2 ++ ", " ++ toIR str2 ++ ", " ++ toIR !(mkZext {to=I64} l32) ++ ", i1 false)"
  realNewLength <- mkAddNoWrap charLength l32
  putObjectHeader newStr !(mkHeader OBJECT_TYPE_ID_STR realNewLength)
  pure newStr


module Data.Compress.GZip

import Data.Compress.Utils.Parser
import Data.Compress.Utils.Bytes
import Data.Compress.Utils.Misc
import Data.Compress.Interface
import Data.Vect
import Data.Bits
import Data.List
import Data.SnocList
import Data.Stream
import Data.Compress.CRC
import Control.Monad.Error.Either

import public Data.Compress.Inflate

public export
data GZipParserState'
  = GZipHead
  | GZipFoot
  | GZipInflate

public export
data GZipParserState : GZipParserState' -> Type where
  AtGHeader : GZipParserState GZipHead
  AtInflate : (isize : Bits32) -> (crc32 : Bits32) -> InflateState -> GZipParserState GZipInflate
  AtGFooter : (isize : Bits32) -> (crc32 : Bits32) -> GZipParserState GZipFoot

public export
data GZipState
  = MkState (List Bits8) (DPair GZipParserState' GZipParserState)

nul_term_string : Semigroup e => Parser (List Bits8) e String
nul_term_string = map ascii_to_string $ take_until (0 ==) token

record GZipFooter where
  constructor MkGZipFooter
  crc32 : Bits32
  isize : Bits32

export
parse_gzip_header : Parser (List Bits8) (SimpleError String) ()
parse_gzip_header = do
  [0x1f, 0x8b] <- count 2 token
  | x => fail $ msg "gzip magic number expected, got \{show x}"
  0x08 <- token
  | x => fail $ msg "deflate method magic number expected, got \{show x}"
  flag <- token
  mtime <- count 4 token
  xfl <- token
  os <- token

  fextra <- ifA (testBit flag 2) $ do
    xlen <- p_nat 2
    toList <$> count xlen token

  fname <- ifA (testBit flag 3) nul_term_string

  fcomment <- ifA (testBit flag 4) nul_term_string

  fhcrc <- ifA (testBit flag 1) (count 2 token)

  pure ()

export
parse_gzip_footer : Parser (List Bits8) (SimpleError String) GZipFooter
parse_gzip_footer = do
  crc32 <- cast <$> p_nat 4
  isize <- cast <$> p_nat 4
  pure (MkGZipFooter crc32 isize)

feed_gzip' : SnocList Bits8 -> DPair GZipParserState' GZipParserState -> List Bits8 -> Either String (SnocList Bits8, GZipState)
feed_gzip' acc (_ ** AtGHeader) [] = Right (acc, MkState [] (_ ** AtGHeader))
feed_gzip' acc (_ ** AtGHeader) content =
  case feed content parse_gzip_header of
    Pure leftover header => feed_gzip' acc (_ ** AtInflate 0 0 init) leftover
    Fail err => Left $ show err
    _ => Right (acc, MkState content (_ ** AtGHeader))
feed_gzip' acc (_ ** AtInflate isize crc32 inflate_state) content =
  case feed inflate_state content of
    Left err => Left err
    Right (uncompressed, (MkState _ _ (_ ** AtEnd leftover))) =>
      let isize = isize + (cast $ length uncompressed)
          crc32 = update_crc32 crc32 uncompressed
      in feed_gzip' (acc <>< uncompressed) (_ ** AtGFooter isize crc32) (toList leftover)
    Right (uncompressed, inflate_state) => -- underfed
      let isize = isize + (cast $ length uncompressed)
          crc32 = update_crc32 crc32 uncompressed
      in Right (acc <>< uncompressed, MkState [] (_ ** AtInflate isize crc32 inflate_state))
feed_gzip' acc (_ ** AtGFooter isize crc32) content =
  case feed content parse_gzip_footer of
    Pure leftover footer =>
      if footer.crc32 /= crc32 then Left "crc32 mismatch"
        else if footer.isize /= isize then Left "isize mismatch"
        else feed_gzip' acc (_ ** AtGHeader) leftover
    Fail err => Left $ show err
    _ => Right (acc, MkState content (_ ** AtGFooter isize crc32))

export
Decompressor GZipState where
  feed (MkState leftover state) input = mapFst toList <$> feed_gzip' Lin state (leftover <+> input)
  done (MkState [] (_ ** AtGHeader)) = Right []
  done (MkState _ (_ ** AtGHeader)) = Left "gzip: leftover data after header"
  done _ = Left "gzip: underfed"
  init = MkState [] (_ ** AtGHeader)


import Control.Monad.State
import Data.List
import Data.String
import Data.MSF.Trans
import Generics.Derive
import JSON
import Rhone.JS
import Web.Html

%default total
%language ElabReflection

record Item where
  constructor MkI
  id   : Nat
  todo : String
  done : Bool

%runElab derive "Item" [Generic,Meta,Eq,FromJSON,ToJSON]

data Ev = New | Clear | Mark Bool | Hash
        | Edit Nat | Abort Nat | Delete Nat | Upd Nat | Toggle Nat Bool

%runElab derive "Ev" [Generic,Eq]

new : ElemRef HTMLInputElement
new = Id Input "new-todo"

liId : Nat -> ElemRef HTMLLIElement
liId n = Id Li "item_\{show n}"

editId : Nat -> ElemRef HTMLInputElement
editId n = Id Input "edit_\{show n}"

itemView : Item -> Node Ev
itemView (MkI n lbl done) =
  li [ ref (liId n), class (if done then "completed" else "") ]
     [ div [ class "view" ]
           [ input [ class "toggle", type CheckBox, checked done
                   , onChecked (Toggle n) ] []
           , label [ onDblClick (Edit n) ] [ Text lbl ]
           , button [ class "destroy", onClick (Delete n) ] [] ]
     , input [ ref (editId n), class "edit", value lbl
             , onEnterDown (Upd n), onEscDown (Abort n), onBlur (Upd n) ] [] ]

ST : Type
ST = List Item

newId : MonadState ST m => MSF m i Nat
newId = get >>^ (maybe 0 (S . id) . getAt 0)

mod : MonadState ST m => (i -> ST -> ST) -> MSF m i ()
mod f = arr f >>! modify

modAt : MonadState ST m => (i -> Item -> Item) -> MSF m (NP I [Nat,i]) ()
modAt f = mod $ \[n,v] => map (\t => if t.id == n then f v t else t)

newVal : LiftJSIO m => MSF m i (Event String)
newVal = valueOf new >>> runEffect (setValue new "") >>> trim ^>> isNot ""

countStr : Nat -> String
countStr 1 = "1 item left"
countStr k = "\{show k} items left"

items : NP I [List Item, String] -> List (Node Ev)
items [is,"#/active"]    = map itemView . filter (not . done) $ reverse is
items [is,"#/completed"] = map itemView . filter done $ reverse is
items [is,_]             = map itemView $ reverse is

disp : MSF (StateT ST $ DomIO Ev JSIO) i ()
disp = get >>> fan
  [ fan [id, windowHash] >>> arr items >>! innerHtmlAtN (Id Ul "todo-list")
  , isNil ^>- [hiddenAt (Id Section "main"), hiddenAt (Id Footer "footer")]
  , all done ^>> isChecked (Id Input "toggle-all")
  , (not . any done) ^>> hiddenAt (Id Button "clear-completed")
  , count (not . done) ^>> countStr ^>> innerHtml (Id Span "todo-count")
  , encode ^>> setItemAt "todomvc-idris2" ]
  >>> windowHash >>-
        [ ifIs "#/active"    "selected" >>> classAt (Id A "sel-active")
        , ifIs "#/completed" "selected" >>> classAt (Id A "sel-completed")
        , ifIs "#/"          "selected" >>> classAt (Id A "sel-all") ]

update : MSF (StateT ST $ DomIO Ev JSIO) (NP I [Nat,String]) ()
update = bool (\[_,s] => null s) >>> collect
           [ mod (\[i,_] => filter $ (/= i) . id)
           , modAt (\s => {todo := s}) ]

controller : MSF (StateT ST $ DomIO Ev JSIO) Ev ()
controller = (toI . unSOP . from) ^>> collect
  [ newVal ?>> [| MkI newId id (pure False) |] >>> mod (::) >>> disp
  , mod (\_ => filter $ not . done) >>> disp
  , mod (\[b] => map {done := b}) >>> disp
  , disp
  , fan [ hd >>^ liId, const "editing" ] >>> attribute_ "class"
  , disp
  , mod (\[i] => filter $ (/= i) . id) >>> disp
  , hd >>> fan [id, editId ^>> value >>^ trim] >>> update >>> disp
  , modAt (\b => {done := b}) >>> disp ]

ui : DomIO Ev JSIO (MSF (DomIO Ev JSIO) Ev (), JSIO ())
ui =  do
  setAttribute new (onEnterDown New)
  setAttribute (Id Button "clear-completed") (onClick Clear)
  setAttribute (Id Input "toggle-all") (onChecked Mark)
  handleEvent Window (HashChange Hash)
  ini <- liftJSIO (window >>= localStorage >>= (`getItem` "todomvc-idris2"))
  pure (loopState (fromMaybe Nil $ ini >>= decodeMaybe) controller, pure ())

main : IO ()
main = runJS . ignore $ reactimateDomIni Hash "todo" ui