module Lens.Util

import Data.List
import Data.Maybe
import Lens
import Lens.Uninhabited
import Map

%default total

public export
beq_prim : (v : PrimitiveValue) ->  v == v = True
beq_prim (Boolean b) = beq_bool b
beq_prim (Number n) = beq_nat n
beq_prim (Text t) = beq_str t

public export
beq_prim2 : (v1, v2 : PrimitiveValue) -> (v1 == v2 = True) -> v1 = v2
beq_prim2 (Boolean x) (Boolean y) prf = rewrite eq_bool x y prf in Refl
beq_prim2 (Boolean _) (Number _) Refl impossible
beq_prim2 (Boolean _) (Text _) Refl impossible
beq_prim2 (Number _) (Boolean _) Refl impossible
beq_prim2 (Number k) (Number j) prf = rewrite eq_nat k j prf in Refl
beq_prim2 (Number _) (Text _) Refl impossible
beq_prim2 (Text _) (Boolean _) Refl impossible
beq_prim2 (Text _) (Number _) Refl impossible
beq_prim2 (Text xs) (Text ys) prf = rewrite eq_str xs ys prf in Refl

public export
neq_prim : (v1, v2 : PrimitiveValue) -> (v1 == v2 = False) -> Not (v1 = v2)
neq_prim (Boolean x) (Boolean y) prf =
    neq_bool x y prf . justInjective . cong boolean
neq_prim (Boolean x) (Number k) prf = uninhabited
neq_prim (Boolean x) (Text xs) prf = uninhabited
neq_prim (Number k) (Boolean x) prf = uninhabited
neq_prim (Number k) (Number j) prf =
    neq_nat k j prf . justInjective . cong number
neq_prim (Number k) (Text xs) prf = uninhabited
neq_prim (Text xs) (Boolean x) prf = uninhabited
neq_prim (Text xs) (Number k) prf = uninhabited
neq_prim (Text xs) (Text ys) prf =
    neq_str xs ys prf . justInjective . cong text

beq_prim_kind : (k1, k2 : PrimitiveKind) -> (k1 == k2 = True) ->  k1 = k2
beq_prim_kind KBoolean KBoolean prf = Refl
beq_prim_kind KBoolean KNumber Refl impossible
beq_prim_kind KBoolean KText Refl impossible
beq_prim_kind KNumber KBoolean Refl impossible
beq_prim_kind KNumber KNumber prf = Refl
beq_prim_kind KNumber KText Refl impossible
beq_prim_kind KText KBoolean Refl impossible
beq_prim_kind KText KNumber Refl impossible
beq_prim_kind KText KText prf = Refl

public export
validate_properties_after_insert : (vm : Map Value) -> (sm : Map Schema) ->
    (k : Key) -> (v : Value) -> (s : Schema) -> validate s v = True ->
    validate_properties vm sm = True -> validate_properties (insert k v vm) (insert k s sm) = True

public export
validate_properties_after_remove : (vm : Map Value) -> (sm : Map Schema) -> (k : Key) ->
    validate_properties vm sm = True -> validate_properties (remove k vm) (remove k sm) = True

public export
invalid_property : (vm : Map Value) -> (sm : Map Schema) -> (k : Key) ->
    (v : Value) -> (s : Schema) -> get k vm = Just v -> get k sm = Just s -> validate s v = False ->
    validate_properties vm sm = False

public export
still_valid : (vm : Map Value) -> (sm : Map Schema) ->
    (k : Key) -> (kvm : Value) -> (ksm : Schema) ->
    get k vm = Just kvm -> get k sm = Just ksm ->
    validate_properties vm sm = True -> validate ksm kvm = True

public export
still_invalid : (vm : Map Value) -> (sm : Map Schema) ->
    (k : Key) ->  get k vm = Just kvm -> get k sm = Just ksm ->
    validate ksm kvm = False -> validate_properties vm sm = False

public export
flip_map_twice : (m : List (PrimitiveValue, PrimitiveValue)) -> flip_map (flip_map m) = m
flip_map_twice [] = Refl
flip_map_twice ((x, y) :: xs) = rewrite flip_map_twice xs in Refl

public export
flip_map_preserves_validity : (a, b : PrimitiveKind) -> (m : List (PrimitiveValue, PrimitiveValue)) ->
    validate_map a b m = True -> validate_map b a (flip_map m) = True
flip_map_preserves_validity a b [] prf = Refl
flip_map_preserves_validity a b ((x, y) :: xs) prf =
    let sprf = and_split (prim_kind_of x == a) (prim_kind_of y == b && Delay (validate_map a b xs)) prf
        sprf2 = and_split (prim_kind_of y == b) (validate_map a b xs) (snd sprf)
        ind = flip_map_preserves_validity a b xs (snd sprf2)
    in rewrite fst sprf2 in rewrite fst sprf in ind

validate_map_kind_a : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) -> (va : PrimitiveValue) ->
    (va, vb) :: _ = m -> validate_map a b m = True -> prim_kind_of va = a
