module TTImp.PartialEval

import Core.CaseTree
import Core.Context
import Core.Context.Log
import Core.Core
import Core.Env
import Core.Hash
import Core.Metadata
import Core.Normalise
import Core.Value
import Core.UnifyState

import TTImp.Elab.Check
import TTImp.TTImp
import TTImp.TTImp.Functor
import TTImp.Unelab

import Libraries.Utils.Hex

import Data.List
import Libraries.Data.NameMap

%default covering

data ArgMode = Static ClosedTerm | Dynamic

Show ArgMode where
  show (Static tm) = "Static " ++ show tm
  show Dynamic = "Dynamic"

getStatic : ArgMode -> Maybe (Term [])
getStatic Dynamic = Nothing
getStatic (Static t) = Just t

specialiseTy : {vars : _} ->
               Nat -> List (Nat, Term []) -> Term vars -> Term vars
specialiseTy i specs (Bind fc x (Pi fc' c p ty) sc)
    = case lookup i specs of
           Nothing => Bind fc x (Pi fc' c Explicit ty) $ -- easier later if everything explicit
                        specialiseTy (1 + i) specs sc
           Just tm => specialiseTy (1 + i) specs (subst (embed tm) sc)
specialiseTy i specs tm = tm

substLoc : {vs : _} ->
           Nat -> Term vs -> Term vs -> Term vs
substLoc i tm (Local fc l idx p)
    = if i == idx then tm else (Local fc l idx p)
substLoc i tm (Bind fc x b sc)
    = Bind fc x (map (substLoc i tm) b) (substLoc (1 + i) (weaken tm) sc)
substLoc i tm (Meta fc n r args)
    = Meta fc n r (map (substLoc i tm) args)
substLoc i tm (App fc f a) = App fc (substLoc i tm f) (substLoc i tm a)
substLoc i tm (As fc s f a) = As fc s (substLoc i tm f) (substLoc i tm a)
substLoc i tm (TDelayed fc r d) = TDelayed fc r (substLoc i tm d)
substLoc i tm (TDelay fc r ty d) = TDelay fc r (substLoc i tm ty) (substLoc i tm d)
substLoc i tm (TForce fc r d) = TForce fc r (substLoc i tm d)
substLoc i tm x = x

substLocs : {vs : _} ->
            List (Nat, Term vs) -> Term vs -> Term vs
substLocs [] tm = tm
substLocs ((i, tm') :: subs) tm = substLocs subs (substLoc i tm' tm)

mkSubsts : Nat -> List (Nat, Term []) ->
           List (Term vs) -> Term vs -> Maybe (List (Nat, Term vs))
mkSubsts i specs [] rhs = Just []
mkSubsts i specs (arg :: args) rhs
    = do subs <- mkSubsts (1 + i) specs args rhs
         case lookup i specs of
              Nothing => Just subs
              Just tm => case arg of
                              Local _ _ idx _ =>
                                   Just ((idx, embed tm) :: subs)
                              As _ _ (Local _ _ idx1 _) (Local _ _ idx2 _) =>
                                   Just ((idx1, embed tm) :: (idx2, embed tm) :: subs)
                              As _ _ _ (Local _ _ idx _) =>
                                   Just ((idx, embed tm) :: subs)
                              _ => Nothing

-- In the case where all the specialised positions are variables on the LHS,
-- substitute the term in on the RHS
specPatByVar : List (Nat, Term []) ->
                (vs ** (Env Term vs, Term vs, Term vs)) ->
                Maybe (vs ** (Env Term vs, Term vs, Term vs))
specPatByVar specs (vs ** (env, lhs, rhs))
    = do let (fn, args) = getFnArgs lhs
         psubs <- mkSubsts 0 specs args rhs
         let lhs' = apply (getLoc fn) fn args
         pure (vs ** (env, substLocs psubs lhs', substLocs psubs rhs))

specByVar : List (Nat, Term []) ->
            List (vs ** (Env Term vs, Term vs, Term vs)) ->
            Maybe (List (vs ** (Env Term vs, Term vs, Term vs)))
specByVar specs [] = pure []
specByVar specs (p :: ps)
    = do p' <- specPatByVar specs p
         ps' <- specByVar specs ps
         pure (p' :: ps')

dropSpec : Nat -> List (Nat, Term []) -> List a -> List a
dropSpec i sargs [] = []
dropSpec i sargs (x :: xs)
    = case lookup i sargs of
           Nothing => x :: dropSpec (1 + i) sargs xs
           Just _ => dropSpec (1 + i) sargs xs

getSpecPats : {auto c : Ref Ctxt Defs} ->
              FC -> Name ->
              (fn : Name) -> (stk : List (FC, Term vars)) ->
              NF [] -> -- Type of 'fn'
              List (Nat, ArgMode) -> -- All the arguments
              List (Nat, Term []) -> -- Just the static ones
              List (vs ** (Env Term vs, Term vs, Term vs)) ->
              Core (Maybe (List ImpClause))
getSpecPats fc pename fn stk fnty args sargs pats
   = do -- First, see if all the specialised positions are variables. If so,
        -- substitute the arguments directly into the RHS
        let Nothing = specByVar sargs pats
            | Just specpats =>
                   do ps <- traverse (unelabPat pename) specpats
                      pure (Just ps)
        -- Otherwise, build a new definition by taking the remaining arguments
        -- on the lhs, and using the specialised function application on the rhs.
        -- Then, this will get evaluated on elaboration.
        let dynnames = mkDynNames 0 args
        let lhs = apply (IVar fc pename) (map (IBindVar fc) dynnames)
        rhs <- mkRHSargs fnty (IVar fc fn) dynnames args
        pure (Just [PatClause fc lhs rhs])
  where
    mkDynNames : Int -> List (Nat, ArgMode) -> List String
    mkDynNames i [] = []
    mkDynNames i ((_, Dynamic) :: as)
        = ("_pe" ++ show i) :: mkDynNames (1 + i) as
    mkDynNames i (_ :: as) = mkDynNames i as

    -- Build a RHS from the type of the function to be specialised, the
    -- dynamic argument names, and the list of given arguments. We assume
    -- the latter two correspond appropriately.
    mkRHSargs : NF [] -> RawImp -> List String -> List (Nat, ArgMode) ->
                Core RawImp
    mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app (a :: as) ((_, Dynamic) :: ds)
        = do defs <- get Ctxt
             sc' <- sc defs (toClosure defaultOpts [] (Erased fc False))
             mkRHSargs sc' (IApp fc app (IVar fc (UN $ Basic a))) as ds
    mkRHSargs (NBind _ x (Pi _ _ _ _) sc) app (a :: as) ((_, Dynamic) :: ds)
        = do defs <- get Ctxt
             sc' <- sc defs (toClosure defaultOpts [] (Erased fc False))
             mkRHSargs sc' (INamedApp fc app x (IVar fc (UN $ Basic a))) as ds
    mkRHSargs (NBind _ x (Pi _ _ Explicit _) sc) app as ((_, Static tm) :: ds)
        = do defs <- get Ctxt
             sc' <- sc defs (toClosure defaultOpts [] (Erased fc False))
             tm' <- unelabNoSugar [] tm
             mkRHSargs sc' (IApp fc app (map rawName tm')) as ds
    mkRHSargs (NBind _ x (Pi _ _ _ _) sc) app as ((_, Static tm) :: ds)
        = do defs <- get Ctxt
             sc' <- sc defs (toClosure defaultOpts [] (Erased fc False))
             tm' <- unelabNoSugar [] tm
             mkRHSargs sc' (INamedApp fc app x (map rawName tm')) as ds
    -- Type will depend on the value here (we assume a variadic function) but
    -- the argument names are still needed
    mkRHSargs ty app (a :: as) ((_, Dynamic) :: ds)
        = mkRHSargs ty (IApp fc app (IVar fc (UN $ Basic a))) as ds
    mkRHSargs _ app _ _
        = pure app

    getRawArgs : List (Maybe Name, RawImp) -> RawImp -> List (Maybe Name, RawImp)
    getRawArgs args (IApp _ f arg) = getRawArgs ((Nothing, arg) :: args) f
    getRawArgs args (INamedApp _ f n arg)
        = getRawArgs ((Just n, arg) :: args) f
    getRawArgs args tm = args

    reapply : RawImp -> List (Maybe Name, RawImp) -> RawImp
    reapply f [] = f
    reapply f ((Nothing, arg) :: args) = reapply (IApp fc f arg) args
    reapply f ((Just t, arg) :: args)
        = reapply (INamedApp fc f t arg) args

    dropArgs : Name -> RawImp -> RawImp
    dropArgs pename tm = reapply (IVar fc pename) (dropSpec 0 sargs (getRawArgs [] tm))

    unelabPat : Name -> (vs ** (Env Term vs, Term vs, Term vs)) ->
                Core ImpClause
    unelabPat pename (_ ** (env, lhs, rhs))
        = do lhsapp <- unelabNoSugar env lhs
             let lhs' = dropArgs pename (map rawName lhsapp)
             defs <- get Ctxt
             rhsnf <- normaliseArgHoles defs env rhs
             rhs' <- unelabNoSugar env rhsnf
             pure (PatClause fc lhs' (map rawName rhs'))

    unelabLHS : Name -> (vs ** (Env Term vs, Term vs, Term vs)) ->
                Core RawImp
    unelabLHS pename (_ ** (env, lhs, rhs))
        = do lhsapp <- unelabNoSugar env lhs
             pure $ dropArgs pename (map rawName lhsapp)

-- Get the reducible names in a function to be partially evaluated. In practice,
-- that's all the functions it refers to
-- TODO: May want to take care with 'partial' names?
getReducible : List Name -> -- calls to check
               NameMap Nat -> -- which nodes have been visited. If the entry is
                              -- present, it's visited
               Defs -> Core (NameMap Nat)
getReducible [] refs defs = pure refs
getReducible (n :: rest) refs defs
  = do let Nothing = lookup n refs
           | Just _ => getReducible rest refs defs
       case !(lookupCtxtExact n (gamma defs)) of
            Nothing => getReducible rest refs defs
            Just def =>
              do let refs' = insert n 65536 refs
                 let calls = refersTo def
                 getReducible (keys calls ++ rest) refs' defs

mkSpecDef : {auto c : Ref Ctxt Defs} ->
            {auto m : Ref MD Metadata} ->
            {auto u : Ref UST UState} ->
            FC -> GlobalDef ->
            Name -> List (Nat, ArgMode) -> Name -> List (FC, Term vars) ->
            Core (Term vars)
mkSpecDef {vars} fc gdef pename sargs fn stk
    = handleUnify
       (do defs <- get Ctxt
           setAllPublic True
           let staticargs
                 = mapMaybe (\ (x, s) => case s of
                                              Dynamic => Nothing
                                              Static t => Just (x, t)) sargs
           let peapp = applyWithFC (Ref fc Func pename) (dropSpec 0 staticargs stk)
           Nothing <- lookupCtxtExact pename (gamma defs)
               | Just _ => -- already specialised
                           do log "specialise" 5 $ "Already specialised " ++ show pename
                              pure peapp
           logC "specialise" 5 $
                   do fnfull <- toFullNames fn
                      args' <- traverse (\ (i, arg) =>
                                   do arg' <- the (Core ArgMode) $ case arg of
                                                   Static a =>
                                                      pure $ Static !(toFullNames a)
                                                   Dynamic => pure Dynamic
                                      pure (show (i, arg'))) sargs
                      pure $ "Specialising " ++ show fnfull ++
                             " (" ++ show fn ++ ") by " ++
                             showSep ", " args'
           let sty = specialiseTy 0 staticargs (type gdef)
           logTermNF "specialise" 3 ("Specialised type " ++ show pename) [] sty

           -- Add as RigW - if it's something else, we don't need it at
           -- runtime anyway so this is wasted effort, therefore a failure
           -- is okay!
           peidx <- addDef pename (newDef fc pename top [] sty Public None)
           addToSave (Resolved peidx)

           -- Reduce the function to be specialised, and reduce any name in
           -- the arguments at most once (so that recursive definitions aren't
           -- unfolded forever)
           let specnames = getAllRefs empty (map snd sargs)
           specLimits <- traverse (\n => pure (n, 1))
                                  (keys specnames)

           defs <- get Ctxt
           reds <- getReducible [fn] empty defs
           setFlag fc (Resolved peidx) (PartialEval (specLimits ++ toList reds))

           let PMDef pminfo pmargs ct tr pats = definition gdef
               | _ => pure (applyWithFC (Ref fc Func fn) stk)
           logC "specialise" 5 $
                   do inpats <- traverse unelabDef pats
                      pure $ "Attempting to specialise:\n" ++
                             showSep "\n" (map showPat inpats)

           Just newpats <- getSpecPats fc pename fn stk !(nf defs [] (type gdef))
                                       sargs staticargs pats
                | Nothing => pure (applyWithFC (Ref fc Func fn) stk)
           log "specialise" 5 $ "New patterns for " ++ show pename ++ ":\n" ++
                    showSep "\n" (map showPat newpats)
           processDecl [InPartialEval] (MkNested []) []
                       (IDef fc (Resolved peidx) newpats)
           setAllPublic False
           pure peapp)
           -- If the partially evaluated definition fails, just use the initial
           -- application. It might indicates a bug in the P.E. function generation
           -- if it fails, but I don't want the whole system to be dependent on
           -- the correctness of PE!
        (\err =>
           do log "specialise" 1 $ "Partial evaluation of " ++ show !(toFullNames fn) ++ " failed" ++
                      "\n" ++ show err
              defs <- get Ctxt
              put Ctxt (record { peFailures $= insert pename () } defs)
              pure (applyWithFC (Ref fc Func fn) stk))
  where
    getAllRefs : NameMap Bool -> List ArgMode -> NameMap Bool
    getAllRefs ns (Dynamic :: xs) = getAllRefs ns xs
    getAllRefs ns (Static t :: xs)
        = addRefs False (UN Underscore) (getAllRefs ns xs) t
    getAllRefs ns [] = ns

    updateApp : Name -> RawImp -> RawImp
    updateApp n (IApp fc f a) = IApp fc (updateApp n f) a
    updateApp n (IAutoApp fc f a) = IAutoApp fc (updateApp n f) a
    updateApp n (INamedApp fc f m a) = INamedApp fc (updateApp n f) m a
    updateApp n f = IVar fc n

    unelabDef : (vs ** (Env Term vs, Term vs, Term vs)) ->
                Core ImpClause
    unelabDef (_ ** (env, lhs, rhs))
        = do lhs' <- unelabNoSugar env lhs
             defs <- get Ctxt
             rhsnf <- normaliseArgHoles defs env rhs
             rhs' <- unelabNoSugar env rhsnf
             pure (PatClause fc (map rawName lhs') (map rawName rhs'))

    showPat : ImpClause -> String
    showPat (PatClause _ lhs rhs) = show lhs ++ " = " ++ show rhs
    showPat _ = "Can't happen"

eraseInferred : {auto c : Ref Ctxt Defs} ->
                Term vars -> Core (Term vars)
eraseInferred (Bind fc x b tm)
    = do b' <- traverse eraseInferred b
         tm' <- eraseInferred tm
         pure (Bind fc x b' tm')
eraseInferred tm
    = case getFnArgs tm of
           (f, []) => pure f
           (Ref fc Func n, args) =>
                do defs <- get Ctxt
                   Just gdef <- lookupCtxtExact n (gamma defs)
                        | Nothing => pure tm
                   let argsE = dropErased fc 0 (inferrable gdef) args
                   argsE' <- traverse eraseInferred argsE
                   pure (apply fc (Ref fc Func n) argsE')
           (f, args) =>
                do args' <- traverse eraseInferred args
                   pure (apply (getLoc f) f args)
  where
    dropErased : FC -> Nat -> List Nat -> List (Term vars) -> List (Term vars)
    dropErased fc pos ps [] = []
    dropErased fc pos ps (n :: ns)
        = if pos `elem` ps
             then Erased fc False :: dropErased fc (1 + pos) ps ns
             else n :: dropErased fc (1 + pos) ps ns

-- Specialise a function name according to arguments. Return the specialised
-- application on success, or Nothing if it's not specialisable (due to static
-- arguments not being concrete)
specialise : {vars : _} ->
             {auto c : Ref Ctxt Defs} ->
             {auto m : Ref MD Metadata} ->
             {auto u : Ref UST UState} ->
             FC -> Env Term vars -> GlobalDef ->
             Name -> List (FC, Term vars) ->
             Core (Maybe (Term vars))
specialise {vars} fc env gdef fn stk
    = case specArgs gdef of
        [] => pure Nothing
        specs =>
            do fnfull <- toFullNames fn
               -- If all the arguments are concrete (meaning, no local variables
               -- or holes in them, so they can be a Term []) we can specialise
               Just sargs <- getSpecArgs 0 specs stk
                   | Nothing => pure Nothing
               let nhash = hash (mapMaybe getStatic (map snd sargs))
                              `hashWithSalt` fn -- add function name to hash to avoid namespace clashes
               let pename = NS partialEvalNS
                            (UN $ Basic ("PE_" ++ nameRoot fnfull ++ "_" ++ asHex nhash))
               defs <- get Ctxt
               case lookup pename (peFailures defs) of
                    Nothing => Just <$> mkSpecDef fc gdef pename sargs fn stk
                    Just _ => pure Nothing
  where
    dropAll : {vs : _} -> SubVars [] vs
    dropAll {vs = []} = SubRefl
    dropAll {vs = v :: vs} = DropCons dropAll

    concrete : {vars : _} ->
               Term vars -> Maybe (Term [])
    concrete tm = shrinkTerm tm dropAll

    getSpecArgs : Nat -> List Nat -> List (FC, Term vars) ->
                  Core (Maybe (List (Nat, ArgMode)))
    getSpecArgs i specs [] = pure (Just [])
    getSpecArgs i specs ((_, x) :: xs)
        = do Just xs' <- getSpecArgs (1 + i) specs xs
                 | Nothing => pure Nothing
             if i `elem` specs
                then do defs <- get Ctxt
                        x' <- normaliseHoles defs env x
                        x' <- eraseInferred x'
                        let Just xok = concrete x'
                            | Nothing => pure Nothing
                        pure $ Just ((i, Static xok) :: xs')
                else pure $ Just ((i, Dynamic) :: xs')

findSpecs : {vars : _} ->
            {auto c : Ref Ctxt Defs} ->
            {auto m : Ref MD Metadata} ->
            {auto u : Ref UST UState} ->
            Env Term vars -> List (FC, Term vars) -> Term vars ->
            Core (Term vars)
findSpecs env stk (Ref fc Func fn)
    = do defs <- get Ctxt
         Just gdef <- lookupCtxtExact fn (gamma defs)
              | Nothing => pure (applyWithFC (Ref fc Func fn) stk)
         Just r <- specialise fc env gdef fn stk
              | Nothing => pure (applyWithFC (Ref fc Func fn) stk)
         pure r
findSpecs env stk (Meta fc n i args)
    = do args' <- traverse (findSpecs env []) args
         pure $ applyWithFC (Meta fc n i args') stk
findSpecs env stk (Bind fc x b sc)
    = do b' <- traverse (findSpecs env []) b
         sc' <- findSpecs (b' :: env) [] sc
         pure $ applyWithFC (Bind fc x b' sc') stk
findSpecs env stk (App fc fn arg)
    = do arg' <- findSpecs env [] arg
         findSpecs env ((fc, arg') :: stk) fn
findSpecs env stk (TDelayed fc r tm)
    = do tm' <- findSpecs env [] tm
         pure $ applyWithFC (TDelayed fc r tm') stk
findSpecs env stk (TDelay fc r ty tm)
    = do ty' <- findSpecs env [] ty
         tm' <- findSpecs env [] tm
         pure $ applyWithFC (TDelay fc r ty' tm') stk
findSpecs env stk (TForce fc r tm)
    = do tm' <- findSpecs env [] tm
         pure $ applyWithFC (TForce fc r tm') stk
findSpecs env stk tm = pure $ applyWithFC tm stk

bName : {auto q : Ref QVar Int} -> String -> Core Name
bName n
    = do i <- get QVar
         put QVar (i + 1)
         pure (MN n i)

-- This is like 'quote' in 'Normalise', except that when we encounter a
-- function name we need to check whether to specialise.
-- (Sorry about all the repetition - I don't really want to export those
-- internal details, and there is a small but crucial change where we call
-- quoteHead as compared with the version in Core.Normalise, to deal with
-- checking for specialised applications.)
mutual
  quoteArgs : {bound, free : _} ->
              {auto c : Ref Ctxt Defs} ->
              {auto m : Ref MD Metadata} ->
              {auto u : Ref UST UState} ->
              Ref QVar Int -> Defs -> Bounds bound ->
              Env Term free -> List (Closure free) ->
              Core (List (Term (bound ++ free)))
  quoteArgs q defs bounds env [] = pure []
  quoteArgs q defs bounds env (a :: args)
      = pure $ (!(quoteGenNF q defs bounds env !(evalClosure defs a)) ::
                !(quoteArgs q defs bounds env args))

  quoteArgsWithFC : {auto c : Ref Ctxt Defs} ->
                    {auto m : Ref MD Metadata} ->
                    {auto u : Ref UST UState} ->
                    {bound, free : _} ->
                    Ref QVar Int -> Defs -> Bounds bound ->
                    Env Term free -> List (FC, Closure free) ->
                    Core (List (FC, Term (bound ++ free)))
  quoteArgsWithFC q defs bounds env terms
      = pure $ zip (map fst terms) !(quoteArgs q defs bounds env (map snd terms))

  quoteHead : {bound, free : _} ->
              {auto c : Ref Ctxt Defs} ->
              {auto m : Ref MD Metadata} ->
              {auto u : Ref UST UState} ->
              Ref QVar Int -> Defs ->
              FC -> Bounds bound -> Env Term free -> NHead free ->
              Core (Term (bound ++ free))
  quoteHead {bound} q defs fc bounds env (NLocal mrig _ prf)
      = let MkVar prf' = addLater bound prf in
            pure $ Local fc mrig _ prf'
    where
      addLater : {idx : _} -> (ys : List Name) -> (0 p : IsVar n idx xs) ->
                 Var (ys ++ xs)
      addLater [] isv = MkVar isv
      addLater (x :: xs) isv
          = let MkVar isv' = addLater xs isv in
                MkVar (Later isv')
  quoteHead q defs fc bounds env (NRef Bound (MN n i))
      = case findName bounds of
             Just (MkVar p) => pure $ Local fc Nothing _ (varExtend p)
             Nothing => pure $ Ref fc Bound (MN n i)
    where
      findName : Bounds bound' -> Maybe (Var bound')
      findName None = Nothing
      findName (Add x (MN n' i') ns)
          = if i == i' -- this uniquely identifies it, given how we
                       -- generated the names, and is a faster test!
               then Just (MkVar First)
               else do MkVar p <-findName ns
                       Just (MkVar (Later p))
      findName (Add x _ ns)
          = do MkVar p <-findName ns
               Just (MkVar (Later p))
  quoteHead q defs fc bounds env (NRef nt n) = pure $ Ref fc nt n
  quoteHead q defs fc bounds env (NMeta n i args)
      = do args' <- quoteArgs q defs bounds env args
           pure $ Meta fc n i args'

  quotePi : {bound, free : _} ->
            {auto c : Ref Ctxt Defs} ->
            {auto m : Ref MD Metadata} ->
            {auto u : Ref UST UState} ->
            Ref QVar Int -> Defs -> Bounds bound ->
            Env Term free -> PiInfo (Closure free) ->
            Core (PiInfo (Term (bound ++ free)))
  quotePi q defs bounds env Explicit = pure Explicit
  quotePi q defs bounds env Implicit = pure Implicit
  quotePi q defs bounds env AutoImplicit = pure AutoImplicit
  quotePi q defs bounds env (DefImplicit t)
      = do t' <- quoteGenNF q defs bounds env !(evalClosure defs t)
           pure (DefImplicit t')

  quoteBinder : {bound, free : _} ->
                {auto c : Ref Ctxt Defs} ->
                {auto m : Ref MD Metadata} ->
                {auto u : Ref UST UState} ->
                Ref QVar Int -> Defs -> Bounds bound ->
                Env Term free -> Binder (Closure free) ->
                Core (Binder (Term (bound ++ free)))
  quoteBinder q defs bounds env (Lam fc r p ty)
      = do ty' <- quoteGenNF q defs bounds env !(evalClosure defs ty)
           p' <- quotePi q defs bounds env p
           pure (Lam fc r p' ty')
  quoteBinder q defs bounds env (Let fc r val ty)
      = do val' <- quoteGenNF q defs bounds env !(evalClosure defs val)
           ty' <- quoteGenNF q defs bounds env !(evalClosure defs ty)
           pure (Let fc r val' ty')
  quoteBinder q defs bounds env (Pi fc r p ty)
      = do ty' <- quoteGenNF q defs bounds env !(evalClosure defs ty)
           p' <- quotePi q defs bounds env p
           pure (Pi fc r p' ty')
  quoteBinder q defs bounds env (PVar fc r p ty)
      = do ty' <- quoteGenNF q defs bounds env !(evalClosure defs ty)
           p' <- quotePi q defs bounds env p
           pure (PVar fc r p' ty')
  quoteBinder q defs bounds env (PLet fc r val ty)
      = do val' <- quoteGenNF q defs bounds env !(evalClosure defs val)
           ty' <- quoteGenNF q defs bounds env !(evalClosure defs ty)
           pure (PLet fc r val' ty')
  quoteBinder q defs bounds env (PVTy fc r ty)
      = do ty' <- quoteGenNF q defs bounds env !(evalClosure defs ty)
           pure (PVTy fc r ty')

  quoteGenNF : {bound, vars : _} ->
               {auto c : Ref Ctxt Defs} ->
               {auto m : Ref MD Metadata} ->
               {auto u : Ref UST UState} ->
               Ref QVar Int ->
               Defs -> Bounds bound ->
               Env Term vars -> NF vars -> Core (Term (bound ++ vars))
  quoteGenNF q defs bound env (NBind fc n b sc)
      = do var <- bName "qv"
           sc' <- quoteGenNF q defs (Add n var bound) env
                       !(sc defs (toClosure defaultOpts env (Ref fc Bound var)))
           b' <- quoteBinder q defs bound env b
           pure (Bind fc n b' sc')
  -- IMPORTANT CASE HERE
  -- If fn is to be specialised, quote the args directly (no further
  -- reduction) then call specialise. Otherwise, quote as normal
  quoteGenNF q defs bound env (NApp fc (NRef Func fn) args)
      = do Just gdef <- lookupCtxtExact fn (gamma defs)
                | Nothing => do args' <- quoteArgsWithFC q defs bound env args
                                pure $ applyWithFC (Ref fc Func fn) args'
           case specArgs gdef of
                [] => do args' <- quoteArgsWithFC q defs bound env args
                         pure $ applyWithFC (Ref fc Func fn) args'
                _ => do empty <- clearDefs defs
                        args' <- quoteArgsWithFC q defs bound env args
                        Just r <- specialise fc (extendEnv bound env) gdef fn args'
                             | Nothing =>
                                  -- can't specialise, keep the arguments
                                  -- unreduced
                                  do args' <- quoteArgsWithFC q empty bound env args
                                     pure $ applyWithFC (Ref fc Func fn) args'
                        pure r
     where
       extendEnv : Bounds bs -> Env Term vs -> Env Term (bs ++ vs)
       extendEnv None env = env
       extendEnv (Add x n bs) env
           -- We're just using this to evaluate holes in the right scope, so
           -- a placeholder binder is fine
           = Lam fc top Explicit (Erased fc False) :: extendEnv bs env
  quoteGenNF q defs bound env (NApp fc f args)
      = do f' <- quoteHead q defs fc bound env f
           args' <- quoteArgsWithFC q defs bound env args
           pure $ applyWithFC f' args'
  quoteGenNF q defs bound env (NDCon fc n t ar args)
      = do args' <- quoteArgsWithFC q defs bound env args
           pure $ applyWithFC (Ref fc (DataCon t ar) n) args'
  quoteGenNF q defs bound env (NTCon fc n t ar args)
      = do args' <- quoteArgsWithFC q defs bound env args
           pure $ applyWithFC (Ref fc (TyCon t ar) n) args'
  quoteGenNF q defs bound env (NAs fc s n pat)
      = do n' <- quoteGenNF q defs bound env n
           pat' <- quoteGenNF q defs bound env pat
           pure (As fc s n' pat')
  quoteGenNF q defs bound env (NDelayed fc r arg)
      = do argQ <- quoteGenNF q defs bound env arg
           pure (TDelayed fc r argQ)
  quoteGenNF q defs bound env (NDelay fc r ty arg)
      -- unlike main evaluator, we want to look under Delays
      = do argNF <- evalClosure defs arg
           argQ <- quoteGenNF q defs bound env argNF
           tyNF <- evalClosure defs ty
           tyQ <- quoteGenNF q defs bound env tyNF
           pure (TDelay fc r tyQ argQ)
    where
      toHolesOnly : Closure vs -> Closure vs
      toHolesOnly (MkClosure _ locs env tm)
          = MkClosure withHoles locs env tm
      toHolesOnly c = c
  quoteGenNF q defs bound env (NForce fc r arg args)
      = do args' <- quoteArgsWithFC q defs bound env args
           case arg of
                NDelay fc _ _ arg =>
                   do argNF <- evalClosure defs arg
                      pure $ applyWithFC !(quoteGenNF q defs bound env argNF) args'
                _ => do arg' <- quoteGenNF q defs bound env arg
                        pure $ applyWithFC (TForce fc r arg') args'
  quoteGenNF q defs bound env (NPrimVal fc c) = pure $ PrimVal fc c
  quoteGenNF q defs bound env (NErased fc i) = pure $ Erased fc i
  quoteGenNF q defs bound env (NType fc) = pure $ TType fc

evalRHS : {vars : _} ->
          {auto c : Ref Ctxt Defs} ->
          {auto m : Ref MD Metadata} ->
          {auto u : Ref UST UState} ->
          Env Term vars -> NF vars -> Core (Term vars)
evalRHS env nf
    = do q <- newRef QVar 0
         defs <- get Ctxt
         quoteGenNF q defs None env nf

export
applySpecialise : {vars : _} ->
                  {auto c : Ref Ctxt Defs} ->
                  {auto m : Ref MD Metadata} ->
                  {auto u : Ref UST UState} ->
                  Env Term vars ->
                  Maybe (List (Name, Nat)) ->
                        -- ^ If we're specialising, names to reduce in the RHS
                        -- with their reduction limits
                  Term vars -> -- initial RHS
                  Core (Term vars)
applySpecialise env Nothing tm
    = findSpecs env [] tm -- not specialising, just search through RHS
applySpecialise env (Just ls) tmin -- specialising, evaluate RHS while looking
                                 -- for names to specialise
    = do defs <- get Ctxt
         tm <- toResolvedNames tmin
         nf <- nf defs env tm
         tm' <- evalRHS env nf
         tmfull <- toFullNames tm'
         logTermNF "specialise" 5 ("New RHS") env tmfull
         pure tmfull


-- -------------------------------------------------------------- [ Errmsg.idr ]
-- Module      : Lightyear.Errmsg
-- Description : Error message formatting.
--
-- This code is distributed under the BSD 2-clause license.
-- See the file LICENSE in the root directory for its full text.
-- --------------------------------------------------------------------- [ EOH ]
module Errmsg

import Lightyear.Core

%access export
-- ------------------------------------------------------------------- [ Begin ]

interface Layout str where
  lineLengths : str -> List Int

private
nat2int : Nat -> Int
nat2int  Z    = 0
nat2int (S x) = 1 + nat2int x

private
rowcol : List Int -> List Int -> (Int, Int)
rowcol       ws        []  = (0,0)  -- should not happen
rowcol (w :: ws) (x :: []) = (1 + (nat2int $ length ws), 1 + w-x)
rowcol (w :: ws) (x :: xs) = rowcol ws xs
rowcol       []        xs  = (0,0)  -- should not happen

private
formatItem : Layout str => str
                        -> (str, String)
                        -> String
formatItem whole (rest, msg)
  = let (row, col) = rowcol (reverse $ lineLengths whole) (reverse $ lineLengths rest)
    in "at " ++ show row ++ ":" ++ show col ++ " expected:\n  " ++ msg

formatError : Layout str => str
                         -> List (str, String)
                         -> String
formatError whole = unlines . map (formatItem whole)
-- --------------------------------------------------------------------- [ EOF ]


module Data.Compress.Inflate

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

public export
data InflateParserState'
  = InflateInit
  | InflateHuffman
  | InflateUncompressed
  | InflateEnd

public export
data InflateParserState : InflateParserState' -> Type where
  AtHeader : InflateParserState InflateInit
  AtHuffman : Bool -> HuffmanTree -> InflateParserState InflateHuffman
  AtUncompressed : Bool -> Nat -> InflateParserState InflateUncompressed
  AtEnd : SnocList Bits8 -> InflateParserState InflateEnd

public export
data InflateState
  = MkState Bitstream (FiniteBuffer Bits8) (DPair InflateParserState' InflateParserState)

match_off : List Nat
match_off = [ 3,4,5,6,7,8,9,10,11,13,15,17,19,23,27,31,35,43,51,59,67,83,99,115,131,163,195,227,258 ]

match_extra : List (Fin 32)
match_extra = [ 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0 ]

dist_off : List Nat
dist_off = [ 1,2,3,4,5,7,9,13,17,25,33,49,65,97,129,193,257,385,513,769,1025,1537,2049,3073,4097,6145,8193,12289,16385,24577 ]

dist_extra : List (Fin 32)
dist_extra = [ 0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13 ]

clen_alphabets : List (Fin 19)
clen_alphabets = [ 16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15 ]

length_lookup : Nat -> Maybe (Nat, Fin 32)
length_lookup n = Just (!(index_may n match_off), !(index_may n match_extra))

distance_lookup : Nat -> Maybe (Nat, Fin 32)
distance_lookup n = Just (!(index_may n dist_off), !(index_may n dist_extra))

parse_inflate_uncompressed_len : Parser Bitstream (SimpleError String) Nat
parse_inflate_uncompressed_len = do
  len <- le_nat 2
  nlen <- cast <$> le_nat 2
  let True = (cast {to=Bits16} len) == (complement nlen)
  | False => fail $ msg "invalid length header"
  pure len

-- List (literal, code length)
parse_inflate_code_lengths : Bits32 -> Maybe Bits32 -> Parser Bitstream (SimpleError String) (Fin 19) -> ?
parse_inflate_code_lengths n_lit_code supplied_prev_length parser = loop [] 0 where
  loop : List (Bits32, Bits32) -> Bits32 -> Parser Bitstream (SimpleError String) (List (Bits32, Bits32))
  loop acc current = if current >= n_lit_code then pure acc else parser >>= \case
    16 => do
      let Just prev_length = map snd (head' acc) <|> supplied_prev_length
      | Nothing => fail $ msg "asked for previous code length, but buffer is empty"
      n <- (3 +) <$> get_bits 2
      let literals = zip [current..(current + n - 1)] (take (cast n) $ repeat prev_length)
      loop (literals <+> acc) (current + n)
    17 => do
      n <- (3 +) <$> get_bits 3
      loop acc (current + n)
    18 => do
      n <- (11 +) <$> get_bits 7
      loop acc (current + n)
    n => do
      let len = cast $ finToNat n
      loop ((current, len) :: acc) (current + 1)

parse_inflate_dynamic : Parser Bitstream (SimpleError String) HuffmanTree
parse_inflate_dynamic = do
  n_lit_code <- (257 +) <$> get_bits 5
  n_dist_code <- (1 +) <$> get_bits 5
  n_len_code <- (cast . (4 +)) <$> get_bits 4
  let True = n_len_code <= 19
  | False => fail $ msg "n_len_code exceeds 19"
  alphabets <- for (take (cast n_len_code) clen_alphabets) (\k => (k,) <$> get_bits 3)
  let Just code_length_parser = make_tree alphabets 19
  | Nothing => fail $ msg "failed to generate code length tree"

  literals <- parse_inflate_code_lengths n_lit_code Nothing code_length_parser
  let Just prev_length = map snd $ head' literals
  | Nothing => fail $ msg "literals tree parser did nothing"
  let Just literals_parser = make_tree literals (cast n_lit_code)
  | Nothing => fail $ msg "failed to generate code literals tree"

  distances <- parse_inflate_code_lengths n_dist_code (Just prev_length) code_length_parser
  let Just distances_parser = make_tree distances (cast n_dist_code)
  | Nothing => fail $ msg "failed to generate code distances tree"

  pure (MkTree literals_parser distances_parser)

data HuffmanOutput = End | Literal Bits8 | Copy Nat Nat

parse_inflate_huffman : HuffmanTree -> Parser Bitstream (SimpleError String) HuffmanOutput
parse_inflate_huffman tree = do
  x <- tree.parse_literals
  if x < 256 then pure $ Literal (cast x)
    else if x == 256 then pure End
    else if x < 286 then do
      let Just (off, extra) = length_lookup (cast (x - 257))
      | Nothing => fail $ msg "length symbol out of bound"
      length <- map (\b => off + cast b) (get_bits extra)
      dcode <- tree.parse_distance

      let Just (off, extra) = distance_lookup (cast dcode)
      | Nothing => fail $ msg "distance symbol out of bound"
      distance <- map (\b => off + cast b) (get_bits extra)
      pure $ Copy (cast length) (cast distance)
    else fail $ msg "invalid code \{show x} encountered"

parse_inflate_header : Parser Bitstream (SimpleError String) (DPair InflateParserState' InflateParserState)
parse_inflate_header = do
  final <- token
  case !(count 2 token) of
    -- Uncompressed
    [False, False] => do
      len <- parse_inflate_uncompressed_len
      pure (_ ** AtUncompressed final len)
    -- Fixed Huffman
    [True , False] => do
      pure (_ ** AtHuffman final default_tree)
    -- Dynamic Huffman
    [False, True ] => do
      tree <- parse_inflate_dynamic
      pure (_ ** AtHuffman final tree)
    -- Invalid
    [True , True ] => do
      fail $ msg "invalid compression method"

next_state : (is_final : Bool) -> DPair InflateParserState' InflateParserState
next_state True  = (_ ** AtEnd [<])
next_state False = (_ ** AtHeader)

feed_inflate' : SnocList Bits8 -> FiniteBuffer Bits8 -> DPair InflateParserState' InflateParserState ->
                Bitstream -> Either String (SnocList Bits8, InflateState)

feed_inflate' acc ob (_ ** AtEnd leftover) content =
  Right (acc, MkState neutral (empty 0) (_ ** AtEnd (leftover <>< toBits8 content))) -- terminates

feed_inflate' acc ob (InflateInit ** state) content =
  case feed content parse_inflate_header of
    Pure leftover state =>
      feed_inflate' acc ob state leftover
    Fail err =>
      Left (show err)
    _ => -- underfed, need more input
      Right (acc, MkState content ob (_ ** AtHeader))

feed_inflate' acc ob (_ ** (AtUncompressed final remaining)) content =
  let (output, leftover) = fromBits8 <$> splitAt remaining (toBits8 content)
      ob = ob +<>< output
      acc = acc <>< output
  in case minus remaining (length output) of
       S n => Right (acc, MkState leftover ob (_ ** AtUncompressed final (S n))) -- underfed
       Z   => feed_inflate' acc ob (next_state final) leftover

feed_inflate' acc' ob (_ ** (AtHuffman final tree)) content = go acc' ob tree content where
  go : SnocList Bits8 -> FiniteBuffer Bits8 -> HuffmanTree -> Bitstream -> Either String (SnocList Bits8, InflateState)
  go acc ob tree input =
    case feed input (parse_inflate_huffman tree) of
      Fail err =>
        Left (show err)
      Pure leftover End =>
        feed_inflate' acc ob (next_state final) leftover
      Pure leftover (Literal literal) =>
        go (acc :< literal) (ob +< literal) tree leftover
      Pure leftover (Copy len distance) =>
        case take_last distance ob of
          Just copied_chunk =>
            let appended = take len $ stream_concat $ repeat copied_chunk
            in go (acc <>< appended) (ob +<>< appended) tree leftover
          Nothing => Left "asked for distance \{show distance} but only \{show (length ob)} in buffer"
      _ => -- underfed, need more input
        Right (acc, MkState input ob (_ ** (AtHuffman final tree)))

export
Decompressor InflateState where
  feed (MkState ib ob state) content = mapFst toList <$> feed_inflate' Lin ob state (ib <+> fromBits8 content)
  done (MkState _ _ (_ ** AtEnd leftover)) = Right (toList leftover)
  done _ = Left "inflate: underfed"
  init = MkState neutral (empty 32768) (_ ** AtHeader)


total twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible

partial loop : Void
loop = loop


import System.File
import Data.String
import Data.List

-- read in a dictionary, shuffle and then resort

mylast : List a -> Maybe a
mylast [] = Nothing
mylast [x] = Just x
mylast (x::xs) = mylast xs

doSort : Nat -> IO ()
doSort Z     = putStrLn "Done"
doSort (S k) = do Right dict<-readFile "words"
                   | Left err => putStrLn $ show err
                  -- reverse and get last word
                  let xs  = reverse $ words dict
                  putStrLn $ show $ mylast xs
                  -- sort reversed list and get last word
                  putStrLn $ show $ mylast $ sort xs
                  doSort k

main : IO ()
main = do max <- getLine
          doSort (integerToNat (cast max))


module Data.Compress.ZLib

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 ZLibParserState'
  = ZLibHead
  | ZLibFoot
  | ZLibInflate

public export
data ZLibParserState : ZLibParserState' -> Type where
  AtZHeader : ZLibParserState ZLibHead
  AtInflate : (adler32 : Bits32) -> InflateState -> ZLibParserState ZLibInflate
  AtZFooter : (adler32 : Bits32) -> ZLibParserState ZLibFoot

public export
data ZLibState
  = MkState (List Bits8) (DPair ZLibParserState' ZLibParserState)

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

record ZLibFooter where
  constructor MkZLibFooter
  adler32 : Bits32

export
parse_zlib_header : Parser (List Bits8) (SimpleError String) ()
parse_zlib_header = do
  cmf <- token
  flg <- token

  let True = 0 == (((shiftL {a=Bits16} (cast cmf) 8) .|. cast flg) `mod` 31)
  | False => fail $ msg "zlib: fcheck checksum failed"

  let False = testBit flg 5
  | True => fail $ msg "zlib: fdict is set"

  pure ()

update_adler32 : Bits32 -> List Bits8 -> Bits32
update_adler32 alder = go (alder .&. 0xffff) (shiftR alder 16) where
  go : Bits32 -> Bits32 -> List Bits8 -> Bits32
  go a b (x :: xs) =
    let base = 65521
        a' = (a + (cast x)) `mod` base
        b' = (a' + b) `mod` base
    in go a' b' xs
  go a b [] = (shiftL b 16) .|. a

export
parse_zlib_footer : Parser (List Bits8) (SimpleError String) ZLibFooter
parse_zlib_footer = do
  adler32 <- cast <$> p_be_nat 4
  pure (MkZLibFooter adler32)

feed_zlib' : SnocList Bits8 -> DPair ZLibParserState' ZLibParserState -> List Bits8 -> Either String (SnocList Bits8, ZLibState)
feed_zlib' acc (_ ** AtZHeader) [] = Right (acc, MkState [] (_ ** AtZHeader))
feed_zlib' acc (_ ** AtZHeader) content =
  case feed content parse_zlib_header of
    Pure leftover header => feed_zlib' acc (_ ** AtInflate 1 init) leftover
    Fail err => Left $ show err
    _ => Right (acc, MkState content (_ ** AtZHeader))
feed_zlib' acc (_ ** AtInflate adler32 inflate_state) content =
  case feed inflate_state content of
    Left err => Left err
    Right (uncompressed, (MkState _ _ (_ ** AtEnd leftover))) =>
      let adler32 = update_adler32 adler32 uncompressed
      in feed_zlib' (acc <>< uncompressed) (_ ** AtZFooter adler32) (toList leftover)
    Right (uncompressed, inflate_state) => -- underfed
      let adler32 = update_adler32 adler32 uncompressed
      in Right (acc <>< uncompressed, MkState [] (_ ** AtInflate adler32 inflate_state))
feed_zlib' acc (_ ** AtZFooter adler32) content =
  case feed content parse_zlib_footer of
    Pure leftover footer =>
      if footer.adler32 /= adler32
         then Left "adler32 mismatch \{show footer.adler32} \{show adler32}"
        else feed_zlib' acc (_ ** AtZHeader) leftover
    Fail err => Left $ show err
    _ => Right (acc, MkState content (_ ** AtZFooter adler32))

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


module DataTypes

import Ratio
import Data.Complex
import Control.ST.Exception
import Control.ST
import Environment
import ParserCombinator

%access public export

data Arity =
    Min Int
  | MinMax Int Int

mutual
    PrimitiveLispFunc : Type
    PrimitiveLispFunc = List LispVal -> ThrowsError LispVal

    ThrowsError : Type -> Type
    ThrowsError = Either LispError

    codata LispVal =
        LispVector Int (List LispVal) -- TODO: Array?
      | LispAtom String
      | LispList (List LispVal)
      | LispDottedList (List LispVal) LispVal
      | LispInteger Integer
      | LispFloat Double
      | LispComplex (Complex Double)
      | LispRational Rational
      | LispString String
      | LispCharacter Char
      | LispBool Bool
      | LispPrimitiveFunc String PrimitiveLispFunc
      | LispFunc String (List String) (Maybe String) (List LispVal) (EnvRef LispVal)
      | LispVoid

    data LispError = NumArgs Arity Integer (List LispVal)
        | TypeMismatch String LispVal
        | BadSpecialForm String LispVal
        | NotFunction String String
        | UnboundVar String String
        | LispParseError String Pos
        | Default String

mutual
  listEq : List LispVal -> List LispVal -> Bool
  listEq [] [] = True
  listEq (x::xs) (y::ys) = if x == y then listEq xs ys else False
  listEq _ _ = False

  Eq LispVal where
    (LispVector n a) == (LispVector m b) = if n == m then False else listEq a b
    (LispAtom a) == (LispAtom b) = a == b
    (LispList a) == (LispList b) = listEq a b
    (LispDottedList xs v1) == (LispDottedList ys v2) = if v1 == v2 then False else listEq xs ys
    (LispInteger n) == (LispInteger m) = n == m
    (LispFloat n) == (LispFloat m) = n == m
    (LispComplex n) == (LispComplex m) = n == m
    (LispRational n) == (LispRational m) = n == m
    (LispString a) == (LispString b) = a == b
    (LispCharacter a) == (LispCharacter b) = a == b
    (LispBool a) == (LispBool b) = a == b
    LispVoid == LispVoid = True
    -- LispPrimitiveFunc String PrimitiveLispFunc
    -- LispFunc String (List String) (Maybe String) (List LispVal) (EnvRef LispVal)
    x == y = False

interface (Exception m LispError, ConsoleIO m, Envir LispVal m) =>
          Context (m : Type -> Type) where

(Exception m LispError, ConsoleIO m, Envir LispVal m) => Context m where

mutual
    unwordsList : List LispVal -> String
    unwordsList = unwords . map showVal

    showVal : LispVal -> String
    showVal (LispString contents) = "\"" ++ contents ++ "\""
    showVal (LispAtom name') = name'
    showVal (LispInteger contents) = show contents
    showVal (LispFloat contents) = show contents
    showVal (LispComplex c) = show c
    showVal (LispRational (n .% d)) = show n++ "/" ++ show d
    showVal (LispBool True) = "#t"
    showVal (LispBool False) = "#f"
    showVal (LispList contents) = "(" ++ unwordsList contents ++ ")"
    showVal (LispVector n contents) = "#(" ++ unwordsList contents ++ ")"
    showVal (LispDottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")"
    showVal (LispFunc name _ _ _ _) = "#<procedure:" ++ name ++ ">"
    showVal LispVoid = ""
    showVal _ = ""

Show LispVal where
    show = showVal

showError : LispError -> String
showError (Default message) = message
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ (show form)
showError (NotFunction message func) = message ++ ": " ++ (show func)
showError (NumArgs expected found args) =
  let error' =
        case expected of
          Min min' =>
            "arity mismatch;\nthe expected number of arguments does not match the given number" ++
            "\nexpected: at least " ++ show min' ++ "\ngiven: " ++ show found
          MinMax min' max' =>
            "arity mismatch;\nthe expected number of arguments does not match the given number" ++
            "\nexpected: " ++
            (if min' == max'
               then show min'
               else "between " ++ show min' ++ " and " ++ show max') ++
            "\ngiven: " ++ show found
      argsError =
        case args of
          [] => ""
          a => "\narguments:\n" ++ unwordsList a
  in error' ++ argsError
showError (LispParseError parseErr pos) = "Parse error " ++ show pos
showError (TypeMismatch expected found) =
  "Invalid type: expected " ++ expected ++ ", found " ++ (show found)

Show LispError where
    show = showError


module Chapter.Concurrency.ProcessLib

import System.Concurrency.Channels

export
data MessagePID : (iface : reqType -> Type) -> Type where
     MkMessage : PID -> MessagePID iface

%access public export

NoRecv : Void -> Type
NoRecv = const Void

data ProcState = Ready
               | Sent
               | Looping

data Process : (iface : reqType -> Type) ->
               Type ->
               (in_state  : ProcState) ->
               (out_state : ProcState) ->
               Type where
     Request : MessagePID service_iface ->
               (msg : service_reqType) ->
               Process ifae (service_iface msg) st st
     Respond : ((msg : reqType) -> Process iface (iface msg) Ready Ready) ->
               Process iface (Maybe reqType) st Sent
     Spawn   : Process service_iface () Ready Looping ->
               Process iface (Maybe (MessagePID service_iface)) st st

     Loop    : Inf (Process iface a Ready Looping) ->
               Process iface a Sent Looping
     Action  : IO a -> Process iface a st st
     Pure    : a -> Process iface a st st
     (>>=)   : Process iface a st1 st2 ->
               (a -> Process iface b st2 st3) ->
               Process iface b st1 st3

data Fuel = Dry
          | More (Lazy Fuel)

%access export

partial
forever : Fuel
forever = More forever

run : Fuel -> Process iface t in_state out_state -> IO (Maybe t)
run fuel (Request {service_iface} (MkMessage proc) msg) =
    do Just chan <- connect proc
         | Nothing => pure Nothing
       if !(unsafeSend chan msg)
          then do Just x <- unsafeRecv (service_iface msg) chan
                    | Nothing => pure Nothing
                  pure (Just x)
          else pure Nothing
-- TODO: encapsulate timeout
run fuel (Respond {reqType} calc) =
    do Just sender <- listen 1
         | Nothing => pure (Just Nothing)
       Just msg <- unsafeRecv reqType sender
         | Nothing => pure (Just Nothing)
       Just res <- run fuel (calc msg)
         | Nothing => pure Nothing
       unsafeSend sender res
       pure (Just (Just msg))
run fuel (Spawn proc)       = do Just pid <- spawn (run fuel proc *> pure ())
                                   | Nothing => pure (Just Nothing)
                                 pure (Just (Just (MkMessage pid)))
run (More fuel) (Loop proc) = run fuel proc
run fuel (Action act)       = pure (Just !act)
run fuel (Pure val)         = pure (Just val)
run fuel (act >>= next)     = do Just x <- run fuel act
                                   | Nothing => pure Nothing
                                 run fuel (next x)
run Dry _                   = pure Nothing

%access public export

Service : (iface : reqType -> Type) -> Type -> Type
Service iface a = Process iface a Ready Looping

Client : Type -> Type
Client a = Process NoRecv a Ready Ready

partial export
runProc : Process iface () in_state out_state -> IO ()
runProc proc = run forever proc *> pure ()


module Main

import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Clock.System

%default total

partial main : IO ()
main = do
  do
    t <- getSystemLocalTime
    putStrLn $ "getSystemLocalTime : " ++ show t

  do
    t <- getSystemTime
    putStrLn $ "systemEpochDay : " ++ show systemEpochDay
    putStrLn $ "getSystemTIme : " ++ show t
    putStrLn $ "  systemToUTCTime : " ++ show (systemToUTCTime t)
    putStrLn $ "    <-> utcToSystemTime : " ++ show (utcToSystemTime (systemToUTCTime t))
    putStrLn $ "  truncateSystemTimeLeapSecond : " ++ show (truncateSystemTimeLeapSecond t)
    putStrLn $ show $ dayOfWeek $ fromGregorian 2021 8 21
    putStrLn $ show $ (modifiedJulianDay $ fromGregorian 2021 8 21) `mod` 7


||| Spec: https://webassembly.github.io/spec/core/syntax/modules.html#imports
module WebAssembly.Structure.Modules.Imports

import WebAssembly.Structure.Values
import WebAssembly.Structure.Types
import WebAssembly.Structure.Modules.Indices

-- Definition

public export
data ImportDesc : Type where
  FuncImport   : TypeIdx    -> ImportDesc
  TableImport  : TableType  -> ImportDesc
  MemImport    : MemType    -> ImportDesc
  GlobalImport : GlobalType -> ImportDesc

public export
record Import where
  constructor MkImport
  wmodule : Name
  name : Name
  desc : ImportDesc

-- Equality

total public export
lemma_funcimport__injective : ((f1 = f2) -> Void) -> (FuncImport f1 = FuncImport f2) -> Void
lemma_funcimport__injective f1_not_f2 Refl = f1_not_f2 Refl

total public export
lemma_tableimport__injective : ((t1 = t2) -> Void) -> (TableImport t1 = TableImport t2) -> Void
lemma_tableimport__injective t1_not_t2 Refl = t1_not_t2 Refl

total public export
lemma_memimport__injective : ((m1 = m2) -> Void) -> (MemImport m1 = MemImport m2) -> Void
lemma_memimport__injective m1_not_m2 Refl = m1_not_m2 Refl

total public export
lemma_globalimport__injective : ((g1 = g2) -> Void) -> (GlobalImport g1 = GlobalImport g2) -> Void
lemma_globalimport__injective g1_not_g2 Refl = g1_not_g2 Refl

total public export
lemma_funcimport_not_tableexport : (FuncImport f = TableImport t) -> Void
lemma_funcimport_not_tableexport Refl impossible

total public export
lemma_funcimport_not_memexport : (FuncImport f = MemImport m) -> Void
lemma_funcimport_not_memexport Refl impossible

total public export
lemma_funcimport_not_globalexport : (FuncImport f = GlobalImport g) -> Void
lemma_funcimport_not_globalexport Refl impossible

total public export
lemma_tableimport_not_funcexport : (TableImport t = FuncImport f) -> Void
lemma_tableimport_not_funcexport Refl impossible

total public export
lemma_tableimport_not_memexport : (TableImport t = MemImport m) -> Void
lemma_tableimport_not_memexport Refl impossible

total public export
lemma_tableimport_not_globalexport : (TableImport t = GlobalImport g) -> Void
lemma_tableimport_not_globalexport Refl impossible

total public export
lemma_memimport_not_tableexport : (MemImport m = TableImport t) -> Void
lemma_memimport_not_tableexport Refl impossible

total public export
lemma_memimport_not_funcxport : (MemImport m = FuncImport f) -> Void
lemma_memimport_not_funcxport Refl impossible

total public export
lemma_memimport_not_globalexport : (MemImport m = GlobalImport g) -> Void
lemma_memimport_not_globalexport Refl impossible

total public export
lemma_globalimport_not_tableexport : (GlobalImport g = TableImport t) -> Void
lemma_globalimport_not_tableexport Refl impossible

total public export
lemma_globalimport_not_funcxport : (GlobalImport g = FuncImport m) -> Void
lemma_globalimport_not_funcxport Refl impossible

total public export
lemma_globalimport_not_memexport : (GlobalImport g = MemImport m) -> Void
lemma_globalimport_not_memexport Refl impossible

total public export
lemma_import__module_injective : ((m1 = m2) -> Void) -> (MkImport m1 n1 d1 = MkImport m2 n2 d2) -> Void
lemma_import__module_injective m1_not_m2 Refl = m1_not_m2 Refl

total public export
lemma_import__name_injective : ((n1 = n2) -> Void) -> (MkImport m1 n1 d1 = MkImport m2 n2 d2) -> Void
lemma_import__name_injective n1_not_n2 Refl = n1_not_n2 Refl

total public export
lemma_import__desc_injective : ((d1 = d2) -> Void) -> (MkImport m1 n1 d1 = MkImport m2 n2 d2) -> Void
lemma_import__desc_injective d1_not_d2 Refl = d1_not_d2 Refl

-- Decidable Equality

public export
implementation DecEq ImportDesc where
  decEq (FuncImport x)   (FuncImport y)   = case decEq x y of
    No x_not_y => No $ lemma_funcimport__injective x_not_y
    Yes Refl   => Yes Refl
  decEq (FuncImport x)   (TableImport y)  = No lemma_funcimport_not_tableexport
  decEq (FuncImport x)   (MemImport y)    = No lemma_funcimport_not_memexport
  decEq (FuncImport x)   (GlobalImport y) = No lemma_funcimport_not_globalexport
  decEq (TableImport x)  (FuncImport y)   = No lemma_tableimport_not_funcexport
  decEq (TableImport x)  (TableImport y)  = case decEq x y of
    No x_not_y => No $ lemma_tableimport__injective x_not_y
    Yes Refl   => Yes Refl
  decEq (TableImport x)  (MemImport y)    = No lemma_tableimport_not_memexport
  decEq (TableImport x)  (GlobalImport y) = No lemma_tableimport_not_globalexport
  decEq (MemImport x)    (FuncImport y)   = No lemma_memimport_not_funcxport
  decEq (MemImport x)    (TableImport y)  = No lemma_memimport_not_tableexport
  decEq (MemImport x)    (MemImport y)    = case decEq x y of
    No x_not_y => No $ lemma_memimport__injective x_not_y
    Yes Refl   => Yes Refl
  decEq (MemImport x)    (GlobalImport y) = No lemma_memimport_not_globalexport
  decEq (GlobalImport x) (FuncImport y)   = No lemma_globalimport_not_funcxport
  decEq (GlobalImport x) (TableImport y)  = No lemma_globalimport_not_tableexport
  decEq (GlobalImport x) (MemImport y)    = No lemma_globalimport_not_memexport
  decEq (GlobalImport x) (GlobalImport y) = case decEq x y of
    No x_not_y => No $ lemma_globalimport__injective x_not_y
    Yes Refl   => Yes Refl

public export
implementation DecEq Import where
  decEq (MkImport m1 n1 d1) (MkImport m2 n2 d2) = case decEq m1 m2 of
    No m1_not_m2 => No $ lemma_import__module_injective m1_not_m2
    Yes Refl     => case decEq n1 n2 of
      No n1_not_n2 => No $ lemma_import__name_injective n1_not_n2
      Yes Refl     => case decEq d1 d2 of
        No d1_not_d2 => No $ lemma_import__desc_injective d1_not_d2
        Yes Refl     => Yes Refl


module Data.Bytes.Util

moduleName : String
moduleName = "Data.Bytes.Util"

export
replicateM : Applicative f => Int -> f a -> f (List a)
replicateM n act = if 0 >= n then pure []
                             else [| act :: replicateM (n-1) act |]

-- Try not to use this, it'd be quite slow, better to use a casting prim of
-- some kind when one exists. This still has to +1 over and over after Nat is
-- optimized to Integer.
export
intToNat : Int -> Nat
intToNat i = if i >= 0 then go i else Z
  where
    go : Int -> Nat
    go 0 = Z
    go k = 1 + go (k-1)

-------------------------------------------------
-- Lies
-------------------------------------------------

-- Why lie about totality?

-- One may ask "If a thing can fail is it not partial?" but consider the total
-- expression x :: xs, if we fail to allocate space when applying :: does that
-- mean :: was partial all along? That's simply a failure of the system we're
-- running on not a failure of totality. The single intended use of this lie is
-- during allocation of bytes in memory. This is why we're lying here: There's
-- no reason to infect a whole codebase with partiality when it's outside
-- allocation that is failing.

-- TODO: bring this up with other devs for idris about it's merits and negatives
-- The less backdoors the better imo but this seems like a innocuous thing.
private
total
%foreign "scheme:lambda (x) (blodwen-error-quit x)"
lie_idris_crash : String -> a

export
total
lieErrorCall : String -> String -> String -> a
lieErrorCall mod fn_name msg = lie_idris_crash $ mod ++ ":" ++ fn_name ++ ": " ++ msg

-------------------------------------------------

export
partial
errorCall : String -> String -> String -> a
errorCall mod fn_name msg = idris_crash $ mod ++ ":" ++ fn_name ++ ": " ++ msg

-- It'd be nice to have have statically enforced size limits but it's a little
-- onerous at this stage and not something we should be forcing on users.
-- Integer would be safer but there's a (likely) size and performance hit that
-- would need investigating, tied with the fact that our Bytes can only be Int
-- large in the first place so that just moves the check not elimates it.
export
partial
checkedAdd : String -> String -> Int -> Int -> Int
checkedAdd mod fun x y
  = let v = x + y
    in if v >= 0 then v else errorCall mod fun $
         "numeric overflow: " ++ show x ++ " + " ++ show y ++ " = " ++ show v

public export
total -- minus where negative results are just 0
monus : Nat -> Nat -> Nat
monus n 0 = n
monus 0 n = 0
monus (S j) (S k) = monus j k

----------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------

-- For when Lazy is causing type problems
infixr 4 &&|
export
(&&|) : Bool -> Bool -> Bool
(&&|) x y = x && y


module Circuits.Idealised.Pretty

import System.File

import Data.String

import Text.Lexer
import Text.Parser

import Toolkit.Data.DList
import Toolkit.Data.Whole
import Toolkit.Data.Location
import Toolkit.Text.Lexer.Run
import Toolkit.Text.Parser.Run

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

import Toolkit.DeBruijn.Context.Item
import Toolkit.DeBruijn.Context

import public Circuits.Common.Pretty
import        Circuits.Idealised.Error
import        Circuits.Idealised.Lexer
import        Circuits.Idealised.Types

%default total

export
Show Direction where
  show INPUT  = "input"
  show OUTPUT = "output"

export
Show Ty where
  show TyUnit = "()"
  show (TyPort (d,t)) = concat ["TyPort(", show d, ",", show t, ")"]
  show TyGate = "TyGate"

export
Show GateKind where
  show AND  = "and"
  show IOR  = "or"
  show XOR  = "xor"
  show ANDN = "nand"
  show IORN = "nor"
  show XORN = "xnor"
  show JOIN = "join"

showEnv : Context (Ty,Usage) type -> String
showEnv [] = ""
showEnv ((I name (type, FREE)) :: rest)
  = name <+> " : " <+> show type <+> "\n" <+> (showEnv rest)
showEnv ((I name (type, USED)) :: rest) = showEnv rest

export
Show FailingEdgeCase where
  show (InvalidSplit p s l r) = "Pivot (" <+> show p <+> ") is wrong do not add up: " <+> unwords [show s, "!= 1 + ", show l, "+", show r]
  show (InvalidEdge  s l r) = "Indices do not add up: " <+> unwords [show s, "= 1 + ", show l, "+", show r]

export
Show Check.Error where
  show (Mismatch x y)
    = "Type Mismatch:\n\n"
      <+> unlines [unwords ["\tExpected:",show x], unwords ["\tGiven:", show y]]

  show (MismatchGate x y)
    = "Type Mismatch:\n\n"
     <+> unlines [unwords ["\tExpected:",show x], unwords ["\tGiven:", show y]]

  show (ElemFail x (NotSatisfied ()))
    = unwords ["Port is used:", x]

  show (ElemFail x NotFound)
    = "\{x} not found."

  show (NotEdgeCase r)  = "Not an edge case:\n\n" <+> show r
  show (PortExpected INPUT) = "Expected an Input Port"
  show (PortExpected OUTPUT) = "Expected an Output Port"
  show (LinearityError env) = "Dangling Ports:\n\n" <+> showEnv env
  show (VectorExpected) = "Vector Expected"
  show (VectorTooShort) = "Output Vector must be a length greater or equal to two."
  show (VectorSizeMismatch o a b)
    = unlines [ "Output Vector and input are wrong sizes:"
              , unwords ["\t" <+> show o, "!=", show a, "+", show b]]
  show (Err x y) = unwords [show x, show y]

export
Show (Idealised.Error) where
  show (TyCheck x) = show x
  show (Parse f n) = show @{circuitspe} n
  show (Sound g e)
    = unlines ["// LOG : Soundness Error:", showErr (g, e)]

-- [ EOF ]


||| Sets and display version of Idris.
module Idris.Version

import IdrisPaths
import Data.List

%default total

||| Semantic versioning with optional tag
||| See [semver](https://semver.org/) for proper definition of semantic versioning
public export
record Version where
  constructor MkVersion
  ||| Semantic version
  ||| Should follow the (major, minor, patch) convention
  semVer : (Nat, Nat, Nat)
  ||| Optional tag
  ||| Usually contains git sha1 of this software's build in between releases
  versionTag : Maybe String

export
version : Version
version with (idrisVersion)
 version | (s,"") = MkVersion s Nothing
 version | (s,t) = MkVersion s (Just t)

export
showVersion : Bool -> Version -> String
showVersion tag (MkVersion (maj,min,patch) versionTag) =
  concat (intersperse "." (map show [ maj, min, patch])) ++
         if tag then showTag else ""
  where
    showTag : String
    showTag = case versionTag of
                Nothing => ""
                Just tag => "-" ++ tag