module Data.Colist1

import Data.Colist
import Data.List
import Data.List1
import Data.Nat
import Data.Stream
import public Data.Zippable

%default total

||| A possibly finite, non-empty Stream.
public export
data Colist1 : (a : Type) -> Type where
  (:::) : a -> Colist a -> Colist1 a

--------------------------------------------------------------------------------
--          Creating Colist1
--------------------------------------------------------------------------------

||| Convert a `List1` to a `Colist1`.
public export
fromList1 : List1 a -> Colist1 a
fromList1 (h ::: t) = h ::: fromList t

||| Convert a stream to a `Colist1`.
public export
fromStream : Stream a -> Colist1 a
fromStream (x :: xs) = x ::: fromStream xs

||| Try to convert a `Colist` to a `Colist1`. Returns `Nothing` if
||| the given `Colist` is empty.
public export
fromColist : Colist a -> Maybe (Colist1 a)
fromColist Nil       = Nothing
fromColist (x :: xs) = Just (x ::: xs)

||| Try to convert a list to a `Colist1`. Returns `Nothing` if
||| the given list is empty.
public export
fromList : List a -> Maybe (Colist1 a)
fromList = fromColist . fromList

||| Create a `Colist1` of only a single element.
public export
singleton : a -> Colist1 a
singleton a = a ::: Nil

||| An infinite `Colist1` of repetitions of the same element.
public export
repeat : a -> Colist1 a
repeat v = v ::: repeat v

||| Create a `Colist1` of `n` replications of the given element.
public export
replicate : (n : Nat) -> {auto 0 prf : IsSucc n} -> a -> Colist1 a
replicate 0     _ impossible
replicate (S k) x = x ::: replicate k x

||| Produce a `Colist1` by repeating a sequence
public export
cycle : List1 a -> Colist1 a
cycle (x ::: xs) = x ::: cycle (xs ++ [x])

||| Generate an infinite `Colist1` by repeatedly applying a function.
public export
iterate : (f : a -> a) -> a -> Colist1 a
iterate f a  = a ::: iterate f (f a)

||| Generate a `Colist1` by repeatedly applying a function.
||| This stops once the function returns `Nothing`.
public export
iterateMaybe : (f : a -> Maybe a) -> a -> Colist1 a
iterateMaybe f a  = a ::: iterateMaybe f (f a)

||| Generate a `Colist1` by repeatedly applying a function
||| to a seed value.
||| This stops once the function returns `Nothing`.
public export
unfold : (f : s -> Maybe (s,a)) -> s -> a -> Colist1 a
unfold f s a = a ::: unfold f s

--------------------------------------------------------------------------------
--          Basic Functions
--------------------------------------------------------------------------------

||| Convert a `Colist1` to a `Colist`
public export
forget : Colist1 a -> Colist a
forget (h ::: t) = h :: t

||| Convert an `Inf (Colist1 a)` to an `Inf (Colist a)`
public export
forgetInf : Inf (Colist1 a) -> Inf (Colist a)
forgetInf (h ::: t) = h :: t

||| Prepends an element to a `Colist1`.
public export
cons : (x : a) -> (xs : Colist1 a) -> Colist1 a
cons x xs = x ::: forget xs

||| Concatenate two `Colist1`s
public export
append : Colist1 a -> Colist1 a -> Colist1 a
append (h ::: t) ys = h ::: append t (forget ys)

||| Append a `Colist1` to a `List`.
public export
lappend : List a -> Colist1 a -> Colist1 a
lappend Nil       ys = ys
lappend (x :: xs) ys = x ::: lappend xs (forget ys)

||| Append a `List` to a `Colist1`.
public export
appendl : Colist1 a -> List a -> Colist1 a
appendl (x ::: xs) ys = x ::: appendl xs ys

||| Take a `Colist1` apart
public export
uncons : Colist1 a -> (a, Colist a)
uncons (h ::: tl) = (h, tl)

||| Extract the first element from a `Colist1`
public export
head : Colist1 a -> a
head (h ::: _) = h

||| Drop the first element from a `Colist1`
public export
tail : Colist1 a -> Colist a
tail (_ ::: t) = t

||| Take up to `n` elements from a `Colist1`
public export
take : (n : Nat) -> {auto 0 prf : IsSucc n} -> Colist1 a -> List1 a
take 0     _          impossible
take (S k) (x ::: xs) = x ::: take k xs

||| Take elements from a `Colist1` up to and including the
||| first element, for which `p` returns `True`.
public export
takeUntil : (p : a -> Bool) -> Colist1 a -> Colist1 a
takeUntil p (x ::: xs) = if p x then singleton x else x ::: takeUntil p xs

||| Take elements from a `Colist1` up to (but not including) the
||| first element, for which `p` returns `True`.
public export
takeBefore : (p : a -> Bool) -> Colist1 a -> Colist a
takeBefore p = takeBefore p . forget

||| Take elements from a `Colist1` while the given predicate `p`
||| returns `True`.
public export
takeWhile : (p : a -> Bool) -> Colist1 a -> Colist a
takeWhile p = takeWhile p . forget

||| Extract all values wrapped in `Just` from the beginning
||| of a `Colist1`. This stops, once the first `Nothing` is encountered.
public export
takeWhileJust : Colist1 (Maybe a) -> Colist a
takeWhileJust = takeWhileJust . forget

||| Drop up to `n` elements from the beginning of the `Colist1`.
public export
drop : (n : Nat) -> Colist1 a -> Colist a
drop n = drop n . forget

||| Try to extract the `n`-th element from a `Colist1`.
public export
index : (n : Nat) -> Colist1 a -> Maybe a
index n = index n . forget

||| Produce a `Colist1` of left folds of prefixes of the given `Colist1`.
||| @ f the combining function
||| @ acc the initial value
||| @ xs the `Colist1` to process
export
scanl : (f : a -> b -> a) -> (acc : a) -> (xs : Colist1 b) -> Colist1 a
scanl f acc (x ::: xs) = acc ::: scanl f (f acc x) xs

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

public export
Semigroup (Colist1 a) where
  (<+>) = append

public export
Functor Colist1 where
  map f (x ::: xs) = f x ::: map f xs

public export
Applicative Colist1 where
  pure = repeat

  (f ::: fs) <*> (a ::: as) = f a ::: (fs <*> as)

public export
Zippable Colist1 where
  zipWith f (x ::: xs) (y ::: ys) = f x y ::: zipWith f xs ys

  zipWith3 f (x ::: xs) (y ::: ys) (z ::: zs) =
    f x y z ::: zipWith3 f xs ys zs

  unzip xs = (map fst xs, map snd xs)

  unzip3 xs = ( map (\(a,_,_) => a) xs
              , map (\(_,b,_) => b) xs
              , map (\(_,_,c) => c) xs
              )

  unzipWith f = unzip . map f

  unzipWith3 f = unzip3 . map f

--------------------------------------------------------------------------------
-- Interleavings
--------------------------------------------------------------------------------

-- zig, zag, and cantor are taken from the paper
-- Applications of Applicative Proof Search
-- by Liam O'Connor

public export
zig : List1 (Colist1 a) -> Colist (Colist1 a) -> Colist a

public export
zag : List1 a -> List (Colist1 a) -> Colist (Colist1 a) -> Colist a

zig xs = zag (head <$> xs) (mapMaybe (fromColist . tail) $ forget xs)

zag (x ::: []) [] [] = x :: []
zag (x ::: []) (z :: zs) [] = x :: zig (z ::: zs) []
zag (x ::: []) zs (l :: ls) = x :: zig (l ::: zs) ls
zag (x ::: (y :: xs)) zs ls = x :: zag (y ::: xs) zs ls

public export
cantor : Colist1 (Colist1 a) -> Colist1 a
cantor (xxs ::: []) = xxs
cantor ((x ::: xs) ::: (yys :: zzss))
  = x ::: zig (yys ::: mapMaybe fromColist [xs]) zzss

namespace Colist

  public export
  cantor : List (Colist a) -> Colist a
  cantor xs =
    let Just (l ::: ls) = List.toList1' $ mapMaybe fromColist xs
          | Nothing => []
    in zig (l ::: []) (fromList ls)

  -- Exploring the (truncated) Nat*Nat top right quadrant of the plane
  -- using Cantor's zig-zag traversal:
  example :
     let nats : Colist Nat; nats = fromStream Stream.nats in
     take 10 (Colist.cantor [ map (0,) nats
                            , map (1,) nats
                            , map (2,) nats
                            , map (3,) nats])
     === [ (0, 0)
         , (1, 0), (0, 1)
         , (2, 0), (1, 1), (0, 2)
         , (3, 0), (2, 1), (1, 2), (0, 3)
         ]
  example = Refl

namespace DPair

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  planeWith : {0 p : a -> Type} ->
              ((x : a) -> p x -> c) ->
              Colist1 a -> ((x : a) -> Colist1 (p x)) ->
              Colist1 c
  planeWith k as f = cantor (map (\ x => map (k x) (f x)) as)

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  plane : {0 p : a -> Type} ->
          Colist1 a -> ((x : a) -> Colist1 (p x)) ->
          Colist1 (x : a ** p x)
  plane = planeWith (\ x, prf => (x ** prf))

namespace Pair

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  planeWith : (a -> b -> c) ->
              Colist1 a -> (a -> Colist1 b) ->
              Colist1 c
  planeWith k as f = cantor (map (\ x => map (k x) (f x)) as)

  ||| Explore the plane corresponding to all possible pairings
  ||| using Cantor's zig zag traversal
  public export
  plane : Colist1 a -> (a -> Colist1 b) -> Colist1 (a, b)
  plane = Pair.planeWith (,)

--------------------------------------------------------------------------------
-- Example
--------------------------------------------------------------------------------

-- Exploring the Nat*Nat top right quadrant of the plane
-- using Cantor's zig-zag traversal:
example :
     let nats1 = fromStream Stream.nats in
     Colist1.take 10 (Pair.plane nats1 (const nats1))
     === (0, 0) :::
         [ (1, 0), (0, 1)
         , (2, 0), (1, 1), (0, 2)
         , (3, 0), (2, 1), (1, 2), (0, 3)
         ]
example = Refl


module Compiler.CaseOpts

-- Case block related transformations

import Compiler.CompileExpr

import Core.CompileExpr
import Core.Context
import Core.FC
import Core.TT

import Data.List
import Data.Vect

%default covering

{-
Lifting out lambdas:

case t of
     C1 => \x1 => e1
     ...
     Cn => \xn = en

  where every branch begins with a lambda, can become:

\x => case t of
           C1 => e1[x/x1]
           ,,,
           Cn => en[x/xn]
-}

shiftUnder : {args : _} ->
             {idx : _} ->
             (0 p : IsVar n idx (x :: args ++ vars)) ->
             NVar n (args ++ x :: vars)
shiftUnder First = weakenNVar (mkSizeOf args) (MkNVar First)
shiftUnder (Later p) = insertNVar (mkSizeOf args) (MkNVar p)

shiftVar : {outer, args : _} ->
           {idx : _} ->
           (0 p : IsVar n idx (outer ++ (x :: args ++ vars))) ->
           NVar n (outer ++ (args ++ x :: vars))
shiftVar {outer = []} p = shiftUnder p
shiftVar {outer = (n::xs)} First = MkNVar First
shiftVar {outer = (y::xs)} (Later p)
    = case shiftVar p of
           MkNVar p' => MkNVar (Later p')