validate_map_kind_a [] _ _ _ Refl _ impossible
validate_map_kind_a ((va, vb) :: m) KBoolean b (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == KBoolean) (prim_kind_of vb == b && validate_map KBoolean b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KBoolean (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KBoolean b (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == KBoolean) (prim_kind_of vb == b && validate_map KBoolean b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KBoolean (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KNumber b (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == KNumber) (prim_kind_of vb == b && validate_map KNumber b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KNumber (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KNumber b (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == KNumber) (prim_kind_of vb == b && validate_map KNumber b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KNumber (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KText b (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == KText) (prim_kind_of vb == b && validate_map KText b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KText (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((va, vb) :: m) KText b (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == KText) (prim_kind_of vb == b && validate_map KText b m) prf1
        xeq = cong prim_kind_of $ cong fst $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of va) KText (fst split)
    in absurd $ trans xeq xeq2
validate_map_kind_a ((_, _) :: _) KBoolean _ (Boolean _) prf prf1 = Refl
validate_map_kind_a ((_, _) :: _) KNumber _ (Number _) prf prf1 = Refl
validate_map_kind_a ((_, _) :: _) KText _ (Text _) prf prf1 = Refl

validate_map_kind_b : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) -> (vb : PrimitiveValue) ->
    (va, vb) :: _ = m -> validate_map a b m = True -> prim_kind_of vb = b
validate_map_kind_b [] _ _ _ Refl _ impossible
validate_map_kind_b ((va, vb) :: m) a KBoolean (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KBoolean && validate_map a KBoolean m) prf1
        split2 = and_split (prim_kind_of vb == KBoolean) (validate_map a KBoolean m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KBoolean (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KBoolean (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KBoolean && validate_map a KBoolean m) prf1
        split2 = and_split (prim_kind_of vb == KBoolean) (validate_map a KBoolean m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KBoolean (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KNumber (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KNumber && validate_map a KNumber m) prf1
        split2 = and_split (prim_kind_of vb == KNumber) (validate_map a KNumber m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KNumber (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KNumber (Text _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KNumber && validate_map a KNumber m) prf1
        split2 = and_split (prim_kind_of vb == KNumber) (validate_map a KNumber m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KNumber (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KText (Boolean _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KText && validate_map a KText m) prf1
        split2 = and_split (prim_kind_of vb == KText) (validate_map a KText m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KText (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) a KText (Number _) prf prf1 =
    let split = and_split (prim_kind_of va == a) (prim_kind_of vb == KText && validate_map a KText m) prf1
        split2 = and_split (prim_kind_of vb == KText) (validate_map a KText m) (snd split)
        xeq = cong prim_kind_of $ cong snd $ fst $ consInjective prf
        xeq2 = beq_prim_kind (prim_kind_of vb) KText (fst split2)
    in absurd $ trans xeq xeq2
validate_map_kind_b ((va, vb) :: m) _ KBoolean (Boolean _) prf prf1 = Refl
validate_map_kind_b ((va, vb) :: m) _ KNumber (Number _) prf prf1 = Refl
validate_map_kind_b ((va, vb) :: m) _ KText (Text _) prf prf1 = Refl

validate_map_kind : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) ->
    (va, vb : PrimitiveValue) -> (va, vb) :: _ = m -> validate_map a b m = True ->
    (prim_kind_of va = a, prim_kind_of vb = b)
validate_map_kind m a b va vb prf prf1 =
    let pa = validate_map_kind_a m a b va prf prf1
        pb = validate_map_kind_b m a b vb prf prf1
    in (pa, pb)

map_still_valid : (m : List (PrimitiveValue, PrimitiveValue)) -> (a, b : PrimitiveKind) ->
    (x :: xs) = m -> validate_map a b m = True -> validate_map a b xs = True
map_still_valid [] _ _ Refl _ impossible
map_still_valid ((va, vb) :: m) a b prf prf1 with (prim_kind_of va == a, prim_kind_of vb == b) proof prf2
    map_still_valid ((va, vb) :: m) a b prf prf1 | (False, _) =
        let split = and_split (prim_kind_of va == a) (prim_kind_of vb == b && validate_map a b m) prf1
        in absurd $ trans (sym $ cong fst prf2) (fst split)
    map_still_valid ((va, vb) :: m) a b prf prf1 | (True, False) =
        let split = and_split (prim_kind_of va == a) (prim_kind_of vb == b && validate_map a b m) prf1
            split2 = and_split (prim_kind_of vb == b) (validate_map a b m) (snd split)
        in absurd $ trans (sym $ cong snd prf2) (fst split2)
    map_still_valid ((va, vb) :: m) a b prf prf1 | (True, True) =
        let split = and_split (prim_kind_of va == a) (prim_kind_of vb == b && validate_map a b m) prf1
            split2 = and_split (prim_kind_of vb == b) (validate_map a b m) (snd split)
        in rewrite snd $ consInjective prf in snd split2

public export
convert_prim_kind : (m : List (PrimitiveValue, PrimitiveValue)) ->
    (a, b : PrimitiveKind) -> (va, vb : PrimitiveValue) ->
    validate_map a b m = True -> prim_kind_of va = a ->
    convert_prim va m = Just vb -> prim_kind_of vb = b
convert_prim_kind [] _ _ _ _ _ _ Refl impossible
convert_prim_kind ((va', vb') :: m) a b va vb prf prf1 prf2 with (va == va') proof prf3
    convert_prim_kind ((va', vb') :: m) a b va vb prf prf1 prf2 | True =
        rewrite sym $ justInjective prf2 in
            snd $ validate_map_kind ((va', vb') :: m) a b va' vb' Refl prf
    convert_prim_kind ((va', vb') :: m) a b va vb prf prf1 prf2 | False =
        let sv = map_still_valid ((va', vb') :: m) a b Refl prf
            ind = convert_prim_kind m a b va vb sv prf1 prf2
        in ind


module Text.Show.PrettyVal

import Data.List
import Data.List1
import Data.Vect
import Text.Show.Value
import Text.Lexer

import Generics.Derive
import System.Clock
import System.File

%language ElabReflection

public export total
PName : Type
PName = Text.Show.Value.Name

||| A class for types that may be reified into a value.
||| Instances of this class may be derived automatically,
||| for datatypes that support `Generics`.
public export
interface PrettyVal a where
  constructor MkPrettyVal
  prettyVal : a -> Value

--------------------------------------------------------------------------------
--          Generics
--------------------------------------------------------------------------------

-- Displays an applied constructer in record syntax.
-- This is called, if all arguments have user-defined names.
rec : PName -> NP (K Value) ks -> NP (K String) ks -> Value
rec con vs ns = Rec con (collapseNP $ hliftA2 named vs ns)
  where named : Value -> String -> (PName,Value)
        named v name = (MkName name, v)

-- Displays an applied constructer with unnamed arguments.
other : PName -> NP (K Value) ks -> Value
other con = Con con . collapseNP

-- Displays a single applied constructor
valC : NP (PrettyVal . f) ks => ConInfo ks -> NP f ks -> Value
valC info args =
  let con   = MkName (wrapOperator info.conName)
      names = argNames info
      vals  = hcmap (PrettyVal . f) prettyVal args
      val   = maybe (other con vals) (rec con vals) names
   in case vals of
        []    => Con con []
        [a,b] => if isOperator info.conName
                    then binOp (MkName info.conName) a b
                    else val
        _     => val

prettySOP :  (all : POP (PrettyVal . f) kss)
          => TypeInfo kss -> SOP f kss -> Value
prettySOP {all = MkPOP _} (MkTypeInfo _ _ cons) =
  collapseNS . hcliftA2 (NP $ PrettyVal . f) valC cons . unSOP

||| Generic version of `prettyVal`.
public export total
genPrettyVal : Meta t code => POP PrettyVal code => t -> Value
genPrettyVal = prettySOP (metaFor t) . from

--------------------------------------------------------------------------------
--          Auto Deriving
--------------------------------------------------------------------------------

namespace Derive

  ||| Derives a `PrettyVal` implementation for the given data type
  ||| and visibility.
  export total
  PrettyValVis : Visibility -> DeriveUtil -> InterfaceImpl
  PrettyValVis vis g = MkInterfaceImpl "PrettyVal" vis []
                         `(MkPrettyVal genPrettyVal)
                         (implementationType `(PrettyVal) g)

  ||| Alias for `PrettyValVis Public`.
  export total
  PrettyVal : DeriveUtil -> InterfaceImpl
  PrettyVal = PrettyValVis Public

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

public export
PrettyVal Value where
  prettyVal v = v

public export
PrettyVal () where
  prettyVal _ = Con "()" []

public export
PrettyVal Bits8 where
  prettyVal = Natural . show

public export
PrettyVal Bits16 where
  prettyVal = Natural . show

public export
PrettyVal Bits32 where
  prettyVal = Natural . show

public export
PrettyVal Bits64 where
  prettyVal = Natural . show

public export
PrettyVal Nat where
  prettyVal = Natural . show

mkNum :  (Ord a, Neg a, Num a, Show a)
      => (String -> Value) -> a -> Value
mkNum c x = if x >= 0 then c (show x)
                      else Neg . c . show $ negate x

public export
PrettyVal Int where
  prettyVal = mkNum Natural

public export
PrettyVal Int8 where
  prettyVal = mkNum Natural

public export
PrettyVal Int16 where
  prettyVal = mkNum Natural

public export
PrettyVal Int32 where
  prettyVal = mkNum Natural

public export
PrettyVal Int64 where
  prettyVal = mkNum Natural

public export
PrettyVal Integer where
  prettyVal = mkNum Natural

public export
PrettyVal Double where
  prettyVal = mkNum Dbl

public export
PrettyVal Char where
  prettyVal = Chr . show

public export
PrettyVal String where
  prettyVal = Str

public export
PrettyVal a => PrettyVal (List a) where
  prettyVal = Lst . map prettyVal

public export
PrettyVal a => PrettyVal (Vect n a) where
  prettyVal = Lst . toList . map prettyVal

public export
(PrettyVal a, PrettyVal b) => PrettyVal (a,b) where
  prettyVal (a,b) = case prettyVal b of
                         Tuple v1 v2 vs => Tuple (prettyVal a) v1 (v2 :: vs)
                         val            => Tuple (prettyVal a) val []

public export
NP (PrettyVal . f) ks => PrettyVal (NP_ k f ks) where
  prettyVal np = Lst . collapseNP $ hcmap (PrettyVal . f) prettyVal np

public export
NP (PrettyVal . f) ks => PrettyVal (NS_ k f ks) where
  prettyVal ns = run $ hcmap (PrettyVal . f) prettyVal ns
    where run : NS_ k (K Value) xs -> Value
          run (Z v) = Con "Z" [v]
          run (S x) = Con "S" [run x]

public export
POP (PrettyVal . f) kss => PrettyVal (POP_ k f kss) where
  prettyVal (MkPOP nps) = Con "MkPOP" [prettyVal nps]

public export
POP (PrettyVal . f) kss => PrettyVal (SOP_ k f kss) where
  prettyVal (MkSOP nss) = Con "MkSOP" [prettyVal nss]

%runElab derive "Bool" [PrettyVal]

%runElab derive "Ordering" [PrettyVal]

%runElab derive "Maybe" [PrettyVal]

%runElab derive "Either" [PrettyVal]

%runElab derive "List1" [PrettyVal]

%runElab derive "Prec" [PrettyVal]

-- System

%runElab derive "Mode" [PrettyVal]

%runElab derive "FileError" [PrettyVal]

%runElab derive "FileMode" [PrettyVal]

%runElab derive "Permissions" [PrettyVal]

%runElab derive "ClockType" [PrettyVal]

-- Reflection

%runElab derive "ModuleIdent" [PrettyVal]

%runElab derive "VirtualIdent" [PrettyVal]

%runElab derive "OriginDesc" [PrettyVal]

%runElab derive "FC" [PrettyVal]

%runElab derive "NameType" [PrettyVal]

%runElab derive "Constant" [PrettyVal]

%runElab derive "Namespace" [PrettyVal]

%runElab derive "UserName" [PrettyVal]

%runElab derive "Language.Reflection.TT.Name" [PrettyVal]

%runElab derive "NoMangleDirective" [PrettyVal]

%runElab derive "Count" [PrettyVal]

%runElab derive "PiInfo" [PrettyVal]

%runElab derive "LazyReason" [PrettyVal]

%runElab derive "TotalReq" [PrettyVal]

%runElab derive "Visibility" [PrettyVal]

%runElab derive "BindMode" [PrettyVal]

%runElab derive "UseSide" [PrettyVal]

%runElab derive "DotReason" [PrettyVal]

%runElab derive "DataOpt" [PrettyVal]

%runElab derive "WithFlag" [PrettyVal]

%runElab derive "BuiltinType" [PrettyVal]

%runElab deriveMutual [ ("TTImp",        [PrettyVal])
                      , ("IField",       [PrettyVal])
                      , ("IFieldUpdate", [PrettyVal])
                      , ("AltType",      [PrettyVal])
                      , ("FnOpt",        [PrettyVal])
                      , ("ITy",          [PrettyVal])
                      , ("Data",         [PrettyVal])
                      , ("Record",       [PrettyVal])
                      , ("Clause",       [PrettyVal])
                      , ("Decl",         [PrettyVal])
                      ]

-- Pretty

%runElab derive "ShowToken" [PrettyVal]

%runElab derive "Bounds" [Generic, Meta, PrettyVal]

%runElab derive "WithBounds" [Generic, Meta, PrettyVal]

%runElab derive "Err" [PrettyVal]


module LightClick.IR.Channel.Normalise.FreshBinders

import Data.List
import Data.Vect

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

import LightClick.Types
import LightClick.Terms

import LightClick.IR.ModuleCentric
import LightClick.IR.ChannelCentric

import LightClick.IR.Channel.Normalise.Error
import LightClick.IR.Channel.Normalise.LetFloat

%default total

createModuleBinders : (state : List String)
                   -> (counter : Nat)
                   -> (expr  : ChannelIR type)
                            -> ChannelIR type
createModuleBinders state counter (CLet bind this inThis)
  = CLet bind this $ createModuleBinders (bind::state) counter inThis

createModuleBinders state counter (CSeq (CModuleInst mname xs) y)
  = CLet ("lightclick_module_" <+> show counter)
         (CModuleInst mname xs)
         (createModuleBinders state (S counter) y)

createModuleBinders state counter (CSeq (CNot o i) y)
  = CLet ("lightclick_module_" <+> show counter)
         (CNot o i)
         (createModuleBinders state (S counter) y)

createModuleBinders state counter (CSeq (CGate ty o ins) y)
  = CLet ("lightclick_module_" <+> show counter)
         (CGate ty o ins)
         (createModuleBinders state (S counter) y)

createModuleBinders state counter (CSeq x y)
  = CSeq (createModuleBinders state counter x) y

createModuleBinders state counter expr = expr

export
covering
freshBinders : (expr : ChannelIR type)
                    -> Normalise (ChannelIR type)
freshBinders expr
  = runLetFloat (createModuleBinders Nil Z expr)

-- [ EOF ]


module Idris.Desugar.Mutual

import Idris.Syntax

%default total

-- Get the declaration to process on each pass of a mutual block
-- Essentially: types on the first pass
--  i.e. type constructors of data declarations
--       function types
--       interfaces (in full, since it includes function types)
--       records (just the generated type constructor)
--       implementation headers (i.e. note their existence, but not the bodies)
-- Everything else on the second pass
getDecl : Pass -> PDecl -> Maybe PDecl
getDecl p (PImplementation fc vis opts _ is cons n ps iname nusing ds)
    = Just (PImplementation fc vis opts p is cons n ps iname nusing ds)

getDecl p (PNamespace fc ns ds)
    = Just (PNamespace fc ns (assert_total $ mapMaybe (getDecl p) ds))

getDecl AsType d@(PClaim _ _ _ _ _) = Just d
getDecl AsType (PData fc doc vis mbtot (MkPData dfc tyn tyc _ _))
    = Just (PData fc doc vis mbtot (MkPLater dfc tyn tyc))
getDecl AsType d@(PInterface _ _ _ _ _ _ _ _ _) = Just d
getDecl AsType d@(PRecord fc doc vis mbtot n ps _ _)
    = Just (PData fc doc vis mbtot (MkPLater fc n (mkRecType ps)))
  where
    mkRecType : List (Name, RigCount, PiInfo PTerm, PTerm) -> PTerm
    mkRecType [] = PType fc
    mkRecType ((n, c, p, t) :: ts) = PPi fc c p (Just n) t (mkRecType ts)
getDecl AsType d@(PFixity _ _ _ _) = Just d
getDecl AsType d@(PDirective _ _) = Just d
getDecl AsType d = Nothing

getDecl AsDef (PClaim _ _ _ _ _) = Nothing
getDecl AsDef d@(PData _ _ _ _ (MkPLater _ _ _)) = Just d
getDecl AsDef (PInterface _ _ _ _ _ _ _ _ _) = Nothing
getDecl AsDef d@(PRecord _ _ _ _ _ _ _ _) = Just d
getDecl AsDef (PFixity _ _ _ _) = Nothing
getDecl AsDef (PDirective _ _) = Nothing
getDecl AsDef d = Just d

getDecl p (PParameters fc ps pds)
    = Just (PParameters fc ps (assert_total $ mapMaybe (getDecl p) pds))
getDecl p (PUsing fc ps pds)
    = Just (PUsing fc ps (assert_total $ mapMaybe (getDecl p) pds))

getDecl Single d = Just d

export
splitMutual : List PDecl -> (List PDecl, List PDecl)
splitMutual ds = (mapMaybe (getDecl AsType) ds, mapMaybe (getDecl AsDef) ds)


-- Reads Runtime Length Encoded files
-- containing a Game of Life
module Conway.RLE

import Conway.Conway

-- map all uppercase to lowercase
lower : (List String) -> (List String)
lower = map toLower

-- Remove whitespace
removeWS : (List String) -> (List String)
removeWS = map (\s => pack $ filter (\c => not $ isSpace c) (unpack s))

-- Remove Comments from RLE
removeComments : (List String) -> (List String)
removeComments = filter (\s => not $ isEmptyOrComment $ unpack s)
  where isEmptyOrComment : List Char -> Bool
        isEmptyOrComment [] = True
        isEmptyOrComment (x::xs) = x == '#'

compress : (List String) -> (List String)
compress [] = []
compress (x::xs) = x::[concat xs]

-- Functions for Parsing a String into an Int
charToInt : Char -> Maybe Int
charToInt c = let i = cast {to=Int} c in
              let zero = cast {to=Int} '0' in
              let nine = cast {to=Int} '9' in
              if i < zero || i > nine
                then Nothing
                else Just (i - zero)

parseInt : String -> Maybe Int
parseInt s = parseInt' (unpack s)
  where
    parseInt' : List Char -> Maybe Int
    parseInt' [] = Nothing
    parseInt' s@(x::xs) = parseInt'' 0 s
      where parseInt'' : Int -> List Char -> Maybe Int
            parseInt'' i [] = Just i
            parseInt'' i (x::xs) = case charToInt x of
                          Just n => do
                            let i' = (i * 10) + n
                            parseInt'' i' xs
                          Nothing => Nothing

-- Obtain dimensions x * y of Conway board
getDimensions : (List String) -> Maybe (Int, Int)
getDimensions [] = Nothing
getDimensions (x::xs) = getDim x
  where getDim : String -> Maybe (Int, Int)
        getDim s = case (pack $ take 2 $ unpack s) of
              "x=" => do
                        x <- parseInt (pack $ takeWhile (/= ',') (drop 2 $ unpack s))
                        case (pack $ take 3 s2) of
                          ",y=" => do
                              y <- parseInt (pack $ drop 3 s2)
                              pure (x, y)
                          _ => Nothing
              _ => Nothing

        where
            s2 : List Char
            s2 = dropWhile (/= ',') $ unpack s

getInitial : Int -> (List String) -> Maybe (List (List CellState))
getInitial _ [] = Nothing
getInitial _ (x1::[]) = Nothing
getInitial y (x1::x2::xs) = getInitial' y (unpack x2)
  where
        next : (List Char) -> Maybe (List Char)
        next xs = case dropWhile (/= '$') xs of
                    [] => Nothing
                    (x::xs) => Just xs

        getN : (List Char) -> Maybe (Nat, List Char)
        getN xs = case (takeWhile isDigit) xs of
                    [] => Just (1, xs)
                    digits => do
                      n <- parseInt (pack digits)
                      pure (cast n, drop (length digits) xs)

        repeatN : Nat -> a -> List a
        repeatN Z a = []
        repeatN (S n) a = a::(repeatN n a)

        getLine : (List Char) -> Maybe (List (CellState))
        getLine ('$'::xs) = Just []
        getLine xs = do
          numNext <- getN xs
          case (snd numNext) of
            ('b'::xs) => liftA (\l => (repeatN (fst numNext) Dead) ++ l)  (getLine xs)
            ('o'::xs) => liftA (\l => (repeatN (fst numNext) Alive) ++ l) (getLine xs)
            _        => Nothing

        getInitial' : Int  -> (List Char) -> Maybe (List (List CellState))
        getInitial' 0 _ = Just []
        getInitial' y xs = do
            first <- getLine xs
            nextItems <- next xs
            rest <- getInitial' (y - 1) nextItems
            pure (first::rest)

getConway : List (String) -> Maybe (List (List CellState))
getConway lines = do
  dimensions <- getDimensions lines
  getInitial (snd dimensions) lines

export
readCFile : String -> IO (Maybe (List (List CellState)))
readCFile fName = do
  readFileRes <- readFile fName
  case readFileRes of
    Left err => pure Nothing
    Right str => do
      let strLines = lines str
      let noWSLines = compress $ removeWS $ removeComments $ strLines
      pure $ getConway noWSLines


public export
record Rec where
  x : Int

f : Rec
f = {x := 4} ?foo


module Language.Elab.Deriving.ShowTest

import Language.Elab.Deriving.Show
%language ElabReflection

-- Testing of elaborations all on their own. (At bottom.)

export
data Foo1 : Type -> Type where
  Bor1 : Foo1 a

export
data Foo2 : Type -> Type where
  Bor2 : a -> Foo2 a

data Foo4 : Type -> Type -> Type where
  Bor4 : b -> Foo4 a b

data Foo5 : Type -> Type -> Type -> Type where
  Bor5 : a -> b -> c -> Foo5 a b c

-- NB c is never used, so Eq shouldn't be required for it
data Foo7 : Type -> Type -> Type -> Type where
  Zor7 : a -> Foo7 a b c
  Gor7 : b -> Foo7 a b c
  Nor7A : a -> b -> Foo7 a b c
  Nor7B : a -> b -> c -> Foo7 a b c
  Bor7 : Foo7 a b c

-- NB a is never used, so Eq shouldn't be required for it
data Foo7' : Type -> Type -> Type -> Type where
  Zor7' : c -> Foo7' a b c
  Gor7' : b -> Foo7' a b c
  Nor7' : b -> c -> Foo7' a b c
  Bor7' : Foo7' a b c

  -- we'll use our own nat for index experimentation
export
data MyNat : Type where
  MZ : MyNat
  MS : MyNat -> MyNat

data Foo6 : Type -> Type -> Type -> Nat -> Type where
  Zor6 : a -> b -> Foo6 a b c Z
  Gor6 : b -> Foo6 a b c (S k)
  Nor6A : a -> b -> c -> Foo6 a b c n
  Nor6B : a -> (0 _ : b) -> c -> Foo6 a b c n -- NB: 0 Use arg
  Bor6A : Foo6 a b c n
  Bor6B : Foo6 a b c n -> Foo6 a b c n
  Wah6 : a -> (n : Nat) -> Foo6 a b c n

export
data Foo6' : Type -> Type -> Type -> MyNat -> Type where
  Zor6'  : a -> b -> Foo6' a b c MZ
  Gor6A'  : b -> Foo6' a b c (MS k)
  Gor6B'  : (k : MyNat) -> b -> Foo6' a b c (MS k)
  Nor6A' : a -> b -> c -> Foo6' a b c n
  Nor6B' : a -> (0 _ : b) -> c -> Foo6' a b c n
  Bor6'  : Foo6' a b c n
  Wah6'  : a -> (n : MyNat) -> Foo6' a b c n
  Kah6'  : a -> (n : MyNat) -> (0 _ : c) -> Foo6' a b c n
  Pah6'  : a -> (n : MyNat) -> MyNat -> (0 _ : c) -> Foo6' a b c n
  -- Rah6'  : a -> (n : MyNat) -> Foo6' a b c n -> MyNat -> (0 _ : c) -> Foo6' a b c n -> Foo6' a b c n
  -- Gah6'  : {1 _ : a} -> (n : MyNat) -> MyNat -> (0 _ : c) -> Foo6' a b c n
  -- ^ another case to consider, what if I'm implicit but M1?
  -- Seems like an error would be appropriate there rather than showing
  -- implicits. Though showing implicits could be a flag in instance generation
  -- I guess.

-- eqImplFoo6'Fun (Wah6' 'c' MZ) (Wah6' 'c' MZ)
-- eqImplFoo6'Fun (Nor6A' {n=MZ} 'c' 'd' 'e')

-- eqImplFoo6Fun (Wah6 {b=Int} {c=String} 'c' (S Z)) (Wah6 'c' (S Z))

-- reference impl
-- NB We need to use n twice, Eq is not dependent, two values of `a` compared
-- against each other must have the same indices. Which follows since if they
-- don't they're obviously not equal.
-- if a con has no explicit, non-M0, non-index, vars then it's empty, and thus
-- vauously true to compare to itself. only explicit, non-M0, non-index vars need
-- to be compared. M0 values can't be used and index vars can't vary in an Eq
-- definition
eqFoo6 : (Eq a, Eq b, Eq c) => Foo6 a b c n -> Foo6 a b c n -> Bool
eqFoo6 (Zor6 x1 y1) (Zor6 x2 y2) = x1 == x2 && y1 == y2
eqFoo6 (Gor6 x1) (Gor6 x2) = x1 == x2
eqFoo6 (Nor6A x1 y1 z1) (Nor6A x2 y2 z2) = x1 == x2 && y1 == y2 && z1 == z2
eqFoo6 (Nor6B x1 _ z1) (Nor6B x2 _ z2) = x1 == x2 && z1 == z2
eqFoo6 Bor6A Bor6A = True
eqFoo6 (Bor6B x1) (Bor6B x2) = eqFoo6 x1 x2
-- we prefer to write this as x1 == x2, and we do so by declaring our Eq object
-- early, otherwise there's no instance for Foo6 to use == from
eqFoo6 (Wah6 x1 _) (Wah6 x2 _) = x1 == x2 -- indices do not differ
eqFoo6 _ _ = False
-- eqFoo6 {b=Int} {c=String} (Wah6 'c' (S Z)) (Wah6 'c' (S Z))

data FooN : MyNat -> Type -> Type where
  BorZ : b -> FooN MZ b
  BorS : b -> FooN (MS MZ) b
  BorNA : (k : MyNat) -> b -> FooN n b
  BorNB : (n : MyNat) -> b -> FooN n b

%runElab deriveShow Export  `{{MyNat}}
%runElab deriveShow Export `{{Foo1}}
%runElab deriveShow Export  `{{Foo2}}
%runElab deriveShow Private `{{Foo4}}
%runElab deriveShow Private `{{Foo5}}
%runElab deriveShow Private `{{Foo7}}
%runElab deriveShow Private `{{Foo7'}}
%runElab deriveShow Private `{{FooN}}
%runElab deriveShow Private `{{Foo6}}
%runElab deriveShow Export  `{{Foo6'}}

-- can check what's generated via
-- :printdef showImplFoo7'Fun

-- Will need to supply types if playing in the repl, e.g.:
-- show (Wah6' 'c' MZ {b=Char} {c=Int})


module Dollar

infixr 1 $
($) : Int -> Int -> Int
($) u x = x + 1

f : Int -> Int
f x = x $ 5


module Fmt

import Data.String

%default total

-- From https://gist.github.com/chrisdone/672efcd784528b7d0b7e17ad9c115292

-- TODO: Add showables

public export
data Format
  = FInt Format
  | FString Format
  | FOther Char Format
  | FEnd

public export
format : List Char -> Format
format ('%' :: 'd' :: cs) = FInt (format cs)
format ('%' :: 's' :: cs) = FString (format cs)
format (c :: cs) = FOther c (format cs)
format [] = FEnd

public export
formatString : String -> Format
formatString = format . unpack

public export
interpFormat : Format -> Type
interpFormat (FInt f) = Int -> interpFormat f
interpFormat (FString f) = String -> interpFormat f
interpFormat (FOther _ f) = interpFormat f
interpFormat FEnd = String

public export
toFunction : (fmt : Format) -> String -> interpFormat fmt
toFunction (FInt f) a = \i => toFunction f (a ++ show i)
toFunction (FString f) a = \s => toFunction f (a ++ s)
toFunction (FOther c f) a = toFunction f (a ++ singleton c)
toFunction FEnd a = a

public export
fmt : (s : String) -> interpFormat (formatString s)
fmt s = toFunction (formatString s) ""


-- exercises in "Type-Driven Development with Idris"
-- chapter 14, section 3, Hangman part

import Data.Vect

-- check that all functions are total
%default total

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

||| (Abstract) State of the game
data GameState : Type where
  NotRunning : GameState
  Running : (guesses : Nat) -> (letters : Nat) -> GameState

||| Result of a guess
data GuessResult = Correct | Incorrect

||| Letters in a word
letters : String -> List Char
letters str = nub $ map toUpper $ unpack str

||| Game commands
data GameCmd : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
  ||| new game
  NewGame : (word : String) ->
            GameCmd () NotRunning $
                       const (Running 6 (length (letters word)))
  ||| won game
  Won : GameCmd () (Running (S guesses) 0) $
                   const NotRunning
  ||| lost game
  Lost : GameCmd () (Running 0 (S guesses)) $
                    const NotRunning
  ||| guess a letter
  Guess : (c : Char) ->
          GameCmd  GuessResult
                   (Running (S guesses) (S letters))
                   (\res => case res of
                              Correct => Running (S guesses) letters
                              Incorrect => Running guesses (S letters))
  ||| display the game state
  ShowState : GameCmd () state $ const state
  ||| display a message
  Message : String -> GameCmd () state $ const state
  ||| read a guess
  ReadGuess : GameCmd Char state $ const state
  ||| pure
  Pure : (res : ty) -> GameCmd ty (state res) state
  ||| sequence
  (>>=) : GameCmd a state1 state2 ->
          ((res : a) -> GameCmd b (state2 res) state3) ->
          GameCmd b state1 state3

namespace Loop
  ||| Game loop (type)
  data GameLoop : (ty : Type) -> GameState -> (ty -> GameState) -> Type where
    ||| sequence
    (>>=) : GameCmd a state1 state2 ->
            ((res : a) -> Inf (GameLoop b (state2 res) state3)) ->
            GameLoop b state1 state3
    ||| exit game
    Exit : GameLoop () NotRunning $ const NotRunning

||| Game loop (implementation)
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)

||| Game set up
hangman : GameLoop () NotRunning $ const NotRunning
hangman = do NewGame "testing"
             gameLoop

||| (Concrete) Game state
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)

||| Game representation
Show (Game gs) 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

||| Fuel machinery
data Fuel = Dry | More (Lazy Fuel)

||| Result of a game
data GameResult : (ty : Type) -> (ty -> GameState) -> Type where
  OK : (res : ty) -> Game (outstate res) ->
       GameResult ty outstate
  OutOfFuel : GameResult ty outstate

||| Helper for returns of runs
ok : (res : ty) -> Game (outstate res) -> IO (GameResult ty outstate)
ok res st = pure (OK res st)

||| Running a game command over fuel
runCmd : Fuel ->
         Game instate ->
         GameCmd ty instate outstate ->
         IO (GameResult ty outstate)
runCmd fuel state (NewGame word)
  = ok () (InProgress (toUpper word) _ (fromList (letters word)))
runCmd fuel (InProgress word _ missing) Won = ok () (GameWon word)
runCmd fuel (InProgress word _ missing) Lost = ok () (GameLost word)
runCmd fuel (InProgress word _ missing) (Guess c)
  = case isElem c missing of
      Yes prf => ok Correct (InProgress word _ (removeElem c missing))
      No contra => ok Incorrect (InProgress word _ missing)
runCmd fuel state ShowState = do printLn state
                                 ok () state
runCmd fuel state (Message x) = do putStrLn x
                                   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 Dry _ _ = pure OutOfFuel
runCmd fuel state (Pure res) = ok res state
runCmd fuel st (cmd >>= next)
  = do OK cmdRes newSt <- runCmd fuel st cmd
        | OutOfFuel => pure OutOfFuel
       runCmd fuel newSt (next cmdRes)

||| Running a game loop over fuel
run : Fuel ->
      Game instate ->
      GameLoop ty instate outstate ->
      IO (GameResult ty outstate)
run Dry _ _ = pure OutOfFuel
run (More fuel) st (cmd >>= next)
  = do OK cmdRes newSt <- runCmd fuel st cmd
       | OutOfFuel => pure OutOfFuel
       run fuel newSt (next cmdRes)
run (More fuel) st Exit = ok () st

-- all remaining functions are partial
%default partial

forever : Fuel
forever = More forever

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


module Printf

import Prelude
import Data.String

data Arg
    = AInt      Arg
    | AOther    Char Arg
    | AEnd

buildArg : List Char -> Arg
buildArg fmt = case fmt of
    '%' :: 'i' :: fmtTail   => AInt (buildArg fmtTail)
    c :: fmtTail            => AOther c (buildArg fmtTail)
    Nil                     => AEnd

argToType : Arg -> Type -> Type
argToType a result = case a of
    AInt fmtTail      => Int -> argToType fmtTail result
    AOther _ fmtTail  => argToType fmtTail result
    AEnd              => result

-- PrintfType "foo" result = result
-- PrintfType "%i\n" result = Int -> result
-- etc
PrintfType : String -> Type -> Type
PrintfType fmt result = argToType (buildArg (unpack fmt)) result

sprintf : (fmt : String) -> PrintfType fmt String
sprintf fmt = go "" (buildArg (unpack fmt)) where
    go : String -> (arg : Arg) -> argToType arg String
    go strTail arg = case arg of
        AInt fmtTail        => \i : Int => go (strTail ++ show i) fmtTail
        AOther c fmtTail    => go (strTail ++ singleton c) fmtTail
        AEnd                => strTail

test : ?result
test = sprintf "%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i%i"


module Data.Hashable

import Data.String

||| A default salt used in the implementation of 'hash'.
export
defaultSalt : Bits64
defaultSalt = 14695981039346656037

infixl 10 `hashWithSalt`
infixl 10 `hash`

||| Interface for type that can be hashed.
-- Minimal implementation: 'hashWithSalt'
public export
interface Hashable a where
    hashWithSalt : Bits64 -> a -> Bits64
    hash : a -> Bits64
    hash = hashWithSalt defaultSalt

||| Combine 2 hashes.
export
combine : Bits64 -> Bits64 -> Bits64
combine h1 h2 = (h1 * 16777619) `prim__xor_Bits64` h2

||| Default implementation of 'hashWithSalt' for types which are smaller than Bits64 (eg Bits32, Int).
export
defaultHashWithSalt : Hashable a => Bits64 -> a -> Bits64
defaultHashWithSalt salt x = salt `combine` hash x

export
Hashable Bits8 where
    hash = cast
    hashWithSalt = defaultHashWithSalt

export
Hashable Bits16 where
    hash = cast
    hashWithSalt = defaultHashWithSalt

export
Hashable Bits32 where
    hash = cast
    hashWithSalt = defaultHashWithSalt

export
Hashable Bits64 where
    hash = id
    hashWithSalt = defaultHashWithSalt

export
Hashable Int where
    hash = cast
    hashWithSalt = defaultHashWithSalt

export
Hashable Char where
    hash = cast . ord
    hashWithSalt = defaultHashWithSalt

export
Hashable String where
    hashWithSalt salt str = finalise (foldl step (salt, 0) $ fastUnpack str)
      where
        step : (Bits64, Bits64) -> Char -> (Bits64, Bits64)
        step (s, l) x = (hashWithSalt s x, l + 1)
        finalise : (Bits64, Bits64) -> Bits64
        finalise (s, l) = hashWithSalt s l