mutual
  shiftBinder : {outer, args : _} ->
                (new : Name) ->
                CExp (outer ++ old :: (args ++ vars)) ->
                CExp (outer ++ (args ++ new :: vars))
  shiftBinder new (CLocal fc p)
      = case shiftVar p of
             MkNVar p' => CLocal fc (renameVar p')
    where
      renameVar : IsVar x i (outer ++ (args ++ (old :: rest))) ->
                  IsVar x i (outer ++ (args ++ (new :: rest)))
      renameVar = believe_me -- it's the same index, so just the identity at run time
  shiftBinder new (CRef fc n) = CRef fc n
  shiftBinder {outer} new (CLam fc n sc)
      = CLam fc n $ shiftBinder {outer = n :: outer} new sc
  shiftBinder new (CLet fc n inlineOK val sc)
      = CLet fc n inlineOK (shiftBinder new val)
                           $ shiftBinder {outer = n :: outer} new sc
  shiftBinder new (CApp fc f args)
      = CApp fc (shiftBinder new f) $ map (shiftBinder new) args
  shiftBinder new (CCon fc ci c tag args)
      = CCon fc ci c tag $ map (shiftBinder new) args
  shiftBinder new (COp fc op args) = COp fc op $ map (shiftBinder new) args
  shiftBinder new (CExtPrim fc p args)
      = CExtPrim fc p $ map (shiftBinder new) args
  shiftBinder new (CForce fc r arg) = CForce fc r $ shiftBinder new arg
  shiftBinder new (CDelay fc r arg) = CDelay fc r $ shiftBinder new arg
  shiftBinder new (CConCase fc sc alts def)
      = CConCase fc (shiftBinder new sc)
                    (map (shiftBinderConAlt new) alts)
                    (map (shiftBinder new) def)
  shiftBinder new (CConstCase fc sc alts def)
      = CConstCase fc (shiftBinder new sc)
                      (map (shiftBinderConstAlt new) alts)
                      (map (shiftBinder new) def)
  shiftBinder new (CPrimVal fc c) = CPrimVal fc c
  shiftBinder new (CErased fc) = CErased fc
  shiftBinder new (CCrash fc msg) = CCrash fc msg

  shiftBinderConAlt : {outer, args : _} ->
                (new : Name) ->
                CConAlt (outer ++ (x :: args ++ vars)) ->
                CConAlt (outer ++ (args ++ new :: vars))
  shiftBinderConAlt new (MkConAlt n ci t args' sc)
      = let sc' : CExp ((args' ++ outer) ++ (x :: args ++ vars))
                = rewrite sym (appendAssociative args' outer (x :: args ++ vars)) in sc in
        MkConAlt n ci t args' $
           rewrite (appendAssociative args' outer (args ++ new :: vars))
             in shiftBinder new {outer = args' ++ outer} sc'

  shiftBinderConstAlt : {outer, args : _} ->
                (new : Name) ->
                CConstAlt (outer ++ (x :: args ++ vars)) ->
                CConstAlt (outer ++ (args ++ new :: vars))
  shiftBinderConstAlt new (MkConstAlt c sc) = MkConstAlt c $ shiftBinder new sc

-- If there's a lambda inside a case, move the variable so that it's bound
-- outside the case block so that we can bind it just once outside the block
liftOutLambda : {args : _} ->
                (new : Name) ->
                CExp (old :: args ++ vars) ->
                CExp (args ++ new :: vars)
liftOutLambda = shiftBinder {outer = []}

-- If all the alternatives start with a lambda, we can have a single lambda
-- binding outside
tryLiftOut : (new : Name) ->
             List (CConAlt vars) ->
             Maybe (List (CConAlt (new :: vars)))
tryLiftOut new [] = Just []
tryLiftOut new (MkConAlt n ci t args (CLam fc x sc) :: as)
    = do as' <- tryLiftOut new as
         let sc' = liftOutLambda new sc
         pure (MkConAlt n ci t args sc' :: as')
tryLiftOut _ _ = Nothing

tryLiftOutConst : (new : Name) ->
                  List (CConstAlt vars) ->
                  Maybe (List (CConstAlt (new :: vars)))
tryLiftOutConst new [] = Just []
tryLiftOutConst new (MkConstAlt c (CLam fc x sc) :: as)
    = do as' <- tryLiftOutConst new as
         let sc' = liftOutLambda {args = []} new sc
         pure (MkConstAlt c sc' :: as')
tryLiftOutConst _ _ = Nothing

tryLiftDef : (new : Name) ->
             Maybe (CExp vars) ->
             Maybe (Maybe (CExp (new :: vars)))
tryLiftDef new Nothing = Just Nothing
tryLiftDef new (Just (CLam fc x sc))
   = let sc' = liftOutLambda {args = []} new sc in
         pure (Just sc')
tryLiftDef _ _ = Nothing

allLams : List (CConAlt vars) -> Bool
allLams [] = True
allLams (MkConAlt n ci t args (CLam _ _ _) :: as)
   = allLams as
allLams _ = False

allLamsConst : List (CConstAlt vars) -> Bool
allLamsConst [] = True
allLamsConst (MkConstAlt c (CLam _ _ _) :: as)
   = allLamsConst as
allLamsConst _ = False

-- label for next name for a lambda. These probably don't need really to be
-- unique, since we've proved things about the de Bruijn index, but it's easier
-- to see what's going on if they are.
data NextName : Type where

getName : {auto n : Ref NextName Int} ->
          Core Name
getName
    = do n <- get NextName
         put NextName (n + 1)
         pure (MN "clam" n)

-- The transformation itself
mutual
  caseLam : {auto n : Ref NextName Int} ->
            CExp vars -> Core (CExp vars)
  -- Interesting cases first: look for case blocks where every branch is a
  -- lambda
  caseLam (CConCase fc sc alts def)
      = if allLams alts && defLam def
           then do var <- getName
                   -- These will work if 'allLams' and 'defLam' are consistent.
                   -- We only do that boolean check because it saves us doing
                   -- unnecessary work (say, if the last one we try fails)
                   let Just newAlts = tryLiftOut var alts
                            | Nothing => throw (InternalError "Can't happen caseLam 1")
                   let Just newDef = tryLiftDef var def
                            | Nothing => throw (InternalError "Can't happen caseLam 2")
                   newAlts' <- traverse caseLamConAlt newAlts
                   newDef' <- traverseOpt caseLam newDef
                   -- Q: Should we go around again?
                   pure (CLam fc var (CConCase fc (weaken sc) newAlts' newDef'))
           else do sc' <- caseLam sc
                   alts' <- traverse caseLamConAlt alts
                   def' <- traverseOpt caseLam def
                   pure (CConCase fc sc' alts' def')
    where
      defLam : Maybe (CExp vars) -> Bool
      defLam Nothing = True
      defLam (Just (CLam _ _ _)) = True
      defLam _ = False
  -- Next case is pretty much as above. There's a boring amount of repetition
  -- here because ConstCase is just a little bit different.
  caseLam (CConstCase fc sc alts def)
      = if allLamsConst alts && defLam def
           then do var <- getName
                   -- These will work if 'allLams' and 'defLam' are consistent.
                   -- We only do that boolean check because it saves us doing
                   -- unnecessary work (say, if the last one we try fails)
                   let Just newAlts = tryLiftOutConst var alts
                            | Nothing => throw (InternalError "Can't happen caseLam 1")
                   let Just newDef = tryLiftDef var def
                            | Nothing => throw (InternalError "Can't happen caseLam 2")
                   newAlts' <- traverse caseLamConstAlt newAlts
                   newDef' <- traverseOpt caseLam newDef
                   pure (CLam fc var (CConstCase fc (weaken sc) newAlts' newDef'))
           else do sc' <- caseLam sc
                   alts' <- traverse caseLamConstAlt alts
                   def' <- traverseOpt caseLam def
                   pure (CConstCase fc sc' alts' def')
    where
      defLam : Maybe (CExp vars) -> Bool
      defLam Nothing = True
      defLam (Just (CLam _ _ _)) = True
      defLam _ = False
  -- Structural recursive cases
  caseLam (CLam fc x sc)
      = CLam fc x <$> caseLam sc
  caseLam (CLet fc x inl val sc)
      = CLet fc x inl <$> caseLam val <*> caseLam sc
  caseLam (CApp fc f args)
      = CApp fc <$> caseLam f <*> traverse caseLam args
  caseLam (CCon fc n ci t args)
      = CCon fc n ci t <$> traverse caseLam args
  caseLam (COp fc op args)
      = COp fc op <$> traverseVect caseLam args
  caseLam (CExtPrim fc p args)
      = CExtPrim fc p <$> traverse caseLam args
  caseLam (CForce fc r x)
      = CForce fc r <$> caseLam x
  caseLam (CDelay fc r x)
      = CDelay fc r <$> caseLam x
  -- All the others, no recursive case so just return the input
  caseLam x = pure x

  caseLamConAlt : {auto n : Ref NextName Int} ->
                  CConAlt vars -> Core (CConAlt vars)
  caseLamConAlt (MkConAlt n ci tag args sc)
      = MkConAlt n ci tag args <$> caseLam sc

  caseLamConstAlt : {auto n : Ref NextName Int} ->
                    CConstAlt vars -> Core (CConstAlt vars)
  caseLamConstAlt (MkConstAlt c sc) = MkConstAlt c <$> caseLam sc

export
caseLamDef : {auto c : Ref Ctxt Defs} ->
             Name -> Core ()
caseLamDef n
    = do defs <- get Ctxt
         Just def <- lookupCtxtExact n (gamma defs) | Nothing => pure ()
         let Just cexpr =  compexpr def             | Nothing => pure ()
         setCompiled n !(doCaseLam cexpr)
  where
    doCaseLam : CDef -> Core CDef
    doCaseLam (MkFun args def)
        = do n <- newRef NextName 0
             pure $ MkFun args !(caseLam def)
    doCaseLam d = pure d

{-

Case of case:

case (case x of C1 => E1
                C2 => E2
                ...) of
     D1 => F1
     D2 => F2
     ...
     _ => Fd

can become

case x of
     C1 => case E1 of
                D1 => F1
                D2 => F2
                ...
                _ => Fd
     C2 => case E2 of
                D1 => F1
                D2 => F2
                ...
                _ => Fd

to minimise risk of duplication, do this only when E1, E2 are all
constructor headed, or there's only one branch (for now)

-}

doCaseOfCase : FC ->
               (x : CExp vars) ->
               (xalts : List (CConAlt vars)) ->
               (alts : List (CConAlt vars)) ->
               (def : Maybe (CExp vars)) ->
               CExp vars
doCaseOfCase fc x xalts alts def
    = CConCase fc x (map updateAlt xalts) Nothing
  where
    updateAlt : CConAlt vars -> CConAlt vars
    updateAlt (MkConAlt n ci t args sc)
        = MkConAlt n ci t args $
              CConCase fc sc
                       (map (weakenNs (mkSizeOf args)) alts)
                       (map (weakenNs (mkSizeOf args)) def)

doCaseOfConstCase : FC ->
                    (x : CExp vars) ->
                    (xalts : List (CConstAlt vars)) ->
                    (alts : List (CConstAlt vars)) ->
                    (def : Maybe (CExp vars)) ->
                    CExp vars
doCaseOfConstCase fc x xalts alts def
    = CConstCase fc x (map updateAlt xalts) Nothing
  where
    updateAlt : CConstAlt vars -> CConstAlt vars
    updateAlt (MkConstAlt c sc)
        = MkConstAlt c $
              CConstCase fc sc alts def

tryCaseOfCase : CExp vars -> Maybe (CExp vars)
tryCaseOfCase (CConCase fc (CConCase fc' x xalts Nothing) alts def)
    = if canCaseOfCase xalts
         then Just (doCaseOfCase fc' x xalts alts def)
         else Nothing
  where
    conCase : CConAlt vars -> Bool
    conCase (MkConAlt _ _ _ _ (CCon _ _ _ _ _)) = True
    conCase _ = False

    canCaseOfCase : List (CConAlt vars) -> Bool
    canCaseOfCase [] = True
    canCaseOfCase [x] = True
    canCaseOfCase xs = all conCase xs
tryCaseOfCase (CConstCase fc (CConstCase fc' x xalts Nothing) alts def)
    = if canCaseOfCase xalts
         then Just (doCaseOfConstCase fc' x xalts alts def)
         else Nothing
  where
    constCase : CConstAlt vars -> Bool
    constCase (MkConstAlt _ (CPrimVal _ _)) = True
    constCase _ = False

    canCaseOfCase : List (CConstAlt vars) -> Bool
    canCaseOfCase [] = True
    canCaseOfCase [x] = True
    canCaseOfCase xs = all constCase xs
tryCaseOfCase _ = Nothing

export
caseOfCase : CExp vars -> CExp vars
caseOfCase tm = go 5 tm
  where
    go : Nat -> CExp vars -> CExp vars
    go Z tm = tm
    go (S k) tm = maybe tm (go k) (tryCaseOfCase tm)


module Idris.Doc.Keywords

import Decidable.Equality
import Parser.Lexer.Source
import Data.List.Quantifiers
import Data.String

import Idris.Doc.Annotations
import Idris.Pretty

import Libraries.Data.List.Quantifiers.Extra

infix 10 ::=
data DocFor : String -> Type where
  (::=) : (0 str : String) -> (doc : Doc IdrisDocAnn) -> DocFor str

doc : DocFor _ -> Doc IdrisDocAnn
doc (_ ::= d) = d

fixity : Doc IdrisDocAnn
fixity = vcat $
    header "Fixity declarations" :: ""
    :: map (indent 2) [
    """
    Operators can be assigned a priority level and associativity. During parsing
    operators with a higher priority will collect their arguments first and the
    declared associativity will inform how subterms are grouped.

    For instance the expression `a + b * c * d + e` is parsed as
    `(a + ((b * c) * d)) + e` because:
      `(+)` is at level 8 and associates to the left
      `(*)` is at level 9 and associates to the left
    """]

recordtypes : Doc IdrisDocAnn
recordtypes = vcat $
    header "Record types" :: ""
    :: map (indent 2) [
    """
    Records are data types with a single constructor. Each of the constructor's
    argument is given a name and the corresponding projections and record update
    functions are automatically generated.
    For instance, we can define a type of pairs of natural numbers
    """, "",
    """
    ```idris
    record Nat2 where
      constructor MkNat2
      fst : Nat
      snd : Nat
    ```
    """, "",
    """
    and we can then immediately use all of `fst`, `snd`, `{ fst := ?h1 }`,
    or `{ snd $= ?h2 }` to respectively project values out of a record,
    replace values, or update them.
    """
    ]

datatypes : Doc IdrisDocAnn
datatypes = vcat $
    header "(Co)Data types" :: ""
    :: map (indent 2) [
    """
    Keyword to introduce a (co)inductive type definition.
    You can either use a BNF-style definition for simple types
    """, "",
    """
    ```idris
    data List a = Nil | (::) a (List a)
    ```
    """, "",
    """
    or a GADT-style definition for indexed types
    """, "",
    """
    ```idris
    data Vect : Nat -> Type -> Type where
      Nil  : Vect 0 a
      (::) : a -> Vect n a -> Vect (S n) a
    ```
    """, "",
    """
    Coinductive data is introduced using the same syntax except
    that the type of potentially infinite subterms is wrapped in
    an `Inf` type constructor.
    """]

totality : Doc IdrisDocAnn
totality = vcat $
    header "Totality" :: ""
    :: map (indent 2) [
    """
    Definitions can be individually declared `total`, `covering`, or partial`.
    It is also possible to set the default totality flag for definitions in a
    module by using the `%default` pragma.
    """, "",
    """
    * `total` offers the highest guarantees. Definitions using this flag are
      only accepted if:
        1. their patterns are covering all possible cases;
        2. they are either obviously terminating (for recursive functions)
           or productive (for corecursive functions);
        3. all the auxiliary functions used are total themselves.
    """, "",
    """
    * `covering` is the default level of guarantees. It only enforces that
      pattern matchings are exhaustive.
    """, "",
    """
    * `partial` is the absence of any totality requirement: as long as the
      definition typechecks, it is accepted. It is possible to call a partial
      function from a total one by using the `assert_total` escape hatch.
    """]

visibility : Doc IdrisDocAnn
visibility = vcat $
    header "Visibility" :: ""
    :: map (indent 2) [
    """
    Programmers can decide which parts of a module they expose to the outside
    world.
    """, "",
    """
    * `public export` ensures that both the declaration and the definition
       are accessible from the outside of the module. This means the function
       will be able to reduce in types.
    """, "",
    """
    * `export` means that only the declaration will be made available to the
      outside world. Users will be able to call the function but its internals
      will not be exposed because it will not reduce in types.
    """, "",
    """
    * `private` means that neither the declaration nor the definition will be
      exported. This is the default and is the ideal setting for auxiliary
      definitions.
    """]

ifthenelse : Doc IdrisDocAnn
ifthenelse = vcat $
    header "Boolean conditional" :: ""
    :: map (indent 2) [
    """
    The `if ... then ... else ...` construct is dependently typed. This means
    that if you are branching over a variable, the branches will have refined
    types where that variable has been replaced by either `True` or `False`.
    For instance, in the following incomplete program
    """, "",
    """
    ```idris
    notInvolutive : (b : Bool) -> not (not b) === b
    notInvolutive b = if b then ?holeTrue else ?holeFalse
    ```
    """, "",
    """
    the two holes have respective types `True === True` and `False === False`.
    """, "", "",
    """
    If you do not need the added power granted by dependently typed branches,
    consider using the simpler `ifThenElse` function defined in `Prelude`.
    """]

impossibility : Doc IdrisDocAnn
impossibility = vcat $
    header  "Impossible branches" :: ""
    :: map (indent 2) [
    """
    The `impossible` keyword can be used to dismiss a clause involving an
    argument with an uninhabited type. For instance an assumption stating
    that 0 is equal to 1:
    """, "",
    """
    ```idris
    zeroIsNotOne : 0 === 1 -> Void
    zeroIsNotOne eq impossible
    ```
    """]

caseof : Doc IdrisDocAnn
caseof = vcat $
    header "Case block" :: ""
    :: map (indent 2) [
    """
    The `case ... of ...` construct is dependently typed. This means that if you
    are branching over a variable, the branches will have refined types where
    that variable has been replaced by the appropriate pattern.
    For instance, in the following program
    """, "",
    """
    ```idris
    assoc : (ma, mb, mc : Maybe a) ->
            ((ma <|> mb) <|> mc) === (ma <|> (mb <|> mc))
    assoc ma mb mc = case ma of
      Nothing => Refl
      Just a  => Refl
    ```
    """, "",
    """
    the branches typecheck because in their respective types `ma` has been replaced
    either by `Nothing` or `Just a` and that was enough for them to compute to
    `(mb <|> mc) === (mb <|> mc)` and `Just a === Just a` respectively. Both of
    which can be discharged using `Refl`.
    """]

importing : Doc IdrisDocAnn
importing = vcat $
    header "Importing" :: ""
    :: map (indent 2) [
    """
    Importing a module brings the definition it exports into scope.
    Combined with `public` it also re-exports these definitions.
    """]

forallquantifier : Doc IdrisDocAnn
forallquantifier = vcat $
    header "Forall quantifier" :: ""
    :: map (indent 2) [
    """
    `forall` quantification is syntactic sugar for implicit runtime-irrelevant
    universal quantification. That is to say that `forall x, y, z. ...`
    desugars to `{0 x, y, z : _} -> ...`.
    """]

implicitarg : Doc IdrisDocAnn
implicitarg = vcat $
    header  "Implicit arguments" :: ""
    :: map (indent 2) [
    """
    Implicit arguments can be solved using various strategies. By default
    they will be filled in using unification but programmers can use various
    keywords to change that.
    """, "",
    """
    * `auto` will use the same mechanism as interface resolution to build the
      argument. Users can add new hints to the database by adding a `%hint`
      pragma to their declarations. By default all data constructors are hints.
      For instance, the following function
      ```idris
      f : (n : Nat) -> {auto _ : n === Z} -> Nat
      f n = n
      ```
      will only accept arguments that can be automatically proven to be equal
      to zero.
    """, "",
    """
    * `default` takes a value of the appropriate type and if no argument is
      explicitly passed at a call site, will use that default value.
      For instance, the following function
      ```idris
      f : {default 0 n : Nat} -> Nat
      f = n
      ```
      will return `0` if no argument is passed and its argument otherwise.
    """]

unusedKeyword : Doc IdrisDocAnn
unusedKeyword = "Currently unused keyword"

interfacemechanism : Doc IdrisDocAnn
interfacemechanism = vcat $
    header "Interfaces" :: ""
    :: map (indent 2) [
    """
    Interfaces offer ad-hoc polymorphism. Programmers can declare new
    interfaces offering a set of methods (some of which may have default
    implementations in terms of the interface's other methods) and write
    programs generic over all types implementing the interface.
    """, "",
    """
    In the following example we define a `Failing` interface that allows
    users to abort in case a computation is doomed to fail. We implement
    the `whenJust` construct using this interface and show a couple of
    implementations:
    """, "",
    """
    ```idris
    interface Failing (0 a : Type) where
      fail : a

    whenJust : Failing ret => Maybe a -> (a -> ret) -> ret
    whenJust (Just v) k = k v
    whenJust Nothing  _ = fail

    implementation Failing Bool where
      fail = False

    Failing (Maybe a) where
      fail = Nothing
    ```
    """, "",
    """
    As you can see the `implementation` keyword is optional. Note that the
    proof search machinery powering interface resolution works best if your
    implementations are for specific type constructors (here `Bool` and `Maybe`).
    """]

doblock : Doc IdrisDocAnn
doblock = vcat $
    header "Do block" :: ""
    :: map (indent 2) [
    #"""
    Do blocks are a popular way to structure (among other things) effectful code.
    They are desugared using `(>>=)` and `(>>)` respectively depending on whether
    the result of a subcomputation is bound. Let bindings and local definitions
    can be used (omitting `in` because the layout is already controlled by the
    `do`-based indentation) and desugared to the corresponding `let` constructs.

    For instance the following block
    ```idris
      do x <- e1
         e2
         let y = e3
         e4
    ```
    is equivalent to the expression `e1 >>= \ x => e2 >> let y = e3 in e4`.
    """#, "",
    """
    By default `(>>=)` and `(>>)` are then selected using the usual type
    directed disambiguation mechanisms. Users who want to bypass this implicit
    disambiguation step can use a qualified `do`: by writing `M.do` they ensure
    Idris will explicitly use `M.(>>=)` and `M.(>>)` during elaboration.
    """ ]

whereblock : Doc IdrisDocAnn
whereblock = vcat $
    header "Where block" :: ""
    :: map (indent 2) [
    header "NB:" <++> """
    `where` is used as a layout keyword in `data`, `record`, `interface`,
    and `implementation` blocks. This documentation snippet focuses instead
    on the `where` blocks introducing local definitions.
    """, "",
    """
    A `where` block allows the introduction of local auxiliary definitions
    that are parametrised over the variables bound on the left hand side of
    the parent clause (cf. the doc for `parameters`).
    """
    ]

parametersblock : Doc IdrisDocAnn
parametersblock = vcat $
    header "Parameters block" :: ""
    :: map (indent 2) [
    """
    Definitions that share a common parameter can be grouped in a parameters
    block to avoid having to explicitly pass it around. Outside of the block
    all the definitions will take additional arguments corresponding to the
    parameters. For instance the functions in the following block all use a
    default value `dflt`
    """, "",
    """
    ```idris
    parameters (dflt : a)

      head : List a -> a
      head (x :: xs) = x
      head _ = dflt

      last : List a -> a
      last [x] = x
      last (_ :: xs) = last xs
      last _ = dflt
    ```
    """, "",
    """
    and their respective types outside of the parameters block are
    `head : a -> List a -> a` and `last : a -> List a -> a`.
    """]

mutualblock : Doc IdrisDocAnn
mutualblock = vcat $
    header "Mutual block" :: ""
    :: map (indent 2) [
    """
    Mutual blocks allow users to have inter-dependent declarations. For instance
    we can define the `odd` and `even` checks in terms of each other like so:
    ```idris
    mutual

      odd : Nat -> Bool
      odd Z = False
      odd (S n) = even n

      even : Nat -> Bool
      even Z = True
      even (S n) = odd n
    ```
    """, "",
    """
    Internally this is implemented in terms of the more fundamental
    forward-declaration feature: all the mutual declarations come first and then
    their definitions. In other words, the earlier example using a `mutual` block
    is equivalent to the following
    ```idris
    odd : Nat -> Bool
    even : Nat -> Bool

    odd Z = False
    odd (S n) = even n

    even Z = True
    even (S n) = odd n
    ```
    """]

namespaceblock : Doc IdrisDocAnn
namespaceblock = vcat $
    header "Namespace block" :: ""
    :: map (indent 2) [
    """
    Attempting to declare two functions with the same name in a given module
    will lead to a scope error. Putting each one in a different `namespace`
    block can help bypass this issue by ensuring that they are assigned distinct
    fully qualified names. For instance
    ```idris
    module M

    namespace Zero
      val : Nat
      val = 0

    namespace One
      val : Nat
      val = 1
    ```
    declares a module `M` containing two values `M.Zero.val` and `M.One.val`.
    You can use `export` or `public export` to control whether a function
    declared in a namespace is available outside of it.
    """]

rewriteeq : Doc IdrisDocAnn
rewriteeq = vcat $
    header "Rewrite" :: ""
    :: map (indent 2) [
    """
    Users can deploy an equality proof to adjust a type by replacing the value
    on the left hand side of the equality by that on the right hand side.
    For instance, if we know that the types `a` and `b` are propositionally
    equal, we can return a value of type `a` as if it had type `b`:
    ```idris
    transport : a === b -> a -> b
    transport eq x = rewrite sym eq in x
    ```
    """]

withabstraction : Doc IdrisDocAnn
withabstraction = vcat $
    header "With abstraction" :: ""
    :: map (indent 2) [
    """
    We often need to match on the result of an intermediate computation.
    When this intermediate computation additionally appears in the type of the
    function being defined, the `with` construct allows us to capture these
    occurences so that the observations made in the patterns will be reflected
    in the type.
    If we additionally need to remember that the link between the patterns and
    the intermediate computation we can use the `proof` keyword to retain an
    equality proof.
    """, "",
    """
    In the following example we want to implement a `filter` function that not
    only returns values that satisfy the input predicate but also proofs that
    they do. The `with (p x)` construct introduces a value of type `Bool`
    obtained by testing `x` with `p`. The additional `proof eq` part records in
    `eq` an equality proof stating that the `True`/`False` patterns in the further
    clauses are equal to the result of evaluating `p x`. This is the reason why
    we can successfully form `(x ** eq)` in the `True` branch.
    ```idris
    filter : (p : a -> Bool) -> List a -> List (x : a ** p x === True)
    filter p [] = []
    filter p (x :: xs) with (p x) proof eq
      _ | True = (x ** eq) :: filter p xs
      _ | False = filter p xs
    ```
    """]

letbinding : Doc IdrisDocAnn
letbinding = vcat $
    header "Let binding" :: ""
    :: map (indent 2) [
    """
    The `let` keyword is used for both local definitions and let bindings.
    Local definitions are just like top-level definitions except that they are
    defined in whatever extended context is available at the definition site.

    Let bindings can be used to bind the result of intermediate computations.
    They do not necessitate but can have a type annotation. They will not unfold
    in the type of subsequent terms so may not be appropriate in all cases.

    For instance, in the following definition the let-bound value `square`
    ensures that `n * n` is only computed once:
    ```idris
    power4 : Nat -> Nat
    power4 n = let square := n * n in square * square
    ```

    It is also possible to pattern-match on the result of the intermediate
    computation. The main pattern is written in place of the variable and
    an alternative list of clauses can be given using the `|` separator.
    For instance, we can shortcut the `square * square` computation in case
    the returned value is 0 like so:
    ```idris
    power4 : Nat -> Nat
    power4 n = let square@(S _) := n * n
                     | Z => Z
               in square * square
    ```
    """]

keywordsDoc : All DocFor Source.keywords
keywordsDoc =
     "data" ::= datatypes
  :: "module" ::= "Keyword to start a module definition"
  :: "where" ::= whereblock
  :: "let" ::= letbinding
  :: "in" ::= "Used by `let` and `rewrite`. See either of them for more details."
  :: "do" ::= doblock
  :: "record" ::= recordtypes
  :: "auto" ::= implicitarg
  :: "default" ::= implicitarg
  :: "implicit" ::= unusedKeyword
  :: "mutual" ::= mutualblock
  :: "namespace" ::= namespaceblock
  :: "parameters" ::= parametersblock
  :: "with" ::= withabstraction
  :: "proof" ::= withabstraction
  :: "impossible" ::= impossibility
  :: "case" ::= caseof
  :: "of" ::= caseof
  :: "if" ::= ifthenelse
  :: "then" ::= ifthenelse
  :: "else" ::= ifthenelse
  :: "forall" ::= forallquantifier
  :: "rewrite" ::= rewriteeq
  :: "using" ::= ""
  :: "interface" ::= interfacemechanism
  :: "implementation" ::= interfacemechanism
  :: "open" ::= unusedKeyword
  :: "import" ::= importing
  :: "public" ::= visibility
  :: "export" ::= visibility
  :: "private" ::= visibility
  :: "infixl" ::= fixity
  :: "infixr" ::= fixity
  :: "infix" ::= fixity
  :: "prefix" ::= fixity
  :: "total" ::= totality
  :: "partial" ::= totality
  :: "covering" ::= totality
  :: []

export
getDocsForKeyword : String -> Doc IdrisDocAnn
getDocsForKeyword k
  = maybe (annotate (Syntax Keyword) $ pretty k) doc
  $ lookup k keywordsDoc

unusedSymbol : Doc IdrisDocAnn
unusedSymbol = "Currently unused symbol"

lambdaAbstraction : Doc IdrisDocAnn
lambdaAbstraction = """
  An anonymous function is introduced using a lambda `\\` and binds a
  comma-separated list of either variable names or irrefutable patterns
  before returning a right hand side using `=>`.

  For instance we can implement `transport` like so:
  ```
  transport : a === b -> a -> b
  transport = \ Refl, v => v
  ```
  """

fatArrow : Doc IdrisDocAnn
fatArrow = vcat
  [ """
    Used for an interface constraint in a type signature or as part of a
    lambda abstraction or case block.

    1. Interface constraint
    """
  , indent 2 """
    `a => b` corresponds to `{auto _ : a} -> b`
    """, ""
  , """
    2. Lambda abstraction
    """
  , indent 2 lambdaAbstraction
  , "", """
    3. Case block
    """
  ]

bang : Doc IdrisDocAnn
bang = """
  Directive to lift the following effectful expression to the nearest enclosing
  (potentially implicit) `do` block. In the following definition for instance

  ```
  anyM : Monad m => (a -> m Bool) -> List a -> m (Maybe a)
  anyM p [] = pure Nothing
  anyM p (x :: xs) = if !(p x) then pure (Just x) else anyM p xs
  ```

  the expression `if !(p x) then pure (Just x) else anyM p xs` is equivalent to
  the following `do` block:

  ```
  do b <- p x
     if b then pure (Just x) else anyM p xs
  ```
  """

asPattern : Doc IdrisDocAnn
asPattern = """
  An as pattern `@` can be used to both pattern match on a variable
  and retain a name for the compound expression. E.g. instead of writing
  ```
  last : List a -> Maybe a
  last [] = Nothing
  last [x] = Just x
  last (x :: y :: ys) = last (y :: ys)
  ```

  where, in the last clasue, we take `y :: ys` apart on the left hand side
  before reconstructing it on the right hand side, we can write:

  ```
  last (x :: xs@(_ :: _)) = last xs
  ```
  """

tupleSyntax : Doc IdrisDocAnn
tupleSyntax = "Used to build dependent pairs together with parentheses"

rangeSyntax : Doc IdrisDocAnn
rangeSyntax = """
  The ellipsis `..` can be used to generate lists or streams of values for
  types that implement the `Range` interface.

  Lists can be generated using an initial value, an (optional) second value
  and a final one. For instance, we can generate lists of integers like so:
    1. `[1..5]`   evaluates to `[1,2,3,4,5]`
    2. `[1,3..5]` evaluates to `[1, 3, 5]`

  Streams can be generated using an initial value and an optional second value.
  For instance the following streams of integers:
    1. `[1..]`   for all positive integers
    2. `[1,3..]` for all positive odds
  """

recordUpdate : Doc IdrisDocAnn
recordUpdate = vcat $ header "Record updates" :: ""
  :: map (indent 2) [
  """
  If a record `r` has a field `n` of type `Nat`, it is possible to either

  1. overwrite the current value with `0` by using the assignment symbol `:=`
     like so: `{ n := 0 } r`

  2. modify the current value by adding `2` by using the modification symbol `$=`
     like so: `{ n $= (2 +) } r`.

  Multiple updates can be combined in a single update by grouping a comma-separated
  list of assignments and/or modifications like so: `{ a := Z, b $= S } r`.
  """
  ]

symbolsDoc : All DocFor (Source.symbols ++ Source.reservedInfixSymbols)
symbolsDoc
  = "," ::= ""
  :: ";" ::= ""
  :: "_" ::= """
             An implicit value either solved by unification or bound
             as a pattern or type variable.
             """
  :: "`" ::= ""
  :: "%" ::= "Start of a pragma"
  :: "\\" ::= lambdaAbstraction
  :: ":" ::= """
             Type declaration, for instance `id : a -> a`
             declares a new toplevel definition `id` of type `a -> a`.
             """
  :: "=" ::= "Definition or equality type"
  :: ":=" ::= "Let binding or record assignment"
  :: "$=" ::= recordUpdate
  :: "|" ::= "Additional patterns showing up in a `with` clause"
  :: "|||" ::= "Document string attached to the following definition"
  :: "<-" ::= "Bind in a do block"
  :: "->" ::= "Function type"
  :: "=>" ::= fatArrow
  :: "?" ::= "An implicit value solved by unification."
  :: "!" ::= bang
  :: "&" ::= unusedSymbol
  :: "**" ::= tupleSyntax
  :: ".." ::= rangeSyntax
  :: "~" ::= ""
  :: "@" ::= asPattern
  :: []

export
getDocsForSymbol : String -> Doc IdrisDocAnn
getDocsForSymbol k
  = maybe (annotate (Syntax Keyword) $ pretty k) doc
  $ lookup k symbolsDoc


||| Spec: https://webassembly.github.io/spec/core/valid/conventions.html#contexts
module WebAssembly.Validation.Conventions.Contexts

import WebAssembly.Structure.Types

import Decidable.Equality

-- Definition

public export
record Context where
  constructor MkContext
  types   : List FuncType
  funcs   : List FuncType
  tables  : List TableType
  mems    : List MemType
  globals : List GlobalType
  locals  : List ValType
  labels  : List ResultType
  return  : Maybe ResultType

total public export
prependTypes : List FuncType -> Context -> Context
prependTypes xs = record {types $= ((++) xs)}

total public export
prependFuncs : List FuncType -> Context -> Context
prependFuncs xs = record {funcs $= ((++) xs)}

total public export
prependTables : List TableType -> Context -> Context
prependTables xs = record {tables $= ((++) xs)}

total public export
prependMems : List MemType -> Context -> Context
prependMems xs = record {mems $= ((++) xs)}

total public export
prependGlobals : List GlobalType -> Context -> Context
prependGlobals xs = record {globals $= ((++) xs)}

total public export
prependLocals : List ValType -> Context -> Context
prependLocals xs = record {locals $= ((++) xs)}

total public export
prependLabels : List ResultType -> Context -> Context
prependLabels xs = record {labels $= ((++) xs)}

-- Equality

total public export
lemma_c__types_injective: ((ty1 = ty2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__types_injective ty1_not_ty2 Refl = ty1_not_ty2 Refl

total public export
lemma_c__funcs_injective: ((fu1 = fu2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__funcs_injective fu1_not_fu2 Refl = fu1_not_fu2 Refl

total public export
lemma_c__tables_injective: ((ta1 = ta2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__tables_injective ta1_not_ta2 Refl = ta1_not_ta2 Refl

total public export
lemma_c__mems_injective: ((me1 = me2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__mems_injective me1_not_me2 Refl = me1_not_me2 Refl

total public export
lemma_c__globals_injective: ((gl1 = gl2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__globals_injective gl1_not_gl2 Refl = gl1_not_gl2 Refl

total public export
lemma_c__locals_injective: ((lo1 = lo2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__locals_injective lo1_not_lo2 Refl = lo1_not_lo2 Refl

total public export
lemma_c__labels_injective: ((la1 = la2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__labels_injective la1_not_la2 Refl = la1_not_la2 Refl

total public export
lemma_c__return_injective: ((re1 = re2) -> Void)
  -> (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1 = MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
  -> Void
lemma_c__return_injective re1_not_re2 Refl = re1_not_re2 Refl

-- Decidable Equality

public export
implementation DecEq Context where
  decEq (MkContext ty1 fu1 ta1 me1 gl1 lo1 la1 re1) (MkContext ty2 fu2 ta2 me2 gl2 lo2 la2 re2)
    = case decEq ty1 ty2 of
        No ty1_not_ty2 => No $ lemma_c__types_injective ty1_not_ty2
        Yes Refl       => case decEq fu1 fu2 of
          No fu1_not_fu2 => No $ lemma_c__funcs_injective fu1_not_fu2
          Yes Refl       => case decEq ta1 ta2 of
            No ta1_not_ta2 => No $ lemma_c__tables_injective ta1_not_ta2
            Yes Refl       => case decEq me1 me2 of
              No me1_not_me2 => No $ lemma_c__mems_injective me1_not_me2
              Yes Refl       => case decEq gl1 gl2 of
                No gl1_not_gl2 => No $ lemma_c__globals_injective gl1_not_gl2
                Yes Refl       => case decEq lo1 lo2 of
                  No lo1_not_lo2 => No $ lemma_c__locals_injective lo1_not_lo2
                  Yes Refl       => case decEq la1 la2 of
                    No la1_not_la2 => No $ lemma_c__labels_injective la1_not_la2
                    Yes Refl       => case decEq re1 re2 of
                      No re1_not_re2 => No $ lemma_c__return_injective re1_not_re2
                      Yes Refl       => Yes Refl


import Control.Linear.LIO

import Network.Socket

data SocketState = Ready | Bound | Listening | Open | Closed

data Socket : SocketState -> Type where
     MkSocket : Socket.Data.Socket -> Socket st

newSocket : LinearIO io
      => (fam  : SocketFamily)
      -> (ty   : SocketType)
      -> (pnum : ProtocolNumber)
      -> (success : (1 _ : Socket Ready) -> L io ())
      -> (fail : SocketError -> L io ())
      -> L io ()
newSocket fam ty pnum success fail
    = do Right rawsock <- socket fam ty pnum
               | Left err => fail err
         success (MkSocket rawsock)

bind : LinearIO io =>
       (1 _ : Socket Ready) ->
       (addr : Maybe SocketAddress) ->
       (port : Port) ->
       L io {use=1} (Res Bool (\res => Socket (case res of
                                                    False => Closed
                                                    True => Bound)))
bind (MkSocket sock) addr port
    = do ok <- Socket.bind sock addr port
         if ok == 0
            then pure1 (True # ?foo1)
            else pure1 (False # ?foo2)


---
pandoc-minted:
  language: idris
---

= No Time for a Taxicab

[Link](https://adventofcode.com/2016/day/1)

Santa's sleigh uses a very high-precision clock to guide its movements, and the
clock's oscillator is regulated by stars. Unfortunately, the stars have been
stolen... by the Easter Bunny. To save Christmas, Santa needs you to retrieve
all **fifty stars** by December 25th.

Collect stars by solving puzzles. Two puzzles will be made available on each day
in the advent calendar; the second puzzle is unlocked when you complete the
first. Each puzzle grants **one star**. Good luck!

You're airdropped near *Easter Bunny Headquarters* in a city somewhere. "Near",
unfortunately, is as close as you can get - the instructions on the Easter Bunny
Recruiting Document the Elves intercepted start here, and nobody had time to
work them out further.

The Document indicates that you should start at the given coordinates (where you
just landed) and face North. Then, follow the provided sequence: either turn
left (`L`) or right (`R`) 90 degrees, then walk forward the given number of
blocks, ending at a new intersection.

There's no time to follow such ridiculous instructions on foot, though, so you
take a moment and work out the destination. Given that you can only walk on the
[street grid of the city](https://en.wikipedia.org/wiki/Taxicab_geometry), how
far is the shortest path to the destination?

For example:

- Following `R2, L3` leaves you `2` blocks East and `3` blocks North, or `5`
  blocks away.
- `R2, R2, R2` leaves you `2` blocks due South of your starting position, which
  is `2` blocks away.
- `R5, L5, R5, R3` leaves you `12` blocks away.

\newpage

== Module Declaration and Imports

> ||| Day 1: No Time for a Taxicab
> module Data.Advent.Day01

Import the [generic `Day`
structure](https://github.com/yurrriq/advent-of-idris/blob/master/src/Data/Advent/Day.idr),
inspired by [Steve Purcell Haskell
solution](https://github.com/purcell/adventofcode2016).

> import public Data.Advent.Day

For no compelling reason, I like to use
[arrows](https://www.haskell.org/arrows/), so import the requisite modules.

> import Control.Arrow
> import Control.Category
> import Data.Morphisms
> import Data.SortedSet

For parsing, use [Lightyear](https://github.com/ziman/lightyear).

> import public Lightyear
> import public Lightyear.Char
> import public Lightyear.Strings

== Data Types

Ensure both the type and data constructors are
[exported](http://docs.idris-lang.org/en/latest/tutorial/modules.html#meaning-for-data-types)
for all the following data types.

> %access public export

We'll need to keep track of which cardinal direction we're facing, so define a
data type `Heading` to model that. A heading is `N`orth, `E`ast, `S`outh or `W`est.

> ||| A cardinal heading.
> data Heading = ||| North
>                N
>              | ||| East
>                E
>              | ||| South
>                S
>              | ||| West
>                W

As per the [puzzle description](no-time-for-a-taxicab), the instructions will
tell us to go `L`eft or `R`ight, so model `Direction`s accordingly.

> ||| A direction to walk in, left or right.
> data Direction = ||| Left
>                  L
>                | ||| Right
>                  R

\newpage

For convenience in the REPL, implement the `Show`
[interface](http://docs.idris-lang.org/en/latest/tutorial/interfaces.html) for
`Direction`.

> implementation Show Direction where
>     show L = "Left"
>     show R = "Right"

An `Instruction`, e.g. `R2`, is comprised of a `Direction` and a number of
blocks to walk in that direction.

As such, define an `Instruction` as a record containing a `Direction` and a
number of `Blocks`.

> Blocks : Type
> Blocks = Integer
>
> ||| A direction and a number of blocks.
> record Instruction where
>     constructor MkIns
>     iDir    : Direction
>     iBlocks : Blocks

A `Position` is a record containing x and y coordinates in the [street
grid](https://en.wikipedia.org/wiki/Taxicab_geometry).

> ||| A pair of coordinates on the street grid.
> record Position where
>     constructor MkPos
>     posX, posY : Blocks
>
> implementation Eq Position where
>     (MkPos x1 y1) == (MkPos x2 y2) = x1 == x2 && y1 == y2
>
> implementation Ord Position where
>     compare (MkPos x1 y1) (MkPos x2 y2) with (compare x1 x2)
>       | EQ = compare y1 y2
>       | o  = o

== Parsers

Ensure the type constructors of the following parsers are
[exported](http://docs.idris-lang.org/en/latest/tutorial/modules.html#meaning-for-data-types).

> %access export

A `Direction` is represented in the input by a single character, `'L'` or `'R'`.

> direction : Parser Direction
> direction = (char 'L' *> pure L) <|>|
>             (char 'R' *> pure R) <?>
>             "a direction"

\newpage

An `Instruction` is represented as a `Direction` followed immediately by an
integer.

> ||| Parse an instruction, i.e. a direction and
> ||| a number of blocks to walk in that direction.
> partial instruction : Parser Instruction
> instruction = [| MkIns direction integer |] <?> "an instruction"

The instructions are given as a comma-separated list.

> ||| Parse a comma-separated list of `Instruction`s.
> partial instructions : Parser (List Instruction)
> instructions = commaSep instruction <* spaces <?>
>                "a comma-separated list of instructions"

== Logic

> ||| Return the new heading after turning right.
> ||| @ initial the initial heading
> turnRight : (initial : Heading) -> Heading
> turnRight N = E
> turnRight E = S
> turnRight S = W
> turnRight W = N
>
> ||| Return the new heading after turning left.
> ||| @ initial the initial heading
> turnLeft : (initial : Heading) -> Heading
> turnLeft N = W
> turnLeft E = N
> turnLeft S = E
> turnLeft W = S
>
> ||| Return the new heading after turning in a given direction.
> turn : Heading -> Direction -> Heading
> turn h L = turnLeft  h
> turn h R = turnRight h
>
> ||| Return the new position after moving one block with a given heading.
> move : Heading -> (Position -> Position)
> move N = record { posY $= (+ 1) }
> move E = record { posX $= (+ 1) }
> move S = record { posY $= (flip (-) 1) }
> move W = record { posX $= (flip (-) 1) }

> ||| Compute the shortest distance from the initial position and a given one.
> shortestDistance : Position -> Blocks
> shortestDistance (MkPos x y) = abs x + abs y

\newpage

> ||| Return the list of intermediate positions visited
> ||| when following a given list of instructions.
> followInstructions : List Instruction -> List Position
> followInstructions is =
>     let directions = drop 1 $ scanl turn N (iDir <$> is)
>         distances  = iBlocks <$> is
>         moves      = concatMap expand (zip directions distances) in
>         scanl (flip move) (MkPos 0 0) moves
>   where
>     expand : (Heading, Blocks) -> List Heading
>     expand (h, n) = replicate (cast n) h

== Part One

\begin{quote}
  \textit{How many blocks away} is Easter Bunny HQ?
\end{quote}

To compute the answer to Part One, `262`, follow the instructions, get the last
position and compute the shortest distance from the initial position.

> partOne : List Instruction -> Maybe Blocks
> partOne = map shortestDistance . last' . followInstructions

== Part Two

Then, you notice the instructions continue on the back of the Recruiting
Document. Easter Bunny HQ is actually at the first location you visit twice.

For example, if your instructions are `R8, R4, R4, R8`, the first location you
visit twice is `4` blocks away, due East.

\begin{quote}
  How many blocks away is the \textit{first location you visit twice}?
\end{quote}

First, define a function `firstDuplicate` to find the first location visited
twice in a list of positions. Instead of specializing for `List Position`,
generalize the solution to `Ord a => List a`.

> ||| Return `Just` the first duplicate in a given list.
> ||| If there are none, return `Nothing`.
> firstDuplicate : Ord a => List a -> Maybe a
> firstDuplicate = go empty
>   where
>     go : SortedSet a -> List a -> Maybe a
>     go _ []         = Nothing
>     go seen (x::xs) =
>         if contains x seen
>            then Just x
>            else go (insert x seen) xs

> partTwo : List Instruction -> Maybe Blocks
> partTwo = map shortestDistance . firstDuplicate . followInstructions

\newpage

== Main

Run the solutions for Day 1.

> namespace Main
>
>     partial main : IO ()
>     main = runDay $ MkDay 1 instructions
>            (pure . maybe "Failed!" show . partOne)
>            (pure . maybe "Failed!" show . partTwo)

$\qed$

\newpage


module CFT.DependentLens

public export
record DepLens (s, a : Type) (t : s -> Type) (b : a -> Type) where
  constructor MkDepLens
  get : s -> a
  set : (es : s) -> b (get es) -> t es


module FCTypes

%default total

StringOrInt : Bool -> Type
StringOrInt b = case b of
                     False => String
                     True => Int

getStringOrInt : (b : Bool) -> StringOrInt b
getStringOrInt b = case b of
                        False => "94"
                        True => 94

valToString : (b : Bool) -> StringOrInt b -> String
valToString b val = case b of
                         False => val
                         True => cast val


module StreamFusion

data TypeT : Type where
  UnitT : TypeT
  IntT : TypeT
  BoolT : TypeT
  ArrayT : TypeT -> TypeT
  VarT : Type -> TypeT -> TypeT
  ArrowT : TypeT -> TypeT -> TypeT

Show TypeT where
  show UnitT = "unit"
  show IntT = "int"
  show BoolT = "bool"
  show (ArrayT typ) = show typ ++ " []"
  show (VarT _ typ) = show typ ++ " ref"
  show (ArrowT arg res) = "(" ++ show arg ++ " -> " ++ show res ++ ")"

interface Symantics (rep : TypeT -> Type) where
  defaultof : rep a
  int : Int -> rep IntT
  bool : Bool -> rep BoolT
  (==) : rep IntT -> rep IntT -> rep BoolT
  (>) : rep IntT -> rep IntT -> rep BoolT
  (<) : rep IntT -> rep IntT -> rep BoolT
  (&&) : rep BoolT -> rep BoolT -> rep BoolT
  (||) : rep BoolT -> rep BoolT -> rep BoolT
  not : rep BoolT -> rep BoolT
  (+) : rep IntT -> rep IntT -> rep IntT
  (*) : rep IntT -> rep IntT -> rep IntT
  ite : rep BoolT -> rep a -> rep a -> rep a
  it : rep BoolT -> rep UnitT -> rep UnitT
  deref : rep (VarT s a) -> rep a
  assign : rep a -> rep (VarT s a) -> rep UnitT
  newVar : rep a -> ({s : Type} -> rep (VarT s a) -> rep b) -> rep b
  letVal : rep a -> (rep a -> rep b) -> rep b
  index : rep IntT -> rep (ArrayT a) -> rep a
  length : rep (ArrayT a) -> rep IntT
  while : rep BoolT -> rep UnitT -> rep UnitT
  seq : rep a -> rep b -> rep b
  seqs : List (rep UnitT) -> rep UnitT
  lam : (rep a -> rep b) -> rep (ArrowT a b)
  app : rep (ArrowT a b) -> rep a -> rep b

data Code : TypeT -> Type where
  C : (Int -> String) -> Code a

Symantics Code where
  defaultof {a = UnitT} = C (\_ => "()")
  defaultof {a = IntT} = C (\_ => "0")
  defaultof {a = BoolT} = C (\_ => "false")
  defaultof {a = (ArrayT x)} = C (\_ => "null")
  defaultof {a = (VarT x y)} = C (\_ => "null")
  defaultof {a = (ArrowT x y)} = C (\_ => "null")
  int x = C (\_ => show x)
  bool x = C (\_ => if x then "true" else "false")
  (==) (C l) (C r) = C (\v => "( " ++ l v ++ " = " ++ r v ++ " )")
  (>) (C l) (C r) = C (\v => "( " ++ l v ++ " > " ++ r v ++ " )")
  (<) (C l) (C r) = C (\v => "( " ++ l v ++ " < " ++ r v ++ " )")
  (&&) (C l) (C r) = C (\v => "( " ++ l v ++ " && " ++ r v ++ " )")
  (||) (C l) (C r) = C (\v => "( " ++ l v ++ " || " ++ r v ++ " )")
  not (C c) = C (\v => "not (" ++ c v ++ " )")
  (+) (C l) (C r) = C (\v => "( " ++ l v ++ " + " ++ r v ++ " )")
  (*) (C l) (C r) = C (\v => "( " ++ l v ++ " * " ++ r v ++ " )")
  ite (C b) (C l) (C r) = C (\v => "(if " ++ b v ++ " then " ++ l v ++ " else " ++ r v ++ ")")
  it (C b) (C t) = C (\v => "(if " ++ b v ++ " then " ++ t v ++ ")")
  deref (C x) = C (\v => "!" ++ x v)
  assign (C val) (C var) = C (\v => var v ++ " := " ++ val v)
  newVar {a} (C s) f = C (\v => let x = "x" ++ show v in
                                let (C c) = f $ the (Code (VarT () a)) (C (\_ => x)) in
                                "let " ++ x ++ " = ref " ++ s v ++ " in " ++ c (v + 1))
  letVal (C s) f = C (\v => let x = "x" ++ show v in
                            let (C c) = f $ C (\_ => x) in
                            "let " ++ x ++ " = " ++ s v ++ " in " ++ c (v + 1))
  index (C i) (C arr) = C (\v => arr v ++ ".[" ++ i v ++ "]")
  length (C arr) = C (\v => arr v ++ ".Length")
  while (C p) (C b) = C (\v => "(while " ++ p v ++ " do " ++ b v ++ ")")
  seq (C fs) (C sn) = C (\v => "(" ++ fs v ++ "; " ++ sn v ++ ")")
  seqs steps = foldr seq defaultof steps
  lam {a} f = C (\v => let x = "x" ++ show v in
                       let (C g) = f (C (\_ => x)) in
                       "(fun (" ++ x ++ " : " ++ show a ++ ") -> " ++ g (v + 1) ++ ")")
  app (C f) (C g) = C (\v => "(" ++ f v ++ " " ++ g v ++ ")")

data Stream : (rep : TypeT -> Type) -> (a : TypeT) -> Type where
  SC : ((s -> rep UnitT) -> rep UnitT) ->
       (s -> rep BoolT) ->
       (s -> (rep a -> rep UnitT) -> rep UnitT) ->
       (s -> rep UnitT) -> Stream rep a

ofArray : Symantics rep => rep (ArrayT a) -> Stream rep a
ofArray arr = SC (init arr) next current reset
  where
    init : rep (ArrayT a) -> ((rep (ArrayT a), DPair Type (\s => rep (VarT s IntT))) -> rep UnitT) -> rep UnitT
    init arr k = newVar (int 0) (\v => k (arr, (_ ** v)))
    next : (rep (ArrayT a), DPair Type (\s => rep (VarT s IntT))) -> rep BoolT
    next (arr, (_ ** v)) = deref v < length arr
    current : (rep (ArrayT a), DPair Type (\s => rep (VarT s IntT))) -> (rep a -> rep UnitT) -> rep UnitT
    current (arr, (_ ** v)) k = letVal (index (deref v) arr) (\x => seqs [k x, assign (deref v + (int 1)) v])
    reset : (rep (ArrayT a), DPair Type (\s => rep (VarT s IntT))) -> rep UnitT
    reset (arr, (_ ** v)) = assign (int 0) v

fold : Symantics rep => (rep a -> rep r -> rep r) -> rep r -> Stream rep a -> rep r
fold f seed stream = newVar seed (\acc => seq (fold' (\x => assign (f x (deref acc)) acc) stream) (deref acc))
  where
    fold' : (rep a -> rep UnitT) -> Stream rep a -> rep UnitT
    fold' k (SC init next current reset) = init (\s => while (next s) (current s k))

count : Symantics rep => Stream rep a -> rep IntT
count = fold (\x, acc => acc + (int 1)) (int 0)

sum : Symantics rep => Stream rep IntT -> rep IntT
sum = fold (\x, acc => x + acc) (int 0)

map : Symantics rep => (rep a -> rep b) -> Stream rep a -> Stream rep b
map f (SC init next current reset) = SC init next (\s, k => current s (\x => letVal x (\x' => k (f x')))) reset

filter : Symantics rep => (rep a -> rep BoolT) -> Stream rep a -> Stream rep a
filter pred (SC init next current reset) = SC init next (\s, k => current s (\x => letVal x (\x' => ite (pred x') (k x') defaultof))) reset

StreamC : (TypeT -> Type) -> Type -> TypeT -> Type
StreamC rep s a = (s, ((s -> rep UnitT) -> rep UnitT), (s -> rep BoolT),
                      (s -> (rep a -> rep UnitT) -> rep UnitT),
                      (s -> rep UnitT))

flatMap : Symantics rep => (rep a -> Stream rep b) -> Stream rep a -> Stream rep b
flatMap f (SC init' next' current' reset') = SC (init f init') next (current current' next') (reset reset')
  where
    init : (rep a -> Stream rep b) -> ((s -> rep UnitT) -> rep UnitT) -> ((s, DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => StreamC rep s' b)) -> rep UnitT) -> rep UnitT
    init f inita k = newVar (bool True) (\b => newVar (bool True) (\b' => newVar defaultof (\v => let (SC initb nextb currentb resetb) = f (deref v) in inita (\st => initb (\st' => k (st, (_ ** b), (_ ** b'), (_ ** v), (_ ** (st', initb, nextb, currentb, resetb))))))))
    next : (s, DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => StreamC rep s' b)) -> rep BoolT
    next (st, _, (_ ** b'), _, (_ ** (st', _, _, _, _))) = deref b'
    current : (s -> (rep a -> rep UnitT) -> rep UnitT) -> (s -> rep BoolT) -> (s, DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => StreamC rep s' b)) -> (rep b -> rep UnitT) -> rep UnitT
    current currenta nexta (st, (_ ** b), (_ ** b'), (_ ** v), (_ ** (st', initb, nextb, currentb, resetb))) k =
      ite (deref b)
          (ite (not (nexta st)) (assign (bool False) b') (seqs [currenta st (\a => seqs [assign a v, assign (bool False) b])]))
          (ite (nextb st') (currentb st' k)
                           (seqs [resetb st', assign (bool True) b]))
    reset : (s -> rep UnitT) -> (s, DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => StreamC rep s' b)) -> rep UnitT
    reset reseta (st, (_ ** b), (_ ** b'), _, (_ ** (st', _, _, _, resetb))) = seqs [assign (bool True) b, assign (bool True) b',reseta st, resetb st']

zipWith : Symantics rep => (rep a -> rep b -> rep c) -> Stream rep a -> Stream rep b -> Stream rep c
zipWith f (SC inita nexta currenta reseta) (SC initb nextb currentb resetb) =
  SC (init inita initb) (next nexta nextb) (current f currenta currentb) (reset reseta resetb)
  where
    init : ((s -> rep UnitT) -> rep UnitT) -> ((s' -> rep UnitT) -> rep UnitT) -> ((s, s', DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => rep (VarT s' b))) -> rep UnitT) -> rep UnitT
    init inita initb k = newVar (bool True) (\b => newVar (bool False) (\b' => newVar defaultof (\v => newVar defaultof (\v' => inita (\s => initb (\s' => k (s, s', (_ ** b), (_ ** b'), (_ ** v), (_ ** v'))))))))
    next : (s -> rep BoolT) -> (s' -> rep BoolT) -> (s, s', DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => rep (VarT s' b))) -> rep BoolT
    next nexta nextb (s, s', _, _, _, _) = nexta s && nextb s'
    current : (rep a -> rep b -> rep c) -> (s -> (rep a -> rep UnitT) -> rep UnitT) -> (s' -> (rep b -> rep UnitT) -> rep UnitT) ->
                                           (s, s', DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => rep (VarT s' b))) ->
                                           (rep c -> rep UnitT) -> rep UnitT
    current f currenta currentb (s, s', (_ ** b), (_ ** b'), (_ ** v), (_ ** v')) k =
      seqs [it (deref b) (currenta s (\x => seqs [assign x v, assign (bool False) b, assign (bool True) b'])),
            it (deref b') (currentb s' (\x => seqs [assign x v', assign (bool False) b'])),
            it (not (deref b) && not (deref b'))
               (seqs [
                  k (f (deref v) (deref v')),
                  assign (bool True) b
                ])]
    reset : (s -> rep UnitT) -> (s' -> rep UnitT) -> (s, s', DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' BoolT)), DPair Type (\s' => rep (VarT s' a)), DPair Type (\s' => rep (VarT s' b))) -> rep UnitT
    reset reseta resetb (s, s', (_ ** b), (_ ** b'), _, _) = seqs [assign (bool True) b, assign (bool False) b', reseta s, resetb s']

example0 : Symantics rep => rep (ArrayT IntT) -> rep IntT
example0 = sum . map (\x => x * (int 2)) . filter (\x => x < (int 3)) . ofArray

example1 : Symantics rep => rep (ArrayT IntT) -> rep IntT
example1 arr = (sum . flatMap (\x => nested1 arr x) . ofArray) arr
  where
    nested2 : rep (ArrayT IntT) -> rep IntT -> Stream rep IntT
    nested2 arr x = (map (\x' => x * x') . ofArray) arr
    nested1 : rep (ArrayT IntT) -> rep IntT -> Stream rep IntT
    nested1 arr x = (flatMap (\x => nested2 arr x) . ofArray) arr

example2 : Symantics rep => rep (ArrayT IntT) -> rep IntT
example2 arr = sum $ zipWith (\x, y => x * y) (nested1 arr) (nested1 arr)
where
  nested1 : rep (ArrayT IntT) -> Stream rep IntT
  nested1 arr = (map (\x => x * (int 2)) . ofArray) arr

example3 : Symantics rep => rep (ArrayT IntT) -> rep (ArrayT IntT) -> rep IntT
example3 arr arr' = sum $ zipWith (\x, y => x * y) (nested1 arr) (nested1 arr')
  where
    nested2 : rep (ArrayT IntT) -> rep IntT -> Stream rep IntT
    nested2 arr x = (filter (\x' => x == x') . ofArray) arr
    nested1 : rep (ArrayT IntT) -> Stream rep IntT
    nested1 arr = (flatMap (\x => nested2 arr x) . ofArray) arr

example4 : Symantics rep => rep (ArrayT IntT) -> rep IntT
example4 arr = sum $ map (\x => x * (int 2)) (nested1 arr)
where
  nested2 : rep (ArrayT IntT) -> rep IntT -> Stream rep IntT
  nested2 arr x = (map (\x' => x * x') . ofArray) arr
  nested1 : rep (ArrayT IntT) -> Stream rep IntT
  nested1 arr = (flatMap (\x => nested2 arr x) . flatMap (\x => nested2 arr x) . ofArray) arr

test0 : Code (ArrowT (ArrayT IntT) IntT)
test0 = lam example0

test3 : Code (ArrowT (ArrayT IntT) (ArrowT (ArrayT IntT) IntT))
test3 = lam (\arr => lam (\arr' => example3 arr arr'))

compile : Code a -> String
compile code = let (C c) = code in c 0


module PQ.Schema

import Control.Monad.Either

import Data.List
import Data.String
import Data.SOP

import PQ.FFI
import PQ.Types

%default total

--------------------------------------------------------------------------------
--          Data Types
--------------------------------------------------------------------------------

public export
data PQPrim : Type where
  SmallInt        : PQPrim
  PQInteger       : PQPrim
  BigInt          : PQPrim
  DoublePrecision : PQPrim
  Text            : PQPrim
  VarChar         : Bits32 -> PQPrim
  Boolean         : PQPrim

export
primSchema : PQPrim -> String
primSchema SmallInt        = "smallint"
primSchema PQInteger       = "integer"
primSchema BigInt          = "bigint"
primSchema DoublePrecision = "double precision"
primSchema Text            = "text"
primSchema (VarChar n)     = #"varchar(\#{show n})"#
primSchema Boolean         = "boolean"

public export
PrimType : PQPrim -> Type
PrimType SmallInt        = Int16
PrimType PQInteger       = Int32
PrimType BigInt          = Int64
PrimType DoublePrecision = Double
PrimType Text            = String
PrimType (VarChar _)     = String
PrimType Boolean         = Bool

export
encodePrimType : (tpe : PQPrim) -> PrimType tpe -> String
encodePrimType SmallInt x        = show x
encodePrimType PQInteger x       = show x
encodePrimType BigInt x          = show x
encodePrimType DoublePrecision x = show x
encodePrimType Text x            = #"'\#{x}'"#
encodePrimType (VarChar _) x     = #"'\#{x}'"#
encodePrimType Boolean True      = "TRUE"
encodePrimType Boolean False     = "FALSE"

export
decodePrimType : (tpe : PQPrim) -> String -> PrimType tpe
decodePrimType SmallInt x        = cast x
decodePrimType PQInteger x       = cast x
decodePrimType BigInt x          = cast x
decodePrimType DoublePrecision x = cast x
decodePrimType Text x            = x
decodePrimType (VarChar _) x     = x
decodePrimType Boolean "t"       = True
decodePrimType Boolean _         = False

public export
data PQType : Type where
  NotNull  : PQPrim -> PQType
  Nullable : PQPrim -> PQType

public export
DBType : PQType -> Type
DBType (NotNull p)  = PrimType p
DBType (Nullable p) = Maybe $ PrimType p

export
encodeDBType : (tpe : PQType) -> DBType tpe -> String
encodeDBType (NotNull p)  v        = encodePrimType p v
encodeDBType (Nullable p) (Just v) = encodePrimType p v
encodeDBType (Nullable p) Nothing  = "DEFAULT"

export
decodeDBType : (tpe : PQType) -> String -> DBType tpe
decodeDBType (NotNull p)  s  = decodePrimType p s
decodeDBType (Nullable p) "" = Nothing
decodeDBType (Nullable p) s  = Just $ decodePrimType p s

--------------------------------------------------------------------------------
--          Table Columns
--------------------------------------------------------------------------------

public export
data Default : PQType -> Type where
  Null        : {0 any : PQPrim} -> Default (Nullable any)
  NoDefault   : {0 any : PQPrim} -> Default (NotNull any)
  Value       : {0 any : PQPrim} -> PrimType any -> Default (NotNull any)
  SmallSerial : Default (NotNull SmallInt)
  Serial      : Default (NotNull PQInteger)
  BigSerial   : Default (NotNull BigInt)

defaultSchema : {tpe : _} -> Default tpe -> String
defaultSchema SmallSerial = "SMALLSERIAL"
defaultSchema Serial      = "SERIAL"
defaultSchema BigSerial   = "BIGSERIAL"
defaultSchema {tpe = Nullable p} Null      = primSchema p
defaultSchema {tpe = NotNull p}  NoDefault = #"\#{primSchema p} NOT NULL"#
defaultSchema {tpe = NotNull p} (Value v)  =
  #"\#{primSchema p} DEFAULT \#{encodePrimType p v}"#

public export
data Constraint : Type where
  Vanilla      : Constraint
  PrimaryKey   : Constraint
  Unique       : Constraint

constraintSchema : Constraint -> String
constraintSchema Vanilla    = ""
constraintSchema PrimaryKey = " PRIMARY KEY"
constraintSchema Unique     = " UNIQUE"

public export
PutType : Default t -> Type -> Type
PutType Null        t = t
PutType NoDefault   t = t
PutType (Value x)   t = Maybe t
PutType SmallSerial _ = ()
PutType Serial      _ = ()
PutType BigSerial   _ = ()

public export
record Column where
  constructor MkField
  0 idrisTpe : Type
  name       : String
  pqType     : PQType
  constraint : Constraint
  deflt      : Default pqType
  fromPQ     : DBType pqType -> Maybe idrisType
  toPQ       : PutType deflt idrisTpe -> PutType deflt (DBType pqType)
  table_name : String

export
encodePutType :  {tpe : _}
              -> (deflt : Default tpe)
              -> PutType deflt (DBType tpe)
              -> String
encodePutType Null x             = encodeDBType tpe x
encodePutType NoDefault x        = encodeDBType tpe x
encodePutType (Value y) (Just x) = encodeDBType tpe x
encodePutType (Value y) Nothing  = "DEFAULT"
encodePutType SmallSerial x      = "DEFAULT"
encodePutType Serial x           = "DEFAULT"
encodePutType BigSerial x        = "DEFAULT"

public export
0 PutTypeC : Column -> Type
PutTypeC (MkField idrisTpe _ _ _ def _ _ _) = PutType def idrisTpe

public export
0 GetTypeC : Column -> Type
GetTypeC c = c.idrisType

public export
primarySerial16 : (0 t : Type) -> String -> (Int16 -> Maybe t) -> String -> Column
primarySerial16 t n f tn =
  MkField t n (NotNull SmallInt) PrimaryKey SmallSerial f id tn

public export
primarySerial32 : (0 t : Type) -> String -> (Int32 -> Maybe t) -> String -> Column
primarySerial32 t n f tn=
  MkField t n (NotNull PQInteger) PrimaryKey Serial f id tn

public export
primarySerial64 : (0 t : Type) -> String -> (Int64 -> Maybe t) -> String -> Column
primarySerial64 t n f tn=
  MkField t n (NotNull BigInt) PrimaryKey BigSerial f id tn

public export
notNull : (0 t : Type)
        -> String
        -> (pq : PQPrim)
        -> (decode : PrimType pq -> Maybe t)
        -> (encode : t -> PrimType pq)
        -> (tn: String)
        -> Column
notNull t n pq dec enc tn=
  MkField t n (NotNull pq) Vanilla NoDefault dec enc tn

public export
notNullDefault : (0 t : Type)
               -> String
               -> (pq   : PQPrim)
               -> (dflt : PrimType pq)
               -> (decode : PrimType pq -> Maybe t)
               -> (encode : t -> PrimType pq)
               -> String
               -> Column
notNullDefault t n pq dflt dec enc tn=
  MkField t n (NotNull pq) Vanilla (Value dflt) dec (map enc) tn

public export
nullable : (0 t : Type)
         -> String
         -> (pq : PQPrim)
         -> (decode : PrimType pq -> Maybe t)
         -> (encode : t -> PrimType pq)
         -> (tn: String)
         -> Column
nullable t n pq dec enc tn =
  MkField (Maybe t) n (Nullable pq) Vanilla Null (maybe (Just Nothing) (map Just . dec)) (map enc) tn

export
columnSchema : Column -> String
columnSchema (MkField _ name tpe con dflt _ _ _) =
  #"\#{name} \#{defaultSchema dflt}\#{constraintSchema con}"#

--------------------------------------------------------------------------------
--          Table
--------------------------------------------------------------------------------

public export
record Table where
  constructor MkTable
  name    : String
  columns : List Column

export
createTableSQL : Table -> String
createTableSQL (MkTable name columns) =
  let cols = fastConcat $ intersperse ",\n" $ map (("  " ++) . columnSchema) columns
   in #"""
      CREATE TABLE \#{name} (
      \#{cols}
      );
      """#

export
createTable : HasIO io => MonadError SQLError io => Connection -> Table -> io ()
createTable c t = exec_ c (createTableSQL t) COMMAND_OK

--------------------------------------------------------------------------------
--          Queries
--------------------------------------------------------------------------------

public export
data EqPrim : PQPrim -> Type where
  EqSmallInt        : EqPrim SmallInt
  EqPQInteger       : EqPrim PQInteger
  EqBigInt          : EqPrim BigInt
  EqDoublePrecision : EqPrim DoublePrecision
  EqText            : EqPrim Text
  EqBoolean         : EqPrim Boolean

public export
data Eq : PQType -> Type where
  EqNotNull  : EqPrim p -> Eq (NotNull p)
  EqNullable : EqPrim p -> Eq (Nullable p)

public export
data OrdPrim : PQPrim -> Type where
  OrdSmallInt        : OrdPrim SmallInt
  OrdPQInteger       : OrdPrim PQInteger
  OrdBigInt          : OrdPrim BigInt
  OrdDoublePrecision : OrdPrim DoublePrecision
  OrdText            : OrdPrim Text
  OrdBoolean         : OrdPrim Boolean

public export
data Ord : PQType -> Type where
  OrdNotNull  : OrdPrim p -> Ord (NotNull p)
  OrdNullable : OrdPrim p -> Ord (Nullable p)

public export
data IsNullable : PQType -> Type where
  ItIsNullable : {0 p : PQPrim} -> IsNullable (Nullable p)

public export
data Op : Type where
  JC : (c1 : Column) -> (c2 : Column) -> Op
  (==)  : (c : Column) -> DBType (pqType c) -> {auto 0 _ : Eq (pqType c)} -> Op
  (/=)  : (c : Column) -> DBType (pqType c) -> {auto 0 _ : Eq (pqType c)} -> Op
  (>)   : (c : Column) -> DBType (pqType c) -> {auto 0 _ : Ord (pqType c)} -> Op
  (>=)  : (c : Column) -> DBType (pqType c) -> {auto 0 _ : Ord (pqType c)} -> Op
  (<)   : (c : Column) -> DBType (pqType c) -> {auto 0 _ : Ord (pqType c)} -> Op
  (<=)  : (c : Column) -> DBType (pqType c) -> {auto 0 _ : Ord (pqType c)} -> Op
  IsNull    : (c : Column) -> {auto 0 _ : IsNullable (pqType c)} -> Op
  IsNotNull : (c : Column) -> {auto 0 _ : IsNullable (pqType c)} -> Op
  (&&)  : Op -> Op -> Op
  (||)  : Op -> Op -> Op
  Not   : Op -> Op
  True  : Op
  False : Op

export
opToSQL : Op -> String
opToSQL (JC c1 c2)  = #"\#{c1.table_name}.\#{c1.name}=\#{c2.table_name}.\#{c2.name}"#
opToSQL (c == x)      = #"\#{c.name} = \#{encodeDBType c.pqType x}"#
opToSQL (c /= x)      = #"\#{c.name} <> \#{encodeDBType c.pqType x}"#
opToSQL (c > x)       = #"\#{c.name} > \#{encodeDBType c.pqType x}"#
opToSQL (c >= x)      = #"\#{c.name} >= \#{encodeDBType c.pqType x}"#
opToSQL (c < x)       = #"\#{c.name} < \#{encodeDBType c.pqType x}"#
opToSQL (c <= x)      = #"\#{c.name} <= \#{encodeDBType c.pqType x}"#
opToSQL (IsNull c)    = #"\#{c.name} IS NULL"#
opToSQL (IsNotNull c) = #"\#{c.name} IS NOT NULL"#
opToSQL (x && y)      = #"(\#{opToSQL x}) AND (\#{opToSQL y})"#
opToSQL (Not x)       = #"NOT (\#{opToSQL x})"#
opToSQL (x || y)      = #"(\#{opToSQL x}) OR (\#{opToSQL y})"#
opToSQL True          = "TRUE"
opToSQL False         = "FALSE"


module Circuits

-- Based on http://okmij.org/ftp/tagless-final/course2/

interface Sym where
  Repr : Type

  lit : Bool -> Repr
  neg : Repr -> Repr
  (&&) : Repr -> Repr -> Repr
  (||) : Repr -> Repr -> Repr

[boolSym] Sym where
  Repr = Bool

  lit x = x
  neg x = not x
  (&&) x y = x && y
  (||) x y = x || y

[strSym] Sym where
  Repr = String

  lit x = if x then "tt" else "ff"
  neg x = "~" ++ x
  (&&) x y = "(" ++ x ++ " && " ++ y ++ ")"
  (||) x y = "(" ++ x ++ " || " ++ y ++ ")"

namespace Ex
  interface NAND where
    Repr : Type

    lit : Bool -> Repr
    nand : Repr -> Repr -> Repr

[boolNAND] NAND where
  Repr = Bool

  lit x = x
  nand x y =  not (x && y)

[strNAND] NAND where
  Repr = String

  lit x = if x then "tt" else "ff"
  nand x y =  "(" ++ x ++ " ^^ " ++ y ++ ")"

[nandSym] NAND => Sym where
  Repr = Ex.Repr

  lit x = Ex.lit x
  neg x = nand x x
  (&&) x y = neg (nand x y)
  (||) x y = nand (neg x) (neg y)

ex : Sym => Repr
ex = lit True && (neg (lit False))

test : Bool
test = ex @{nandSym @{boolNAND}}


module Extra.Op

public export
(>>) : (a -> b) -> (b -> c) -> (a -> c)
(>>) f g = g . f
infixr 9 >>

public export
(|>) : a -> (a -> b) -> b
(|>) x f = f x
infixr 5 |>


-- ---------------------------------------------------------------- [ Core.idr ]
-- Module      : Lightyear.Core
-- Description : Central Definitions and Instances
--
-- This code is distributed under the BSD 2-clause license.
-- See the file LICENSE in the root directory for its full text.
-- --------------------------------------------------------------------- [ EOH ]
module Lightyear.Core

import Data.Fin
import Control.Monad.Trans
import Control.Monad.State

%access export
%default total

||| Parse results
public export
data Result str a =
  ||| Sucess, returning the remaining string and the parser result
  Success str a |
  ||| Failure, returning a stack trace of errors based on `<?>`
  Failure (List (str, String)) -- a stacktrace of errors based on <?> and friends

implementation Functor (Result str) where
  map f (Success s x ) = Success s (f x)
  map f (Failure es) = Failure es

record ParserT str (m : Type -> Type) a where
  constructor PT
  runParserT :
    (r : Type) ->
    (a -> str -> m r) -> -- uncommitted success
    (a -> str -> m r) -> -- committed success
    (List (str, String) -> m r) -> -- uncommitted error
    (List (str, String) -> m r) -> -- committed error
    str ->
    m r

||| Run a parser monad on some input
execParserT : Monad m => ParserT str m a
                      -> (input : str)
                      -> m (Result str a)
execParserT {str} {m} {a} (PT p) input = p (Result str a) success success failure failure input
  where success x i = pure $ Success i x
        failure = pure . Failure

implementation Monad m => Functor (ParserT str m) where
  map {a} {b} f (PT p) = PT $ \r, us, cs => p r (us . f) (cs . f)

implementation Monad m => Applicative (ParserT str m) where
  pure x = PT (\r, us, cs, ue, ce => us x)

  (<*>) (PT f) (PT g) = PT $ \r, us, cs, ue, ce =>
    f r (\f' => g r (us . f') (cs . f') ue ce)
        (\f' => g r (cs . f') (cs . f') ce ce)
        ue ce

infixl 2 <*>|
||| A variant of <$>, lazy in its second argument, which must NOT be
||| pattern-matched right away because we want to keep it lazy in case
||| it's not used.
(<*>|) : Monad m => ParserT str m (a -> b)
                 -> Lazy (ParserT str m a)
                 -> ParserT str m b
(<*>|) (PT f) x = PT $ \r, us, cs, ue, ce =>
    f r (\f' => let PT g = x in g r (us . f') (cs . f') ue ce)
        (\f' => let PT g = x in g r (cs . f') (cs . f') ce ce)
        ue ce

implementation Monad m => Monad (ParserT str m) where
  (>>=) (PT x) f = PT $ \r, us, cs, ue, ce =>
    x r (\x' => let PT y = f x' in y r us cs ue ce)
        (\x' => let PT y = f x' in y r cs cs ce ce)
        ue ce

implementation Monad m => MonadTrans (ParserT str) where
  lift x = PT $ \r, us, cs, ue, ce, s => (x >>= flip us s)

-- HACK
-- for some reason the MonadState instance does not work with plain lift :(
private
lift' : Monad m => m a -> ParserT str m a
lift' = lift

implementation MonadState s m => MonadState s (ParserT str m) where
  get = lift' get
  put = lift' . put

||| Fail with some error message
fail : String -> ParserT str m a
fail msg = PT $ \r, us, cs, ue, ce, i => ue [(i, msg)]

implementation Monad m => Alternative (ParserT str m) where
  empty = fail "non-empty alternative"

  (<|>) (PT x) (PT y) = PT $ \r, us, cs, ue, ce, i =>
    x r us cs (\err => y r us cs (ue . (err ++))
                                 (ce . (err ++)) i) ce i

infixl 3 <|>|

||| A variant of <|>, lazy in its second argument, which must NOT be
||| pattern-matched right away because we want to keep it lazy in case
||| it's not used.
(<|>|) : Monad m => ParserT str m a
                 -> Lazy (ParserT str m a)
                 -> ParserT str m a
(<|>|) (PT x) y = PT $ \r, us, cs, ue, ce, i =>
  x r us cs (\err => let PT y' = y in y' r us cs (ue . (err ++))
                                                 (ce . (err ++)) i) ce i

infixl 0 <?>
||| Associate an error with parse failure
(<?>) : Monad m => ParserT str m a -> String -> ParserT str m a
(PT f) <?> msg = PT $ \r, us, cs, ue, ce, i =>
  f r us cs (ue . ((i, msg) ::)) (ce . ((i, msg) ::)) i

||| Commit to a parse alternative and prevent backtracking
commitTo : Monad m => ParserT str m a -> ParserT str m a
commitTo (PT f) = PT $ \r, us, cs, ue, ce => f r cs cs ce ce

-- There is no reason that we mark "str" as the determining type
-- other than to aid typeinterface resolution.
--
-- I feel that having this restriction (which is probably okay
-- given that the only streams so far are String and Text anyway)
-- is more acceptable than failing surprisingly
-- any time the unsuspecting user calls "satisfy" without {tok=Char}
-- in an odd context.
--
-- We make "str" the determining type because it's usually fixed
-- by the parser monad you're working in, which helps resolution.
interface Stream tok str | str where
  uncons : str -> Maybe (tok, str)

||| Matches a single element that satisfies some condition, accepting
||| a transformation of successes.
satisfyMaybe : (Monad m, Stream tok str)
                        => (tok -> Maybe out)
                        -> ParserT str m out
satisfyMaybe {tok=tok} {str=str} f =
  PT $ \r, us, cs, ue, ce, i =>
    case uncons {tok=tok} {str=str} i of
      Nothing      => ue [(i, "a token, not EOF")]
      Just (t, i') => case f t of
        Nothing  => ue [(i, "a different token")]
        Just res => us res i'

||| Matches a single element that satisfies some condition.
satisfy : (Monad m, Stream tok str)
                   => (tok -> Bool)
                   -> ParserT str m tok
satisfy p = satisfyMaybe (\t => if p t then Just t else Nothing)

||| Succeeds if and only if the argument parser fails.
|||
||| In Parsec, this combinator is called `notFollowedBy`.
requireFailure : ParserT str m tok -> ParserT str m ()
requireFailure (PT f) = PT $ \r, us, cs, ue, ce, i =>
                               f r
                                 (\t, s => ue [(i, "argument parser to fail")])
                                 (\t, s => ce [(i, "argument parser to fail")])
                                 (\errs => us () i)
                                 (\errs => cs () i)
                                 i
-- --------------------------------------------------------------------- [ EOF ]


module Control.Monad.Maybe

-------------------------------------------------
-- The monad transformer `MaybeT m a` equips a monad with the ability to
-- return no value at all.

-- Sequenced actions of `MaybeT m a` produce a value `a` only if all of the
-- actions in the sequence returned a value.

-- This is isomorphic to `EitherT ()` and therefore less powerful than `EitherT e a`
-- ability to not return a result.
-------------------------------------------------

import Control.Monad.Trans
import Data.Maybe

%default total

public export
data MaybeT : (m : Type -> Type) -> (a : Type) -> Type where
  MkMaybeT : m (Maybe a) -> MaybeT m a

public export
%inline
runMaybeT : MaybeT m a -> m (Maybe a)
runMaybeT (MkMaybeT x) = x

public export
%inline
isNothingT : Functor m => MaybeT m a -> m Bool
isNothingT = map isNothing . runMaybeT

public export
%inline
isJustT : Functor m => MaybeT m a -> m Bool
isJustT = map isJust . runMaybeT

public export
%inline
maybeT : Monad m => m b -> (a -> m b) -> MaybeT m a -> m b
maybeT v g x = runMaybeT x >>= maybe v g

public export
%inline
fromMaybeT : Monad m => m a -> MaybeT m a -> m a
fromMaybeT v x = runMaybeT x >>= maybe v pure

public export
%inline
toMaybeT : Functor m => Bool -> m a -> MaybeT m a
toMaybeT b m = MkMaybeT $ map (\a => toMaybe b a) m

||| map the underlying computation
||| The basic 'unwrap, apply, rewrap' of this transformer.
public export
%inline
mapMaybeT : (m (Maybe a) -> n (Maybe a')) -> MaybeT m a -> MaybeT n a'
mapMaybeT f = MkMaybeT . f . runMaybeT

||| Analogous to Just, aka pure for MaybeT
public export
%inline
just : Applicative m => a -> MaybeT m a
just = MkMaybeT . pure . Just

||| Analogous to Nothing, aka empty for MaybeT
public export
%inline
nothing : Applicative m => MaybeT m a
nothing = MkMaybeT $ pure Nothing

-------------------------------------------------
-- Interface Implementations
-------------------------------------------------

public export
Eq (m (Maybe a)) => Eq (MaybeT m a) where
 (==) = (==) `on` runMaybeT

public export
Ord (m (Maybe a)) => Ord (MaybeT m a) where
 compare = compare `on` runMaybeT

public export
Show (m (Maybe a)) => Show (MaybeT m a) where
  showPrec d (MkMaybeT x) = showCon d "MkMaybeT" $ showArg x

||| Corresponds to the Semigroup instance of Maybe
|||
||| Note: This could also be implemented with only an Applicative
||| prerequisite: `MkMaybeT x <+> MkMaybeT y = MkMaybeT $ [| x <+> y |]`
||| However, the monadic version is more efficient for long-running effects,
||| only evaluating the second argument if the first returns `Nothing`.
public export
Monad m => Semigroup (MaybeT m a) where
  MkMaybeT x <+> MkMaybeT y = MkMaybeT $ do
    r@(Just _) <- x | Nothing => y
    pure r

public export
Monad m => Monoid (MaybeT m a) where
  neutral = nothing

public export
Functor m => Functor (MaybeT m) where
  map f m = MkMaybeT $ map f <$> runMaybeT m

public export
Foldable m => Foldable (MaybeT m) where
  foldr f acc (MkMaybeT e)
    = foldr (\x,xs => maybe xs (`f` xs) x) acc e

  null (MkMaybeT e) = null e

public export
Traversable m => Traversable (MaybeT m) where
  traverse f (MkMaybeT x)
    = MkMaybeT <$> traverse (maybe (pure Nothing) (map Just . f)) x

public export
Applicative m => Applicative (MaybeT m) where
  pure = just
  MkMaybeT f <*> MkMaybeT x = MkMaybeT [| f <*> x |]

public export
Monad m => Monad (MaybeT m) where
  MkMaybeT x >>= k = MkMaybeT $ x >>= maybe (pure Nothing) (runMaybeT . k)

||| See note about Monad prerequisite on Semigroup instance.
public export
Monad m => Alternative (MaybeT m) where
  empty = nothing
  MkMaybeT x <|> my = MkMaybeT $ x >>= \case
    r@(Just _) => pure r
    Nothing    => runMaybeT my

public export
MonadTrans MaybeT where
  lift = MkMaybeT . map Just

public export
HasIO m => HasIO (MaybeT m) where
  liftIO act = MkMaybeT $ liftIO (io_bind act (pure . Just))


module ParserCombinator

%access public export

record Pos where
    constructor MkPos
    line, column : Int

Show Pos where
    show (MkPos line col) = "(line " ++ (show line) ++ ", column " ++ (show col) ++ ")"

data Error = MkError String

Show Error where
    show (MkError err) = err

data ParseResult a = ParseError Error String Pos | ParseSuccess a String Pos

Show a => Show (ParseResult a) where
    show (ParseError err _ pos) = "Error " ++ (show pos) ++ ": " ++ (show err)
    show (ParseSuccess a _ _) = show a

data Parser : Type -> Type where
    MkParser : (String -> Pos -> ParseResult a) -> Parser a

parse' : Parser a -> String -> Pos -> ParseResult a
parse' (MkParser p) inp pos = p inp pos

Functor Parser where
    map f m1 = MkParser $ \inp, pos =>
        case parse' m1 inp pos of
            ParseError err s2 pos => ParseError err s2 pos
            ParseSuccess a rest pos => ParseSuccess (f a) rest pos

mutual
    Applicative Parser where
        pure a = MkParser $ \inp, pos => ParseSuccess a inp pos
        af <*> ax = do
            f <- af
            x <- ax
            pure (f x)

    Monad Parser where
        p >>= f = MkParser $ \inp, pos =>
            case parse' p inp pos of
                ParseError err _ pos' => ParseError err inp pos'
                ParseSuccess a rest pos' => parse' (f a) rest pos'

failure : String -> Parser a
failure err = MkParser $ \inp, pos => ParseError (MkError err) inp pos

-- TODO: USE THIS!
-- TODO: RENAME PROBABLY!
failWith : String -> Parser a -> Parser a
failWith err p =
    MkParser $ \inp, pos =>
        case parse' p inp pos of
            ParseError _ inp' pos' => ParseError (MkError err) inp' pos'
            ok@(ParseSuccess _ _ _) => ok

nextPos : Char -> Pos -> Pos
nextPos c pos =
    if c == '\n'
    then record { line $= (+ 1), column $= (const 0) } pos
    else record { column $= (+ 1) } pos

item : Parser Char
item =
    MkParser $ \inp, pos =>
        case inp of
            "" => ParseError (MkError "'Item' run on empty input") "" pos
            s =>
                let c = (strHead s)
                in ParseSuccess c (strTail s) (nextPos c pos)

(<|>) : Parser a -> Parser a -> Parser a
p <|> q =
    MkParser $ \inp, pos =>
        case parse' p inp pos of
            ParseError _ _ _ => parse' q inp pos
            ParseSuccess a rest pos' => ParseSuccess a rest pos'

mutual
    many1 : Parser a -> Parser (List a)
    many1 p = do
        v <- p
        vs <- many' p
        pure (v :: vs)

    many' : Parser a -> Parser (List a)
    many' p = many1 p <|> pure []

skipMany : Parser a -> Parser ()
skipMany p = do
    many' p
    pure ()

skipMany1 : Parser a -> Parser ()
skipMany1 p = do
    many1 p
    pure ()

skipUntil : Parser t -> Parser a -> Parser ()
skipUntil end p = scan
    where
    scan =
        do end
           pure ()
        <|>
        do p
           scan
           pure ()

try : Parser a -> Parser a
try p =
    MkParser $ \inp, pos =>
        case parse' p inp pos of
            ParseError err _ pos' => ParseError err inp pos'
            ParseSuccess a rest pos' => ParseSuccess a rest pos'

sat : (Char -> Bool) -> Parser Char
sat p = do
    x <- item
    if p x
    then pure x
    else failure $ "Condition not satisfied for: `" ++ (singleton x) ++ "`"

rej : (Char -> Bool) -> Parser Char
rej p = do
    x <- item
    if not (p x)
    then pure x
    else failure $ "Rejection condition not satisfied for: `" ++ (singleton x) ++ "`"

char : Char -> Parser Char
char x = sat (== x)

oneOf : String -> Parser Char
oneOf "" = item *> failure "Empty input to 'OneOf'"
oneOf s = (try (char (strHead s))) <|> oneOf (strTail s)

noneOf : String -> Parser Char
noneOf s =
    do
        c <- item
        go c s
    where
        go c "" = pure c
        go c s = do
            if c == strHead s
            then failure $ "Rejection condition not satisfied for: `" ++ (singleton c) ++ "`"
            else go c (strTail s)

sepBy : Parser a -> Parser b -> Parser (List a)
sepBy p sep = separated <|> pure []
    where
        separated = do
            x <- p
            xs <- many' (sep *> p)
            pure (x :: xs)

endBy : Parser a -> Parser b -> Parser (List a)
endBy p sep =
  many' $ do
    x <- p
    sep
    pure x

digit : Parser Char
digit = sat isDigit

hexDigit : Parser Char
hexDigit = digit <|> oneOf "ABCDEFabcdef"

octDigit : Parser Char
octDigit = oneOf "01234567"

binDigit : Parser Char
binDigit = oneOf "01"

lower : Parser Char
lower = sat isLower

upper : Parser Char
upper = sat isUpper

letter : Parser Char
letter = sat isAlpha

alphanum : Parser Char
alphanum = sat isAlphaNum

space : Parser Char
space = sat isSpace

spaces : Parser ()
spaces = skipMany1 space

string : String -> Parser String
string "" = pure ""
string s = do
    char (strHead s)
    string (strTail s)
    pure s

eof : Parser ()
eof = MkParser $ \inp, pos =>
    case inp of
        "" => ParseSuccess () inp pos
        s => ParseError (MkError "Not end of file") s (nextPos (strHead s) pos)

parse : Parser a -> String -> ParseResult a
parse p inp = parse' p inp (MkPos 1 0)