||| An Idris port of the Wadler-Leijen pretty-printer.
module Text.PrettyPrint.Leijen

import Data.List
import Data.Stream

%default total

||| Zip a Stream and a List together.
private
zipWithStreamL : (f : a -> b -> c) -> Stream a -> (r : List b) -> List c
zipWithStreamL _ _         []        = []
zipWithStreamL f (x :: xs) (y :: ys) = f x y :: zipWithStreamL f xs ys

||| Create a string from a specified number of spaces.
|||
||| @ n how many spaces to use
private
spaces : (n : Nat) -> String
spaces Z = ""
spaces n = pack (replicate n ' ')

private
indentation : Nat -> String
indentation n = spaces n

infixr 5 |/|, |//|, |$|, |$$|
infixr 6 |+|, |++|

||| The abstract data type `Doc` represents pretty documents.
|||
||| Doc is an instance of the `Show` class. `(show doc)` pretty prints
||| document `doc` with a page width of 100 characters and a ribbon
||| width of 40 characters.
|||
|||     > show (text "hello" |$| text "world")
|||
||| Which would return the string "hello\nworld", i.e.
|||
|||
|||     hello
|||     world
|||
export
data Doc : Type where
  Empty : Doc

  ||| A single character document with the invariant that the
  ||| character is not a newline.
  Char' : Char -> Doc

  ||| A document containing a string (plus its length). Invariant:
  ||| the string doesn't contain a newline.
  Text : Nat -> String -> Doc

  ||| A newline document.
  |||
  ||| @ nospace If True, then when this newline is undone by group, do
  ||| not insert a space
  Line : (nospace : Bool) -> Doc

  Cat : Doc -> Doc -> Doc
  Nest : Int -> Doc -> Doc

  ||| One document or another.
  |||
  ||| Invariant: first lines of first doc longer than the first lines
  ||| of the second doc
  |||
  ||| @ d1 the document with the longer first lines
  ||| @ d2 the document with the shorter first lines
  Union : (d1, d2 : Doc) -> Doc

  Column  : (Nat -> Doc) -> Doc
  Nesting : (Int -> Doc) -> Doc

||| The data type `SimpleDoc` represents rendered documents and is
||| used by the display functions.
|||
||| The `Nat` in `SText` contains the length of the string. The `Nat`
||| in `SLine` contains the indentation for that line. The library
||| provides two default display functions 'displayS' and
||| 'displayIO'. You can provide your own display function by writing a
||| function from a `SimpleDoc` to your own output format.
public export
data SimpleDoc  = SEmpty
                | SChar Char SimpleDoc
                | SText Nat String SimpleDoc
                | SLine Nat SimpleDoc

||| List of indentation/document pairs; saves an indirection over `List (Nat,Doc)`
public export
data Docs   = Nil
            | Cons Nat Doc Docs

-----------------------------------------------------------
-- Primitives
-----------------------------------------------------------

||| The empty document is, indeed, empty. Although `empty` has no
||| content, it does have a 'height' of 1 and behaves exactly like
||| `(text "")` (and is therefore not a unit of `|$|`).
public export
empty : Doc
empty           = Empty

||| The `line` document advances to the next line and indents to the
||| current nesting level. Document `line` behaves like `(text " ")`
||| if the line break is undone by 'group'.
public export
line : Doc
line            = Line False

||| The document `(char c)` contains the literal character `c`. The
||| character shouldn't be a newline (`'\n'`), the function 'line'
||| should be used for line breaks.
public export
char : Char -> Doc
char '\n'       = line
char c          = Char' c

||| The document `(text s)` contains the literal string `s`. The
||| string shouldn't contain any newline (`'\n'`) characters. If the
||| string contains newline characters, the function 'string' should be
||| used.
public export
text : String -> Doc
text ""         = Empty
text s          = Text (length s) s

||| The `linebreak` document advances to the next line and indents to
||| the current nesting level. Document `linebreak` behaves like
||| 'empty' if the line break is undone by 'group'.
public export
linebreak : Doc
linebreak       = Line True

||| Horizontal concatenation of documents
public export
beside : Doc -> Doc -> Doc
beside x y      = Cat x y

||| The document `(nest i x)` renders document `x` with the current
||| indentation level increased by i (See also 'hang', 'align' and
||| 'indent').
|||
||| > nest 2 (text "hello" |$| text "world") |$| text "!"
|||
||| outputs as:
|||
||| `
||| hello
|||   world
||| !
||| `
public export
nest : Int -> Doc -> Doc
nest i x        = Nest i x

public export
column : (Nat -> Doc) -> Doc
column f        = Column f

public export
nesting : (Int -> Doc) -> Doc
nesting f       = Nesting f

||| The `group` combinator is used to specify alternative
||| layouts. The document `(group x)` undoes all line breaks in
||| document `x`. The resulting line is added to the current line if
||| that fits the page. Otherwise, the document `x` is rendered without
||| any changes.
public export
group : Doc -> Doc
group x         = Union (flatten x) x
  where flatten : Doc -> Doc
        flatten (Cat x y)       = Cat (flatten x) (flatten y)
        flatten (Nest i x)      = Nest i (flatten x)
        flatten (Line break)    = if break then Empty else Text 1 " "
        flatten (Union x _)     = flatten x
        flatten (Column f)      = Column (\n => flatten (f n))
        flatten (Nesting f)     = Nesting (\n => flatten (f n))
        flatten other           = other                     --Empty,Char,Text

-----------------------------------------------------------
-- semi primitive: Alignment and indentation
-----------------------------------------------------------

-- The combinators in this section can not be described by Wadler's
-- original combinators. They align their output relative to the
-- current output position - in contrast to `nest` which always
-- aligns to the current nesting level. This deprives these
-- combinators from being `optimal'. In practice however they
-- prove to be very useful. The combinators in this section should
-- be used with care, since they are more expensive than the other
-- combinators. For example, `align` shouldn't be used to pretty
-- print all top-level declarations of a language, but using `hang`
-- for let expressions is fine.

||| The document `(align x)` renders document `x` with the nesting
||| level set to the current column. It is used for example to
||| implement 'hang'.
|||
||| As an example, we will put a document right above another one,
||| regardless of the current nesting level:
|||
||| > x $$ y  = align (x |$| y)
|||
||| > test    = text "hi" |++| (text "nice" $$ text "world")
|||
||| which will be layed out as:
|||
||| `
||| hi nice
|||    world
||| `
public export
align : Doc -> Doc
align d         = column (\k =>
                  nesting (\i => nest (cast k - i) d))   --nesting might be negative :-)

||| The hang combinator implements hanging indentation. The document
||| `(hang i x)` renders document `x` with a nesting level set to the
||| current column plus `i`. The following example uses hanging
||| indentation for some text:
|||
||| > test  = hang 4 (fillSep (map text
||| >         (words "the hang combinator indents these words !")))
|||
||| Which lays out on a page with a width of 20 characters as:
|||
||| `
||| the hang combinator
|||     indents these
|||     words !
||| `
|||
||| The `hang` combinator is implemented as:
|||
||| > hang i x  = align (nest i x)
public export
hang : Nat -> Doc -> Doc
hang i d        = align (nest (cast i) d)

||| The document `(indent i x)` indents document `x` with `i` spaces.
|||
||| > test  = indent 4 (fillSep (map text
||| >         (words "the indent combinator indents these words !")))
|||
||| Which lays out with a page width of 20 as:
|||
||| `
|||     the indent
|||     combinator
|||     indents these
|||     words !
||| `
public export
indent : Nat -> Doc -> Doc
indent i d      = hang i (text (spaces i) `beside` d)

-----------------------------------------------------------
-- Character documents
-----------------------------------------------------------

||| The document `lparen` contains a left parenthesis, "(".
public export
lparen : Doc
lparen          = char '('

||| The document `rparen` contains a right parenthesis, ")".
public export
rparen : Doc
rparen          = char ')'

||| The document `langle` contains a left angle, "<".
public export
langle : Doc
langle          = char '<'

||| The document `rangle` contains a right angle, ">".
public export
rangle : Doc
rangle          = char '>'

||| The document `lbrace` contains a left brace, "{".
public export
lbrace : Doc
lbrace          = char '{'

||| The document `rbrace` contains a right brace, "}".
public export
rbrace : Doc
rbrace          = char '}'

||| The document `lbracket` contains a left square bracket, "[".
public export
lbracket : Doc
lbracket        = char '['

||| The document `rbracket` contains a right square bracket, "]".
public export
rbracket : Doc
rbracket        = char ']'

||| The document `squote` contains a single quote, "'".
public export
squote : Doc
squote          = char '\''

||| The document `dquote` contains a double quote, '"'.
public export
dquote : Doc
dquote          = char '"'

||| The document `semi` contains a semi colon, ";".
public export
semi : Doc
semi            = char ';'

||| The document `colon` contains a colon, ":".
public export
colon : Doc
colon           = char ':'

||| The document `comma` contains a comma, ",".
public export
comma : Doc
comma           = char ','

||| The document `space` contains a single space, " ".
|||
||| > x |++| y   = x |+| space |+| y
public export
space : Doc
space           = char ' '

||| The document `dot` contains a single dot, ".".
public export
dot : Doc
dot             = char '.'

||| The document `backslash` contains a backslash, "\\".
public export
backslash : Doc
backslash       = char '\\'

||| The document `equals` contains an equal sign, "=".
public export
equals : Doc
equals          = char '='

-----------------------------------------------------------
-- high-level combinators
-----------------------------------------------------------

||| The document `softline` behaves like `space` if the resulting
||| output fits the page, otherwise it behaves like `line`.
|||
||| ```
||| softline = group line
||| ```
public export
softline : Doc
softline        = group line

||| The document `softbreak` behaves like `empty` if the resulting
||| output fits the page, otherwise it behaves like 'line'.
|||
||| ```
||| softbreak  = group linebreak
||| ```
public export
softbreak : Doc
softbreak       = group linebreak

||| The document `(x |+| y)` concatenates document `x` and document
||| `y`. It is an associative operation having 'empty' as a left and
||| right unit.
public export
(|+|) : Doc -> Doc -> Doc
x |+| y          = x `beside` y

||| The document `(x |++| y)` concatenates document `x` and `y` with a
||| `space` in between.
public export
(|++|) : Doc -> Doc -> Doc
x |++| y         = x |+| space |+| y

||| The document `(x |/| y)` concatenates document `x` and `y` with a
||| 'softline' in between. This effectively puts `x` and `y` either
||| next to each other (with a `space` in between) or underneath each
||| other.
public export
(|/|) : Doc -> Doc -> Doc
x |/| y         = x |+| softline |+| y

||| The document `(x |//| y)` concatenates document `x` and `y` with
||| a 'softbreak' in between. This effectively puts `x` and `y` either
||| right next to each other or underneath each other.
public export
(|//|) : Doc -> Doc -> Doc
x |//| y        = x |+| softbreak |+| y

||| The document `(x |$| y)` concatenates document `x` and `y` with a
||| `line` in between.
public export
(|$|) : Doc -> Doc -> Doc
x |$| y         = x |+| line |+| y

||| The document `(x |$$| y)` concatenates document `x` and `y` with
||| a `linebreak` in between.
public export
(|$$|) : Doc -> Doc -> Doc
x |$$| y        = x |+| linebreak |+| y

||| Fold a list of documents using some combining operator.
|||
||| @ f how to combine the documents
||| @ ds the documents to combine
public export
fold : (f : Doc -> Doc -> Doc) -> (ds : List Doc) -> Doc
fold _ []       = empty
fold f (d::ds)  = f d (fold f ds)

||| The document `(vsep xs)` concatenates all documents `xs`
||| vertically with `(|$|)`. If a 'group' undoes the line breaks
||| inserted by `vsep`, all documents are separated with a space.
|||
||| ```
||| someText = map text (words ("text to lay out"))
|||
||| test     = text "some" |++| vsep someText
||| ```
|||
||| This is layed out as:
|||
||| ```
||| some text
||| to
||| lay
||| out
||| ```
|||
||| The 'align' combinator can be used to align the documents under
||| their first element
|||
||| ```
||| test     = text "some" |++| align (vsep someText)
||| ```
|||
||| Which is printed as:
|||
||| ```
||| some text
|||      to
|||      lay
|||      out
||| ```
public export
vsep : List Doc -> Doc
vsep            = fold (|$|)

||| The document `(sep xs)` concatenates all documents `xs` either
||| horizontally with `(|++|)`, if it fits the page, or vertically with
||| `(|$|)`.
|||
||| ```
||| sep xs  = group (vsep xs)
||| ```
public export
sep : List Doc -> Doc
sep             = group . vsep

||| The document `(fillSep xs)` concatenates documents `xs`
||| horizontally with `(|++|)` as long as its fits the page, than
||| inserts a `line` and continues doing that for all documents in
||| `xs`.
|||
||| ```
||| fillSep xs  = foldr (|/|) empty xs
||| ```
public export
fillSep : List Doc -> Doc
fillSep         = fold (|/|)

||| The document `(hsep xs)` concatenates all documents `xs`
||| horizontally with `(|++|)`.
public export
hsep : List Doc -> Doc
hsep            = fold (Text.PrettyPrint.Leijen.(|++|))

||| The document `(hcat xs)` concatenates all documents `xs`
||| horizontally with `(|+|)`.
public export
hcat : List Doc -> Doc
hcat            = fold (|+|)

||| The document `(vcat xs)` concatenates all documents `xs`
||| vertically with `(|$$|)`. If a `group` undoes the line breaks
||| inserted by `vcat`, all documents are directly concatenated.
public export
vcat : List Doc -> Doc
vcat            = fold (|$$|)

||| The document `(cat xs)` concatenates all documents `xs` either
||| horizontally with `(|+|)`, if it fits the page, or vertically with
||| `(|$$|)`.
|||
||| ```
||| cat xs  = group (vcat xs)
||| ```
public export
cat : List Doc -> Doc
cat             = group . vcat

||| The document `(fillCat xs)` concatenates documents `xs`
||| horizontally with `(|+|)` as long as its fits the page, than inserts
||| a `linebreak` and continues doing that for all documents in `xs`.
|||
||| ```
||| fillCat xs  = foldr (|//|) empty xs
||| ```
public export
fillCat : List Doc -> Doc
fillCat         = fold (|//|)

||| The document `(enclose l r x)` encloses document `x` between
||| documents `l` and `r` using `(|+|)`.
|||
||| ```
||| enclose l r x   = l |+| x |+| r
||| ```
public export
enclose : Doc -> Doc -> Doc -> Doc
enclose l r x   = l |+| x |+| r

||| Document `(squotes x)` encloses document `x` with single quotes
||| "\'".
public export
squotes : Doc -> Doc
squotes         = enclose squote squote

||| Document `(dquotes x)` encloses document `x` with double quotes
||| '\"'.
public export
dquotes : Doc -> Doc
dquotes         = enclose dquote dquote

||| Document `(braces x)` encloses document `x` in braces, "{" and
||| "}".
public export
braces : Doc -> Doc
braces          = enclose lbrace rbrace

||| Document `(parens x)` encloses document `x` in parenthesis, "("
||| and ")".
public export
parens : Doc -> Doc
parens          = enclose lparen rparen

||| Document `(angles x)` encloses document `x` in angles, "<" and
||| ">".
public export
angles : Doc -> Doc
angles          = enclose langle rangle

||| Document `(brackets x)` encloses document `x` in square brackets,
||| "[" and "]".
public export
brackets : Doc -> Doc
brackets        = enclose lbracket rbracket

-----------------------------------------------------------
-- list, tupled and semiBraces pretty print a list of
-- documents either horizontally or vertically aligned.
-----------------------------------------------------------

||| The document `(encloseSep l r sep xs)` concatenates the documents
||| `xs` separated by `sep` and encloses the resulting document by `l`
||| and `r`. The documents are rendered horizontally if that fits the
||| page. Otherwise they are aligned vertically. All separators are put
||| in front of the elements. For example, the combinator 'list' can be
||| defined with `encloseSep`:
|||
||| > list xs = encloseSep lbracket rbracket comma xs
||| > test    = text "list" |++| (list (map int [10,200,3000]))
|||
||| Which is layed out with a page width of 20 as:
|||
||| ``
||| list [10,200,3000]
||| ``
|||
||| But when the page width is 15, it is layed out as:
|||
||| ``
||| list [10
|||      ,200
|||      ,3000]
||| ``
public export
encloseSep : Doc -> Doc -> Doc -> List Doc -> Doc
encloseSep left right sep ds
    = case ds of
        []  => left `beside` right
        [d] => left `beside` (d `beside` right)
        _   => align (cat (zipWithStreamL (beside) (left :: repeat sep) ds) `beside` right)

||| The document `(list xs)` comma separates the documents `xs` and
||| encloses them in square brackets. The documents are rendered
||| horizontally if that fits the page. Otherwise they are aligned
||| vertically. All comma separators are put in front of the
||| elements.
public export
list : List Doc -> Doc
list            = encloseSep lbracket rbracket comma

||| The document `(tupled xs)` comma separates the documents `xs`
||| and encloses them in parenthesis. The documents are rendered
||| horizontally if that fits the page. Otherwise they are aligned
||| vertically. All comma separators are put in front of the
||| elements.
public export
tupled : List Doc -> Doc
tupled          = encloseSep lparen   rparen  comma

||| The document `(semiBraces xs)` separates the documents `xs` with
||| semicolons and encloses them in braces. The documents are
||| rendered horizontally if that fits the page. Otherwise they are
||| aligned vertically. All semi colons are put in front of the
||| elements.
public export
semiBraces : List Doc -> Doc
semiBraces      = encloseSep lbrace   rbrace  semi

-----------------------------------------------------------
-- punctuate p [d1,d2,...,dn] => [d1 |+| p,d2 |+| p, ... ,dn]
-----------------------------------------------------------

||| `(punctuate p xs)` concatenates all documents in `xs` with
||| document `p` except for the last document.
|||
||| ```
||| > someText = map text ["words","in","a","tuple"]
||| > test     = parens (align (cat (punctuate comma someText)))
||| ```
|||
||| This is layed out on a page width of 20 as:
|||
||| ```
||| (words,in,a,tuple)
||| ```
|||
||| But when the page width is 15, it is layed out as:
|||
||| ```
||| (words,
|||  in,
|||  a,
|||  tuple)
||| ```
|||
||| (If you want put the commas in front of their elements instead of
||| at the end, you should use `tupled` or, in general, `encloseSep`.)
public export
punctuate : Doc -> List Doc -> List Doc
punctuate _ []      = []
punctuate _ [d]     = [d]
punctuate p (d::ds)  = (d |+| p) :: punctuate p ds

-----------------------------------------------------------
-- Combinators for prelude types
-----------------------------------------------------------

private
string' : List Char -> Doc
string' []        = empty
string' ('\n'::s) = line |+| string' s
string' (c::s)    = char c |+| string' s

||| The document `(string s)` concatenates all characters in `s`
||| using `line` for newline characters and `char` for all other
||| characters. It is used instead of 'text' whenever the text contains
||| newline characters.
public export
string : String -> Doc
string str = string' (unpack str)

public export
bool : Bool -> Doc
bool b          = text (show b)

||| The document `(int i)` shows the literal integer `i` using
||| 'text'.
public export
int : Int -> Doc
int i           = text (show i)

||| The document `(integer i)` shows the literal integer `i` using
||| 'text'.
public export
integer : Integer -> Doc
integer i       = text (show i)

public export
nat : Nat -> Doc
nat n = text (show n)

||| The document `(double d)` shows the literal double `d` using
||| 'text'.
public export
double : Double -> Doc
double d        = text (show d)

{-
-- | The document @(rational r)@ shows the literal rational @r@ using
-- 'text'.
rational : Rational -> Doc
rational r      = text (show r)
-}

-----------------------------------------------------------
-- Useful instances
-----------------------------------------------------------

||| Note that this operator is not associative with respect to
||| propositional equality of the underlying Doc syntax tree, but
||| rather with respect to the equality of the result of rendering. So
||| it's "morally" a `Semigroup`.
public export
Semigroup Doc where
  (<+>) = beside

||| Note that the neutral element is not a left and right unit with
||| respect to propositional equality of the underlying Doc syntax
||| tree, but rather with respect to the equality of the result of
||| rendering. So it's "morally" a `Monoid`.
public export
Monoid Doc where
  neutral = empty

-----------------------------------------------------------
-- semi primitive: fill and fillBreak
-----------------------------------------------------------

public export
width : Doc -> (Nat -> Doc) -> Doc
width d f       = column (\k1 => d |+| column (\k2 => f (minus k2 k1)))

||| The document `(fillBreak i x)` first renders document `x`. It
||| than appends `space`s until the width is equal to `i`. If the
||| width of `x` is already larger than `i`, the nesting level is
||| increased by `i` and a `line` is appended. When we redefine `ptype`
||| in the previous example to use `fillBreak`, we get a useful
||| variation of the previous output:
|||
||| > ptype (name,tp)
||| >        = fillBreak 6 (text name) |++| text ":" |++| text tp
|||
||| The output will now be:
|||
||| `
||| let empty  : Doc
|||     nest   : Int -> Doc -> Doc
|||     linebreak
|||            : Doc
||| `
public export
fillBreak : Int -> Doc -> Doc
fillBreak f x   = width x (\w =>
                  if (cast w > f) then nest f linebreak
                                  else text "")

||| The document `(fill i x)` renders document `x`. It than appends
||| `space`s until the width is equal to `i`. If the width of `x` is
||| already larger, nothing is appended. This combinator is quite
||| useful in practice to output a list of bindings. The following
||| example demonstrates this.
|||
||| > types  = [("empty","Doc")
||| >          ,("nest","Int -> Doc -> Doc")
||| >          ,("linebreak","Doc")]
||| >
||| > ptype (name,tp)
||| >        = fill 6 (text name) |++| text ":" |++| text tp
||| >
||| > test   = text "let" |++| align (vcat (map ptype types))
|||
||| Which is layed out as:
|||
||| `
||| let empty  : Doc
|||     nest   : Int -> Doc -> Doc
|||     linebreak : Doc
||| `
public export
fill : Nat -> Doc -> Doc
fill f d        = width d (\w =>
                  if (w >= f) then empty
                              else text (spaces (minus f w)))

-----------------------------------------------------------
-- Renderers
-----------------------------------------------------------

private
fits : Nat -> SimpleDoc -> Bool
fits w SEmpty                   = True
fits Z (SChar _ x)              = False
fits w (SChar _ x)              = fits (minus w 1) x
fits Z (SText l _ x)            = False
fits w (SText l _ x)            = fits (minus w l) x
fits w (SLine _ _)              = True

-----------------------------------------------------------
-- renderPretty: the default pretty printing algorithm
-----------------------------------------------------------

||| This is the default pretty printer which is used by 'show',
||| 'putDoc' and 'hPutDoc'. `(renderPretty ribbonfrac width x)` renders
||| document `x` with a page width of `width` and a ribbon width of
||| `(ribbonfrac * width)` characters. The ribbon width is the maximal
||| amount of non-indentation characters on a line. The parameter
||| `ribbonfrac` should be between `0.0` and `1.0`. If it is lower or
||| higher, the ribbon width will be 0 or `width` respectively.
public export
renderPretty : Double -> Nat -> Doc -> SimpleDoc
renderPretty rfrac w x
    = assert_total $ best 0 0 (Cons 0 x Nil)
    where
     ||| the ribbon width in characters
     r : Nat
     r  = let rDouble = cast w * rfrac
              rNat = integerToNat (cast rDouble)
          in max 0 (min w rNat)

     --nicest : r = ribbon width, w = page width,
     --          n = indentation of current line, k = current column
     --          x and y, the (simple) documents to chose from.
     --          precondition: first lines of x are longer than the first lines of y.
     nicest : Nat -> Nat -> SimpleDoc -> SimpleDoc -> SimpleDoc
     nicest n k x y =
       let width = min (minus w k) ((minus r k) + n) in
       if fits width x then x else y

     -- best : n = indentation of current line
     --         k = current column
     --        (ie. (k >= n) && (k - n == count of inserted characters)
     covering
     best : Nat -> Nat -> Docs -> SimpleDoc
     best _ _ Nil      = SEmpty
     best n k (Cons i d ds)
       = case d of
           Empty       => best n k ds
           Char' c     => let k' = k+1 in SChar c (best n k' ds)
           Text l s    => let k' = k+l in SText l s (best n k' ds)
           Line _      => SLine i (best i i ds)
           Cat x y     => best n k (Cons i x (Cons i y ds))
           Nest j x    => let i' = integerToNat (cast (cast i + j)) in best n k (Cons i' x ds)
           Union x y   => nicest n k (best n k (Cons i x ds))
                                     (best n k (Cons i y ds))

           Column f    => best n k (Cons i (f k) ds)
           Nesting f   => best n k (Cons i (f (cast i)) ds)

-----------------------------------------------------------
-- renderCompact: renders documents without indentation
--  fast and fewer characters output, good for machines
-----------------------------------------------------------

||| `(renderCompact x)` renders document `x` without adding any
||| indentation. Since no 'pretty' printing is involved, this
||| renderer is very fast. The resulting output contains fewer
||| characters than a pretty printed version and can be used for output
||| that is read by other programs.
covering
renderCompact : Doc -> SimpleDoc
renderCompact x
    = scan 0 [x]
    where
      covering
      scan : Nat -> List Doc -> SimpleDoc
      scan _ []     = SEmpty
      scan k (d::ds) = case d of
                        Empty       => scan k ds
                        Char' c     => let k' = k+1 in SChar c (scan k' ds)
                        Text l s    => let k' = k+l in SText l s (scan k' ds)
                        Line _      => SLine 0 (scan 0 ds)
                        Cat x y     => scan k (x::y::ds)
                        Nest _ x    => scan k (x::ds)
                        Union _ y   => scan k (y::ds)
                        Column f    => scan k (f k::ds)
                        Nesting f   => scan k (f 0::ds)

-----------------------------------------------------------
-- Displayers:  displayS and displayIO
-----------------------------------------------------------

||| `(displayS simpleDoc)` takes the output `simpleDoc` from a
||| rendering function and transforms it to a 'ShowS' type (for use in
||| the 'Show' class).
|||
||| > showWidth : Nat -> Doc -> String
||| > showWidth w x   = displayS (renderPretty 0.4 w x) ""
public export
displayS : SimpleDoc -> String -> String
displayS SEmpty             = id
displayS (SChar c x)        = strCons c . displayS x
displayS (SText _ s x)      = (s ++) . displayS x
displayS (SLine i x)        = (('\n' `strCons` indentation i) ++) . displayS x

{-
-- | `(displayIO handle simpleDoc)` writes `simpleDoc` to the file
-- handle `handle`. This function is used for example by 'hPutDoc':
--
-- > hPutDoc handle doc  = displayIO handle (renderPretty 0.4 100 doc)
displayIO : Handle -> SimpleDoc -> IO ()
displayIO handle simpleDoc
    = display simpleDoc
    where
      display SEmpty        = return ()
      display (SChar c x)   = do{ hPutChar handle c; display x}
      display (SText _ s x) = do{ hPutStr handle s; display x}
      display (SLine i x)   = do{ hPutStr handle ('\n'::indentation i); display x}
-}

-----------------------------------------------------------
-- default pretty printers: show, putDoc and hPutDoc
-----------------------------------------------------------
public export
Show Doc where
  show doc       = displayS (renderPretty 0.4 80 doc) ""

{-
||| The action `(putDoc doc)` pretty prints document `doc` to the
||| standard output, with a page width of 100 characters and a ribbon
||| width of 40 characters.
|||
||| > main : IO ()
||| > main = do{ putDoc (text "hello" |++| text "world") }
|||
||| Which would output
|||
||| `
||| hello world
||| `
putDoc : Doc -> IO ()
putDoc doc              = hPutDoc stdout doc

||| `(hPutDoc handle doc)` pretty prints document `doc` to the file
||| handle `handle` with a page width of 100 characters and a ribbon
||| width of 40 characters.
|||
||| > main = do{ handle <- openFile "MyFile" WriteMode
||| >          ; hPutDoc handle (vcat (map text
||| >                            ["vertical","text"]))
||| >          ; hClose handle
||| >          }
hPutDoc : Handle -> Doc -> IO ()
hPutDoc handle doc      = displayIO handle (renderPretty 0.4 80 doc)
-}

 --  LocalWords:  PPrint combinators Wadler Wadler's encloseSep
-- -}


module StringLiteral

Str : String
Str = """
  First line

  Third line
  """

Str2NL : String
Str2NL = "First line\n\nThird line"

sss : Str === Str2NL
sss = Refl

Str1NL : String
Str1NL = "First line\nThird line"

sss' : (Str == Str1NL) === False
sss' = Refl


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

import WebAssembly.Structure.Types

import public WebAssembly.Structure.Modules.Indices
import public WebAssembly.Structure.Modules.Functions
import public WebAssembly.Structure.Modules.Tables
import public WebAssembly.Structure.Modules.Memories
import public WebAssembly.Structure.Modules.Globals
import public WebAssembly.Structure.Modules.ElementSegments
import public WebAssembly.Structure.Modules.DataSegments
import public WebAssembly.Structure.Modules.StartFunction
import public WebAssembly.Structure.Modules.Exports
import public WebAssembly.Structure.Modules.Imports

import Decidable.Equality

||| Spec: https://webassembly.github.io/spec/core/syntax/modules.html#modules
public export
record Module where
  constructor MkModule
  types    : List FuncType
  funcs    : List Func
  tables   : List Table
  mems     : List Mem
  globals  : List Global
  elem     : List Elem
  wdata    : List Data
  start    : Maybe Start
  imports  : List Import
  exports  : List Export

-- Equality

total public export
lemma_module__types_injective : ((ty1 = ty2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__types_injective ty1_not_ty2 Refl = ty1_not_ty2 Refl

total public export
lemma_module__funcs_injective : ((fu1 = fu2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__funcs_injective fu1_not_fu2 Refl = fu1_not_fu2 Refl

total public export
lemma_module__tables_injective : ((ta1 = ta2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__tables_injective ta1_not_ta2 Refl = ta1_not_ta2 Refl

total public export
lemma_module__mems_injective : ((me1 = me2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__mems_injective me1_not_me2 Refl = me1_not_me2 Refl

total public export
lemma_module__globals_injective : ((gl1 = gl2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__globals_injective gl1_not_gl2 Refl = gl1_not_gl2 Refl

total public export
lemma_module__elem_injective : ((el1 = el2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__elem_injective el1_not_el2 Refl = el1_not_el2 Refl

total public export
lemma_module__data_injective : ((da1 = da2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__data_injective da1_not_da2 Refl = da1_not_da2 Refl

total public export
lemma_module__start_injective : ((st1 = st2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__start_injective st1_not_st2 Refl = st1_not_st2 Refl

total public export
lemma_module__imports_injective : ((im1 = im2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__imports_injective im1_not_im2 Refl = im1_not_im2 Refl

total public export
lemma_module__exports_injective : ((ex1 = ex2) -> Void)
  -> ( MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1
     = MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
  -> Void
lemma_module__exports_injective ex1_not_ex2 Refl = ex1_not_ex2 Refl

-- Decidable Equality

public export
implementation DecEq Module where
  decEq (MkModule ty1 fu1 ta1 me1 gl1 el1 da1 st1 im1 ex1) (MkModule ty2 fu2 ta2 me2 gl2 el2 da2 st2 im2 ex2)
    = case decEq ty1 ty2 of
      No ty1_not_ty2 => No $ lemma_module__types_injective ty1_not_ty2
      Yes Refl       => case decEq fu1 fu2 of
        No fu1_not_fu2 => No $ lemma_module__funcs_injective fu1_not_fu2
        Yes Refl       => case decEq ta1 ta2 of
          No ta1_not_ta2 => No $ lemma_module__tables_injective ta1_not_ta2
          Yes Refl       => case decEq me1 me2 of
            No me1_not_me2 => No $ lemma_module__mems_injective me1_not_me2
            Yes Refl       => case decEq gl1 gl2 of
              No gl1_not_gl2 => No $ lemma_module__globals_injective gl1_not_gl2
              Yes Refl       => case decEq el1 el2 of
                No el1_not_el2 => No $ lemma_module__elem_injective el1_not_el2
                Yes Refl       => case decEq da1 da2 of
                  No da1_not_da2 => No $ lemma_module__data_injective da1_not_da2
                  Yes Refl       => case decEq st1 st2 of
                    No st1_not_st2 => No $ lemma_module__start_injective st1_not_st2
                    Yes Refl       => case decEq im1 im2 of
                      No im1_not_im2 => No $ lemma_module__imports_injective im1_not_im2
                      Yes Refl       => case decEq ex1 ex2 of
                        No ex1_not_ex2 => No $ lemma_module__exports_injective ex1_not_ex2
                        Yes Refl      => Yes Refl


module LightClick.IR.Channel.Normalise.Merge

import Data.List
import Data.Vect

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

import LightClick.Types
import LightClick.Terms

import LightClick.IR.ModuleCentric
import LightClick.IR.ChannelCentric
import LightClick.IR.Channel.Normalise.Error

%default total

data State = Empty | RepeatedName | UniqueNames (List String) | InlineModule

||| If the name has been seen return nothing, otherwise extend the state.
updateState : State -> String -> State
updateState Empty y = UniqueNames [y]
updateState RepeatedName y = RepeatedName
updateState (UniqueNames xs) y with (isElem y xs)
  updateState (UniqueNames xs) y | (Yes prf) = RepeatedName
  updateState (UniqueNames xs) y | (No contra) = UniqueNames (y::xs)

updateState InlineModule y = InlineModule

||| A ChannelIR specification is in module normal form if each CModuleInst has a unique type.
|||
||| Returns nothing if a name is repeated, other wise a list of unique names.
isModuleNF : (state : State)
          -> (expr  : ChannelIR type)
                   -> State
isModuleNF state (CLet n beThis inThis)
  = isModuleNF (isModuleNF state beThis) inThis

isModuleNF state (CSeq this thenThis)
  = isModuleNF (isModuleNF state this) thenThis

isModuleNF state (CModuleInst (CRef mname MODULE) xs)
  = updateState state mname

isModuleNF state (CModuleInst mname xs)  = InlineModule
isModuleNF state expr = state

||| Remove all instances of CModuleInst and merge them together.
mergeModules : (state : List (String, (ChannelIR MODULE, List (String, ChannelIR CHAN))))
            -> (expr  : ChannelIR type)
                     -> ChannelIR type
mergeModules state (CLet x y z)
  = CLet x (mergeModules state y) (mergeModules state z)
mergeModules state (CSeq (CModuleInst m@(CRef name MODULE) cs) y)
  = mergeModules ((name, (m,toList cs))::state) y

mergeModules state (CSeq x y) = CSeq x (mergeModules state y)

mergeModules state CEnd = rebuild CEnd (reduce Nil state)
  where
    rebuild : ChannelIR UNIT
           -> List (String, (ChannelIR MODULE, List (String, ChannelIR CHAN)))
           -> ChannelIR UNIT
    rebuild u Nil     = u
    rebuild u ((_,(m,Nil))::xs) = (rebuild u xs) -- shouldn't happen
    rebuild u ((_,(m,c::cs))::xs) = CSeq (CModuleInst m (c::(fromList cs))) (rebuild u xs)

    action : String
          -> ChannelIR MODULE
          -> List (String, ChannelIR CHAN)
          -> List (String, (ChannelIR MODULE, List (String, ChannelIR CHAN)))
          -> List (String, (ChannelIR MODULE, List (String, ChannelIR CHAN)))
    action k inst cs Nil                          = [(k,(inst,cs))]
    action k inst cs ((name, (inst', cs')) :: rest) with (decEq k name)
      action k inst cs ((k, (inst', cs')) :: rest) | (Yes Refl)
        = (k, (inst', cs ++ cs')) :: rest
      action k inst cs ((name, (inst', cs')) :: rest) | (No contra)
        = (name, (inst', cs')) :: (action k inst cs rest)

    reduce : List (String, (ChannelIR MODULE, List (String, ChannelIR CHAN))) -- turn into map
          -> List (String, (ChannelIR MODULE, List (String, ChannelIR CHAN)))
          -> List (String, (ChannelIR MODULE, List (String, ChannelIR CHAN)))
    reduce new Nil = new
    reduce new ((k,(inst, cs))::xs) = reduce (action k inst cs new) xs

mergeModules state expr = expr

export
covering
runMerge : ChannelIR type -> Either Normalise.Error (ChannelIR type)
runMerge expr =
  case isModuleNF Empty expr of
    Empty => Left (NoModuleInstances)
    InlineModule => Left (ModuleInlined)
    RepeatedName => runMerge (mergeModules Nil expr)
    UniqueNames _ => Right expr

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


-- Module      : Itea.Html
-- Description :
-- Copyright   : (c) Simon Nielsen Knights 2018
-- License     : MIT
-- Maintainer  : simonank@mail.ru
-- Stability   : unstable
-- Portability : portable

module Itea.Html
import Itea.Html.Attributes
import Itea.Html.Events

import Control.Monad.Reader
import Control.Monad.Identity

%default total
%access public export

-- Types -----------------------------------------------------------------------

||| HTML element type representing the structure of the DOM tree
data HTML : Type -> Type where
  ||| Tag element
  ||| @tagname node tag
  ||| @events list of events assigned to the tag
  ||| @attributes tag attributes such as class, href, rel
  ||| @html child nodes in the DOM tree
  HtmlElem : (tagname    : String)
          -> (events     : List (Event a))
          -> (attributes : List Attribute)
          -> (html       : List (HTML a))
          -> HTML a
  ||| Text element
  ||| @text raw text
  HtmlText : (text : String) -> HTML a

||| HTML monad for implictly passing the event queue around
Html : Type -> Type
Html a = Reader (EventQueue a) (HTML a)

-- Element ---------------------------------------------------------------------

||| Create a static element with given attributes
staticElement : String -> List Attribute -> List (Html a) -> Html a
staticElement name attr html =
  let html = map (runIdentity . flip runReaderT !ask) html in
  pure $ HtmlElem name [] attr html

||| Create an interactive element with given listeners
|||
||| @name name of element
||| @handlers list of handlers taking the event queue as input
||| @attr element attributes
||| @ok implicit proos ensuring given handler list is non empty
interactiveElement : (name     : String)
                  -> (handlers : List (EventQueue a -> Event a))
                  -> (attr     : List Attribute)
                  -> { auto ok : NonEmpty handlers }
                  -> Html a
interactiveElement name events attr =
  pure $ HtmlElem name (map (flip apply !ask) events) attr []

-- Tags ------------------------------------------------------------------------

||| Construct a text element
text : String -> Html a
text = pure . HtmlText

div : List Attribute -> List (Html a) -> Html a
div = staticElement "div"

body : List Attribute -> List (Html a) -> Html a
body = staticElement "body"

nav : List Attribute -> List (Html a) -> Html a
nav = staticElement "nav"

article : List Attribute -> List (Html a) -> Html a
article = staticElement "article"

aside : List Attribute -> List (Html a) -> Html a
aside = staticElement "aside"

h1 : List Attribute -> List (Html a) -> Html a
h1 = staticElement "h1"

h2 : List Attribute -> List (Html a) -> Html a
h2 = staticElement "h2"

h3 : List Attribute -> List (Html a) -> Html a
h3 = staticElement "h3"

h4 : List Attribute -> List (Html a) -> Html a
h4 = staticElement "h4"

h5 : List Attribute -> List (Html a) -> Html a
h5 = staticElement "h5"

h6 : List Attribute -> List (Html a) -> Html a
h6 = staticElement "h6"

br : Html a
br = staticElement "br" [] []

tr : List Attribute -> List (Html a) -> Html a
tr = staticElement "tr"

table : List Attribute -> List (Html a) -> Html a
table = staticElement "table"

td : List Attribute -> List (Html a) -> Html a
td = staticElement "td"

tbody : List Attribute -> List (Html a) -> Html a
tbody = staticElement "tbody"

thead : List Attribute -> List (Html a) -> Html a
thead = staticElement "thead"

tfoot : List Attribute -> List (Html a) -> Html a
tfoot = staticElement "tfoot"

th : List Attribute -> List (Html a) -> Html a
th = staticElement "th"

||| Image object
record Image where
  constructor MkImage
  ||| Relative link
  rel    : String
  ||| Width of image
  width  : Dimension
  ||| Height of image
  height : Dimension

img : List Attribute -> Html a
img = flip (staticElement "img") []

namespace Simple

  ||| Simple interface working with images directly
  img : List Attribute -> Image -> Html a
  img attr (MkImage rel' width' height') =
    img $ [ width width'
          , height height'
          , rel rel'
          ] ++ attr

p : List Attribute -> List (Html a) -> Html a
p = staticElement "p"

code : List Attribute -> List (Html a) -> Html a
code = staticElement "code"

strong : List Attribute -> List (Html a) -> Html a
strong = staticElement "strong"

{-
header
footer
address
main
hr
pre
blockquote
ol
ul
li
dl
dd
figure
figcaption
a
em
small
s
cite
q
abbr
time
var
samp
kbd
sup
i
u
matk
ruby
rt
rp
bdi
bdo
span
ins
del
iframe
embed
object
param
video
audio
source
track
canvas
math
caption
colgroup
col
form
fieldset
legend
label
select
datalist
optgroup
option
textarea
keygen
output
progress
meter
details
summary
menuitem
menu
-}

||| Interactive button
|||
||| @xs list of listeners along with their return messages
||| @attr button attributes
||| @ok proof of the input list having at least one element
button : (xs   : List (EventQueue a -> Event a))
      -> (attr : List Attribute)
      -> { auto ok : NonEmpty xs }
      -> Html a
button = interactiveElement "button"

||| Interactive input
|||
||| @xs list of listeners along with their return messages
||| @attr input attributes
||| @ok proof of the input list having at least one element
input : (xs   : List (EventQueue a -> Event a))
     -> (attr : List Attribute)
     -> { auto ok : NonEmpty xs }
     -> Html a
input = interactiveElement "input"


module Flexidisc.Record.Type

import        Flexidisc.RecordContent
import public Flexidisc.THList

import public Flexidisc.Dec.IsYes
import public Flexidisc.Header
import public Flexidisc.TaggedValue

%default total
%access export

-- CREATE

||| A `RecordM` is a set of rows
||| @ m      A Type constructor used to decorate all values of the record
||| @ k      The type of the labels
||| @ header The list of rows into the record, with their types
public export
data RecordM : (m : Type -> Type) -> (k : Type) -> (header : Header k) -> Type where
  Rec : (o : Ord k) =>
        (values : RecordContentM m k o header) -> (nubProof : Nub header) ->
        RecordM m k (H header)

public export
Record : (k : Type) -> (header : Header k) -> Type
Record = RecordM id

infix 6 :::

||| Convenient helper for row type readability
public export
(:::) : (k : l) -> (v : Type) -> Pair l Type
(:::) = MkPair

%name Record xs, ys, zs

||| The empty record
public export
Nil : Ord k => RecordM m k []
Nil = Rec empty []

||| Insert a new row in a record (with explicit proof)
public export
cons' : (DecEq k, Ord k) => TaggedValue k' (m ty) -> RecordM m k header ->
        (fresh : Fresh k' header) ->
        RecordM m k ((k', ty) :: header)
cons' x (Rec xs isnub) (F fresh) =
  Rec (insert x xs) (freshInsert fresh isnub)

||| Insert a new row in a record
public export
cons : (DecEq k, Ord k) => TaggedValue k' (m ty) -> RecordM m k header ->
       {default SoTrue fresh : IsFresh k' header} ->
       RecordM m k ((k', ty) :: header)
cons x xs {fresh} = cons' x xs (getProof fresh)

||| Insert a new row in a record
public export
(::) : (DecEq k, Ord k) => TaggedValue k' (m ty) -> RecordM m k header ->
       {default SoTrue fresh : IsFresh k' header} ->
       RecordM m k ((k', ty) :: header)
(::) = cons

||| Decide whether a record can be extended with the proposed key/value pair or not
public export
decCons : (DecEq k, Ord k) =>
          TaggedValue k' (m ty) -> RecordM m k header ->
          Dec (RecordM m k ((k', ty) :: header))
decCons x (Rec xs _) {k'} {ty} {header = H hs} with (decNub (insert (k', ty) hs))
  | (Yes prf) = Yes (Rec (insert x xs) prf)
  | (No contra) = No (cantBuildARecordWithNonNubHeader contra)
  where
    cantBuildARecordWithNonNubHeader : (DecEq k, o : Ord k) =>
                                       {hs : OrdHeader k o} ->
                                       (contra : Nub hs -> Void) -> Not (RecordM m k (H hs))
    cantBuildARecordWithNonNubHeader contra (Rec xs prf) = contra prf

||| It's just monomorphic `id` with a fancy name, to help type inference
recM : (m : Type -> Type) -> RecordM m k header -> RecordM m k header
recM _ = id

||| It's just monomorphic `id` with a fancy name, to help type inference
rec : Record k header -> Record k header
rec = id

namespace test
  %access private

  test_rec1 : Record String ["Firstname" ::: String]
  test_rec1 = ["Firstname" := "John"]

  test_rec2 : Record String ["Lastname" ::: String, "Firstname" ::: String]
  test_rec2 = ["Firstname" := "John", "Lastname" := "Doe"]


%default total

data Ty = Ctor Int

fn : Ty -> Ty
fn m@(Ctor _) = y
  where
    y = m -- from @ pattern

asPatternVisibleInWhere : fn (Ctor 42) = Ctor 42
asPatternVisibleInWhere = Refl

fn2 : Ty -> Ty
fn2 m@(Ctor _) = y (Ctor 99)
  where
    y m = m -- should be the arg `m`, not the @ pattern

lhsVariablesShadowAsPattern : fn2 (Ctor 42) = Ctor 99
lhsVariablesShadowAsPattern = Refl

fn3 : Ty -> Ty
fn3 m@(Ctor _) = y (Ctor 99)
  where
    y m = z
      where
        z = m -- should be y's arg `m`, not @ pattern

nestedWhereShadowsAsPattern : fn3 (Ctor 42) = Ctor 99
nestedWhereShadowsAsPattern = Refl

fn4 : Ty -> Ty
fn4 m@(Ctor _) = y (Ctor 99)
  where
    y _ = z
      where
        z = m -- should be @ pattern

nestedWhereExposesAsPattern : fn4 (Ctor 42) = Ctor 42
nestedWhereExposesAsPattern = Refl

main : IO ()
main = putStrLn "OK"


module Elab.Elaboration

import Elab.Common
import Typing.TypeChecking
import Typing.Util

-- 8YYYY 8o  0 oYYYo 0   0 8YYYo 8YYYY      _YYY_ oYYYo    0   0  o8o  0    Y8Y 8888_
-- 8___  8Yo 8 %___  0   0 8___P 8___  ____ 0   0 %___     0   0 8   8 0     0  0   0
-- 8"""  8 Yo8 `"""p 0   0 8""Yo 8"""  """" 0   0 `"""p    "o o" 8YYY8 0     0  0   0
-- 8oooo 0   8 YoooY "ooo" 0   0 8oooo      "ooo" YoooY     "8"  0   0 8ooo o8o 8oooY

ensureOpenSettingsAreValid : List OpenSettings -> Elaborator ()
ensureOpenSettingsAreValid oss = for_ oss ensure
where
	ensureModuleExists : String -> Elaborator ()
	ensureModuleExists m = do
		ms <- moduleNames
		unless (m `elem` ms)
			$ throw $ "The module " ++ m ++ " is not a known module."

	openAsIsValid : Maybe String -> Elaborator ()
	openAsIsValid Nothing = pure ()
	openAsIsValid (Just m') = do
		ms <- moduleNames
		unless (not (m' `elem` ms))
			$ throw $ "The module name " ++ m' ++ " is already in use."

	hidingUsingIsValid : String -> Maybe HidingUsing -> Elaborator ()
	hidingUsingIsValid _ Nothing = pure ()
	hidingUsingIsValid m (Just hu') = do
		defs <- definitions
		sig <- signature
		let ns = nub (case hu' of { Hiding ns' => ns' ; Using ns' => ns' })
		let known = nub ([ n | ((_,n),_,_) <- toList defs ] ++ [ n | ((_,n),_) <- toList sig ])
		let missing = ns \\ known
		unless (isNil missing)
			$ throw $ "The module " ++ m ++ " does not declare these symbols: "
							++ unwords missing

	showLR : String \/ FullName -> String
	showLR (Left n0) = n0
	showLR (Right (m0,n0)) = m0 ++ "." ++ n0

	renamingIsValid : String -> Maybe String -> Maybe HidingUsing -> List FullName -> Elaborator ()
	renamingIsValid m a hu r = do
		defs <- definitions
		sig <- signature
		let ns = nub [ n | (n,_) <- r ]
		let known = nub ([ n | ((m',n),_,_) <- toList defs, m' == m ]
					++ [ n | ((m',n),_) <- toList sig, m' == m ])
		let missing = ns \\ known
		unless (isNil missing) $ throw $ "The module " ++ m ++ " does not declare these symbols: "
			++ unwords ns
		let knownBeingUsed = case hu of
			Nothing => known
			Just (Using used) => used
			Just (Hiding hidden) => known \\ hidden
		let missingUsed = ns \\ knownBeingUsed
		unless (isNil missingUsed)
			$ throw $ "The following symbols are not being opened: " ++ unwords missingUsed
		let ns' = [ n' | (_,n') <- r ]
		let preserved = known \\ ns
		let overlappingNames = [ x | (x :: xs) <- groupBy (==) (sort (ns' ++ preserved)), length xs /= 0 ]
		unless (isNil overlappingNames)
			$ throw $ "These symbols will be overlapping when the module " ++ m
				++ " is opened: " ++ unwords overlappingNames
		als <- aliases
		let combine = the (String -> String \/ FullName) $ case a of
			Nothing => Left
			Just m' => \n' => Right (m', n')
		let mns' = nub [ combine n' | (_,n') <- r ]
		let knownAls = nub [ al | (al,_) <- als ]
		let overlap = intersect mns' knownAls

		unless (isNil overlap) $ throw $ "These symbols are already in scope: "
			++ unwords (map showLR overlap)

	ensure : OpenSettings -> Elaborator ()
	ensure (NewOpenSettings m a hu r) = do
		ensureModuleExists m
		openAsIsValid a
		hidingUsingIsValid m hu
		renamingIsValid m a hu r

-- 8o  0 8YYYY 0     0  o8o  0    Y8Y  o8o  oYYYo 8YYYY oYYYo
-- 8Yo 8 8___  0  0  0 8   8 0     0  8   8 %___  8___  %___
-- 8 Yo8 8"""  8 _8_ 8 8YYY8 0     0  8YYY8 `"""p 8"""  `"""p
-- 0   8 8oooo "8* *8" 0   0 8ooo o8o 0   0 YoooY 8oooo YoooY

newAliases : Signature Term -> Definitions -> List OpenSettings -> ModuleAliases
newAliases _ _ [] = []
newAliases sig defs (os::oss) = do
	let als  = newAliasesFromSettings os
	let als' = newAliases sig defs oss
	als' ++ als
where
	used : Maybe HidingUsing -> List FullName -> List FullName
	used Nothing            = id
	used (Just (Hiding ns)) = filter (\(_,n) => not (n `elem` ns))
	used (Just (Using ns))  = filter (\(_,n) => (n `elem` ns))

	renamed : List FullName -> List FullName -> List (String >< FullName)
	renamed r mns = [ (maybe n id (lookup n r), (m,n)) | (m,n) <- mns ]

	ased : Maybe String -> List (String >< FullName) ->
		List ((String \/ FullName) >< FullName)
	ased Nothing   ns = [ (Left x, (m,n)) | (x,(m,n)) <- ns ]
	ased (Just m') ns = [ (Right (m',x), (m,n)) | (x,(m,n)) <- ns ]

	newAliasesFromSettings : OpenSettings -> ModuleAliases
	newAliasesFromSettings (NewOpenSettings m a hu r) = do
		let openedSymbols = [ (m',c) | ((m',c),_) <- toList sig, m' == m ]
							++ [ (m',x) | ((m',x),_,_) <- toList defs, m' == m ]
		let usedSymbols = used hu openedSymbols
		let renamedSymbols = renamed r usedSymbols
		ased a renamedSymbols

extendAliases : List OpenSettings -> Elaborator a -> Elaborator a
extendAliases settings tc = do
	ensureOpenSettingsAreValid settings
	als <- aliases
	sig <- signature
	defs <- definitions
	let newAls = newAliases sig defs settings ++ als
	putAliases newAls
	x <- tc
	putAliases als
	pure x

-- 8888. 0   0 Y8Y 0    8888_ 0     o8o  8_   _8 8888. 8888_  o8o
-- 8___Y 0   0  0  0    0   0 0    8   8 8"o_o"8 8___Y 0   0 8   8
-- 8"""o 0   0  0  0    0   0 0    8YYY8 0  8  0 8"""o 0   0 8YYY8
-- 8ooo" "ooo" o8o 8ooo 8oooY 8ooo 0   0 0     0 8ooo" 8oooY 0   0

buildLambda : (List Term -> Term) -> List Plict -> Term
buildLambda f [] = f []
buildLambda f (plic :: plics) = Lam plic $
	NewScope ["_" ++ show (length plics)] $ \[x] => buildLambda (f . (x ::)) plics

-- 8YYYY 0     o8o  8888. YY8YY 8YYYY 8YYYo 8_   _8 8888_ 8YYYY  oYYo 0
-- 8___  0    8   8 8___Y   0   8___  8___P 8"o_o"8 0   0 8___  0   " 0
-- 8"""  0    8YYY8 8"""o   0   8"""  8""Yo 0  8  0 0   0 8"""  0   , 0
-- 8oooo 8ooo 0   0 8ooo"   0   8oooo 0   0 0     0 8oooY 8oooo  YooY 8ooo

export elabTermDecl : TermDeclaration -> Elaborator ()

--         oYYYo Y8Y 8_   _8 8YYYo 0    8YYYY
-- ____    %___   0  8"o_o"8 8___P 0    8___
-- """"    `"""p  0  0  8  0 8"""  0    8"""
--         YoooY o8o 0     0 0     8ooo 8oooo

elabTermDecl (SimpleTermDef n ty def) = do
	when' (typeInDefinitions n) $ throw ("Term already defined: " ++ n)
	ty' <- liftTC (check ty Star)
	m <- moduleName
	addAlias n
	def' <- liftTC (extendDefinitions (insert (m,n) (def,ty') empty) (check def ty'))
	addDeclaration n def' ty'

--         8YYYo  o8o  YY8YY YY8YY 8YYYY 8YYYo 8o  0
-- ____    8___P 8   8   0     0   8___  8___P 8Yo 8
-- """"    8"""  8YYY8   0     0   8"""  8""Yo 8 Yo8
--         0     0   0   0     0   8oooo 0   0 0   8

elabTermDecl decl@(PatternTermDef n ty preclauses) = go n ty preclauses
where
	isVarPat : Pattern -> Bool
	isVarPat (VarPat _) = True
	isVarPat _ = False

	truePlicities : List Plict -> Term -> Maybe (List (Plict \/ Plict))
	truePlicities [] _ = Just []
	truePlicities (Expl::plics) (Pi Expl _ sc) = do
		rest <- truePlicities plics (descope (Var . Name) sc)
		pure $ Right Expl :: rest
	truePlicities (Expl::plics) (Pi Impl _ sc) = do
		rest <- truePlicities (Expl :: plics) (descope (Var . Name) sc)
		pure $ Left Impl :: rest
	truePlicities (Impl :: _) (Pi Expl _ _) = Nothing
	truePlicities (Impl :: plics) (Pi Impl _ sc) = do
		rest <- truePlicities plics (descope (Var . Name) sc)
		pure $ Right Impl :: rest

	motiveAux : Int -> Term -> CaseMotive
	motiveAux 0 t = CaseMotiveNil t
	motiveAux i (Pi _ a (NewScope ns b)) = CaseMotiveCons a $ NewScope ns (motiveAux (i - 1) . b)

	truePatterns : List (Plict \/ Plict) -> List Pattern -> List Pattern
	truePatterns [] [] = []
	truePatterns (Right _ :: plics) (p :: ps) = p :: truePatterns plics ps
	truePatterns (Left _ :: plics) ps = MakeMeta :: truePatterns plics ps

	go : String -> Term -> (List ClauseDeclT) -> Elaborator ()
	go n ty [] = throw "Cannot create an empty let-where definition."
	go n ty [(plics,(ps,xs,b))] with (all isVarPat ps)
		| True = elabTermDecl $ SimpleTermDef n ty (helperFold (uncurry lamHelper) (zip plics xs) b)
	go n ty preclauses@((_,(ps0,_,_)) :: _) = do
		let lps0 = length ps0
		unless (all (\(_,(ps,_,_)) => length ps == lps0) preclauses)
			$ throw "Mismatching number of patterns in different clauses of a pattern matching function."
		let (plics :: plicss) = map fst preclauses
		unless (all (plics ==) plicss)
			$ throw "Mismatching plicities in different clauses of a pattern matching function"
		case truePlicities plics ty of
			Nothing => throw $ "Cannot build a case expression motive from the type " ++ show ty
			Just truePlics => do
				let mot = motiveAux (cast $ length truePlics) ty
				let clauses = [ clauseHelper (truePatterns truePlics ps) xs b | (_,(ps,xs,b)) <- preclauses ]
				let plicsForLambdaAux = map (either id id) truePlics
				elabTermDecl $ SimpleTermDef n ty $
					buildLambda (\as => Case as mot clauses) plicsForLambdaAux

--         _YYY_ 8YYYo 8YYYY 8o  0
-- ____    0   0 8___P 8___  8Yo 8
-- """"    0   0 8"""  8"""  8 Yo8
--         "ooo" 0     8oooo 0   8

elabTermDecl (OpenTermDef n args ty) = do
	when' (typeInDefinitions n) $ throw ("Term already defined: " ++ n)
	let (ty,plics,mot) = convertArgs args
	ty' <- liftTC (checkify ty Star)
	mot' <- liftTC (checkifyCaseMotive mot)
	m <- moduleName
	fs <- openFunctions
	case lookup (m,n) fs of
		Nothing => do
				putOpenFunctions $ insert (m,n) (ty',plics,mot',[]) $ fs
				let initialDef = buildLambda (\xs => Case xs mot' []) plics
				addAlias n
				initialDef' <- liftTC $
					extendDefinitions (insert (m,n) (initialDef,ty') empty) (check initialDef ty')
				addDeclaration n initialDef' ty
		Just _ => throw $ "The open function " ++ show (DottedVar m n) ++ " has already been declared."
where
	convertArgs : List DeclArg -> (Term >< List Plict >< CaseMotive)
	convertArgs [] = (ty, [], CaseMotiveNil ty)
	convertArgs (NewDeclArg plic x t :: as) = do
		let (b, plics, mot) = convertArgs as
		(piHelper plic x t b, plic :: plics, consMotiveHelper x t mot)

--         Y8Y 8o  0 oYYYo YY8YY 8o  0  o8o   oYYo 8YYYY
-- ____     0  8Yo 8 %___    0   8Yo 8 8   8 0   " 8___
-- """"     0  8 Yo8 `"""p   0   8 Yo8 8YYY8 0   , 8"""
--         o8o 0   8 YoooY   0   0   8 0   0  YooY 8oooo

elabTermDecl (InstTermDef n preclauses) = do
	let aliasedName = the Term $ case n of
		Left n0 => Var (Name n0)
		Right (m0,n0) => DottedVar m0 n0
	(m',n') <- liftTC $ unalias n
	fs <- openFunctions
	Just (ty,plics,mot,clauses) <- pure $ lookup (m',n') fs
		| _ => throw ("No open function named " ++ show aliasedName ++ " has been declared.")

	clauses' <- Traversable.for preclauses $ \(plics',(ps,xs,b)) => do
		case insertMetas plics plics' of
			Nothing => throw $ "Instance for open function " ++ show aliasedName ++
				" has invalid argument plicities."
			Just bs => pure $ clauseHelper (truePatterns bs ps) xs b
	let newClauses = clauses ++ clauses'
	let newDef = buildLambda (\xs => Case xs mot newClauses) plics
	let newOpenFunctions = insert (m',n') (ty,plics,mot,newClauses) $
		fromList $ filter (\(p,_) => p /= (m',n')) $ toList fs
	newDef' <- liftTC $ extendDefinitions (insert (m',n') (newDef, ty) empty) (check newDef ty)
	putOpenFunctions newOpenFunctions
	defs <- definitions
	putDefinitions $ insert (m', n') (newDef', ty) $
		fromList $ filter (\(p,_,_) => p /= (m',n')) (toList defs)
where
	insertMetas : List Plict -> List Plict -> Maybe (List Bool)
	insertMetas [] [] = Just []
	insertMetas (Expl :: args) (Expl :: plics) = do
		rest <- insertMetas args plics
		pure $ False :: rest
	insertMetas (Expl :: _) (Impl :: _) = Nothing
	insertMetas (Impl :: args) (Expl :: plics) = do
		rest <- insertMetas args plics
		pure $ True :: rest
	insertMetas (Impl :: args) (Impl :: plics) = do
		rest <- insertMetas args plics
		pure $ False :: rest
	insertMetas _ _ = Nothing

	truePatterns : List Bool -> List Pattern -> List Pattern
	truePatterns [] [] = []
	truePatterns (False :: plics) (p :: ps) = p :: truePatterns plics ps
	truePatterns (True :: plics) ps = MakeMeta :: truePatterns plics ps

--          oYYo 0    _YYY_ oYYYo 8YYYY
-- ____    0   " 0    0   0 %___  8___
-- """"    0   , 0    0   0 `"""p 8"""
--          YooY 8ooo "ooo" YoooY 8oooo

elabTermDecl (CloseTermDef n) = do
	let aliasedName = the Term $ case n of
		Left n0 => Var (Name n0)
		Right (m0,n0) => DottedVar m0 n0
	(m',n') <- liftTC $ unalias n
	fs <- openFunctions
	Just (ty,plics,mot,clauses) <- pure $ lookup (m',n') fs
		| _ => throw ("Open function " ++ show aliasedName ++ " is not defined.")
	putOpenFunctions $ fromList $ filter (\(p,_) => p /= (m',n')) $ toList fs

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

validConSig : Constructor -> Constructor -> ConSig Term -> Elaborator ()
validConSig tycon c (ConSigNil (Con tc _)) = unless (tc == tycon) $
	throw $ "The constructor " ++ show c ++ " should constructor a value of the type " ++ show tycon
		++ " but instead produces a " ++ show tc
validConSig tycon c (ConSigNil a) = throw $
	"The constructor " ++ show c ++ " should constructor a value of the type " ++ show tycon
			++ " but instead produces " ++ show a
validConSig tycon c (ConSigCons _ _ sc) = validConSig tycon c (descope (Var . Name) sc)

-- 8YYYY 0     o8o  8888.  o8o  0    YY8YY
-- 8___  0    8   8 8___Y 8   8 0      0
-- 8"""  0    8YYY8 8"""o 8YYY8 0      0
-- 8oooo 8ooo 0   0 8ooo" 0   0 8ooo   0

elabAlt : String -> String -> ConSig Term -> Elaborator ()
elabAlt tycon c consig = do
	validConSig (BareCon tycon) (BareCon c) consig
	when' (typeInSignature (BareCon c))
		$ throw ("Constructor already declared: " ++ c)
	addAlias c
	consig' <- liftTC (checkifyConSig consig)
	addConstructor c consig'

-- 8YYYY 0     o8o  8888. Y8Y 8o  0 oYYYo YY8YY  o8o  8o  0  oYYo 8YYYY  o8o  0    YY8YY
-- 8___  0    8   8 8___Y  0  8Yo 8 %___    0   8   8 8Yo 8 0   " 8___  8   8 0      0
-- 8"""  0    8YYY8 8"""o  0  8 Yo8 `"""p   0   8YYY8 8 Yo8 0   , 8"""  8YYY8 0      0
-- 8oooo 8ooo 0   0 8ooo" o8o 0   8 YoooY   0   0   0 0   8  YooY 8oooo 0   0 8ooo   0

elabInstanceAlt : String -> Constructor -> String -> ConSig Term -> Elaborator ()
elabInstanceAlt m localTycon c consig = do
	validConSig localTycon (BareCon c) consig
	sig <- signature
	case lookup (m,c) sig of
		Just _ => throw ("Constructor already declared: " ++ c)
		Nothing => do
			addAliasFor (Left c) (m,c)
			consig' <- liftTC (checkifyConSig consig)
			addConstructorToModule m c consig'

-- 8YYYY 0     o8o  8888. YY8YY 0   0 8YYYo 8YYYY 8888_ 8YYYY  oYYo 0
-- 8___  0    8   8 8___Y   0   "o o" 8___P 8___  0   0 8___  0   " 0
-- 8"""  0    8YYY8 8"""o   0     0   8"""  8"""  0   0 8"""  0   , 0
-- 8oooo 8ooo 0   0 8ooo"   0     0   0     8oooo 8oooY 8oooo  YooY 8ooo

export elabTypeDecl : TypeDeclaration -> Elaborator ()

--         Y8Y 8o  0 8888_ 0   0  oYYo YY8YY Y8Y 0   0 8YYYY
-- ____     0  8Yo 8 0   0 0   0 0   "   0    0  0   0 8___
-- """"     0  8 Yo8 0   0 0   0 0   ,   0    0  "o o" 8"""
--         o8o 0   8 8oooY "ooo"  YooY   0   o8o  "8"  8oooo

elabTypeDecl (Inductive tycon tyconargs alts) = do
	let tyconSig = conSigHelper tyconargs Star
	when' (typeInSignature (BareCon tycon))
		$ throw ("Type constructor already declared: " ++ tycon)
	addAlias tycon
	tyconSig' <- liftTC (checkifyConSig tyconSig)
	addConstructor tycon tyconSig'
	traverse_ (uncurry (elabAlt tycon)) alts

--         8888_  o8o  YY8YY  o8o  8YYYY  o8o  8_   _8 Y8Y 0    0   0
-- ____    0   0 8   8   0   8   8 8___  8   8 8"o_o"8  0  0    "o o"
-- """"    0   0 8YYY8   0   8YYY8 8"""  8YYY8 0  8  0  0  0      0
--         8oooY 0   0   0   0   0 0     0   0 0     0 o8o 8ooo   0

elabTypeDecl (DataFamily tycon tyconargs) = do
	let tyconSig = conSigHelper tyconargs Star
	when' (typeInSignature (BareCon tycon))
		$ throw ("Type constructor already declared: " ++ tycon)
	addAlias tycon
	tyconSig' <- liftTC (checkifyConSig tyconSig)
	addConstructor tycon tyconSig'
	m <- moduleName
	od <- openData
	putOpenData ((m,tycon) :: od)

--         8888_  o8o  YY8YY  o8o  Y8Y 8o  0 oYYYo YY8YY  o8o  8o  0  oYYo 8YYYY
-- ____    0   0 8   8   0   8   8  0  8Yo 8 %___    0   8   8 8Yo 8 0   " 8___
-- """"    0   0 8YYY8   0   8YYY8  0  8 Yo8 `"""p   0   8YYY8 8 Yo8 0   , 8"""
--         8oooY 0   0   0   0   0 o8o 0   8 YoooY   0   0   0 0   8  YooY 8oooo

elabTypeDecl (DataInstance tycon alts) = do
	let aliasedName = case tycon of
						BareCon c => Left c
						DottedCon m c => Right (m,c)
	(m',c') <- liftTC $ unalias aliasedName
	od <- openData
	unless ((m',c') `elem` od)
		$ throw $ "The constructor " ++ show tycon ++ " is not an open data type."
	traverse_ (uncurry (elabInstanceAlt m' tycon)) alts

-- 8YYYY 0     o8o  8888. 8_   _8 _YYY_ 8888_ 0   0 0    8YYYY
-- 8___  0    8   8 8___Y 8"o_o"8 0   0 0   0 0   0 0    8___
-- 8"""  0    8YYY8 8"""o 0  8  0 0   0 0   0 0   0 0    8"""
-- 8oooo 8ooo 0   0 8ooo" 0     0 "ooo" 8oooY "ooo" 8ooo 8oooo

export elabModule : Module -> Elaborator ()
elabModule (NewModule m settings stmts0) = do
	addModuleName m
	putModuleName m
	ensureOpenSettingsAreValid settings
	als <- aliases
	sig <- signature
	defs <- definitions
	let newAls = newAliases sig defs settings ++ als
	putAliases newAls
	go stmts0
	putAliases als
where
	go : List Statement -> Elaborator ()
	go [] = pure ()
	go (TyDecl td :: stmts) = do
		elabTypeDecl td
		go stmts
	go (TmDecl td :: stmts) = do
		elabTermDecl td
		go stmts


module Erlang.Conversion

import Erlang.Types

%default total

-- UNSAFE CONVERSIONS

-- ErlType a -> ErlType b

||| Cast a value from one type to another. (Caution: Wrong usage of this
||| function may result in run-time errors.)
|||
||| Both the target type and the type of the given value must be a member of `ErlType`.
|||
||| `erlUnsafeCast` should only be used when you are sure the casting is safe.
||| In the common case, you should probably use the functions from `Erlang.Decode`.
export
erlUnsafeCast : ErlType from => (0 to : Type) -> ErlType to => from -> to
erlUnsafeCast to term = believe_me term

-- SAFE CONVERSIONS

-- ErlType a -> ErlTerm
-- (Allow all supported Erlang types to be type erased)

export
ErlType a => Cast a ErlTerm where
  cast x = believe_me x

-- Unit <-> ErlTuple0

export
Cast () ErlTuple0 where
  cast MkUnit = MkTuple0

export
Cast ErlTuple0 () where
  cast MkTuple0 = MkUnit

-- Bool -> ErlAtom

export
Cast Bool ErlAtom where
  cast True = MkAtom "true"
  cast False = MkAtom "false"

-- ErlNil/ErlCons -> List

export
Cast ErlNil (List a) where
  cast [] = []

export
Cast b (List a) => Cast (ErlCons a b) (List a) where
  cast (x :: y) = x :: cast y

-- ErlNil/ErlCons -> ErlList

export
Cast ErlNil (ErlList []) where
  cast [] = []

export
Cast b (ErlList bs) => Cast (ErlCons a b) (ErlList (a :: bs)) where
  cast (x :: y) = x :: cast y

-- ErlList -> List

export
Cast (ErlList []) (List a) where
  cast [] = []

export
Cast (ErlList as) (List a) => Cast (ErlList (a :: as)) (List a) where
  cast (x :: xs) = x :: cast xs

-- ErlList -> ErlNil/ErlCons

export
Cast (ErlList []) ErlNil where
  cast [] = []

export
Cast (ErlList [a]) (ErlCons a ErlNil) where
  cast (x :: xs) = x :: cast xs

export
Cast (ErlList as) (ErlCons b c) => Cast (ErlList (a :: as)) (ErlCons a (ErlCons b c)) where
  cast (x :: xs) = x :: cast xs

-- List -> ErlNil/ErlCons

||| Helper functions for `listToErlCons`.
export
0 ListToErlCons : List a -> Type
ListToErlCons [] = ErlNil
ListToErlCons (_ :: xs) = ErlCons a (ListToErlCons xs)

||| Convert `List` to `ErlNil` and `ErlCons`.
export
listToErlCons : (xs : List a) -> ListToErlCons xs
listToErlCons [] = []
listToErlCons (x :: xs) = x :: listToErlCons xs

-- List -> ErlList

||| Helper function for `listToErlList`.
export
0 ListToTypes : List a -> List Type
ListToTypes [] = []
ListToTypes (_ :: xs) = a :: ListToTypes xs

||| Convert `List` to `ErlList`.
export
listToErlList : (xs : List a) -> ErlList (ListToTypes xs)
listToErlList [] = []
listToErlList (x :: xs) = x :: listToErlList xs


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

||| The original unadulterated version of the GRL.
module GRL.Lang.GLang

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

%access export
%default total

||| The original unadulterated version of the GRL.
data GLang : GTy -> Type where
    ||| Make a Goal node.
    MkGoal : String -> Maybe SValue -> GLang ELEM
    ||| Make a Soft Goal node.
    MkSoft : String -> Maybe SValue -> GLang ELEM
    ||| Make a Task node.
    MkTask : String -> Maybe SValue -> GLang ELEM
    ||| Make a resource node.
    MkRes  : String -> Maybe SValue -> GLang ELEM

    ||| Declare an impact relation.
    MkImpacts : CValue -> GLang ELEM -> GLang ELEM -> GLang INTENT

    ||| Declare a side-effect relation.
    MkEffects : CValue -> GLang ELEM -> GLang ELEM -> GLang INTENT

    ||| And decomposition relation.
    MkAnd : GLang ELEM -> List (GLang ELEM) -> GLang STRUCT
    ||| XOR decomposition relation.
    MkXor : GLang ELEM -> List (GLang ELEM) -> GLang STRUCT
    ||| IOR decomposition relation.
    MkIor : GLang ELEM -> List (GLang ELEM) -> GLang STRUCT

-- --------------------------------------------------------------- [ Accessors ]

||| Obtain the node's title.
getElemTitle : GLang ELEM -> String
getElemTitle (MkGoal t _) = t
getElemTitle (MkSoft t _) = t
getElemTitle (MkTask t _) = t
getElemTitle (MkRes  t _) = t

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

mkGoal : String -> GLang ELEM
mkGoal t = MkGoal t Nothing

mkSoft : String -> GLang ELEM
mkSoft t = MkSoft t Nothing

mkTask : String -> GLang ELEM
mkTask t = MkTask t Nothing

mkRes : String -> GLang ELEM
mkRes t = MkRes t Nothing

mkSatGoal : String -> SValue -> GLang ELEM
mkSatGoal t s = MkGoal t (Just s)

mkSatSoft : String -> SValue -> GLang ELEM
mkSatSoft t s = MkSoft t (Just s)

mkSatTask : String -> SValue -> GLang ELEM
mkSatTask t s = MkTask t (Just s)

mkSatRes : String -> SValue -> GLang ELEM
mkSatRes t s = MkRes t (Just s)

mkImpacts : CValue -> GLang ELEM -> GLang ELEM -> GLang INTENT
mkImpacts = MkImpacts

mkEffects : CValue -> GLang ELEM -> GLang ELEM -> GLang INTENT
mkEffects = MkEffects

mkAnd : GLang ELEM -> List (GLang ELEM) -> GLang STRUCT
mkAnd = MkAnd

mkIor : GLang ELEM -> List (GLang ELEM) -> GLang STRUCT
mkIor = MkIor

mkXor : GLang ELEM -> List (GLang ELEM) -> GLang STRUCT
mkXor = MkXor

-- --------------------------------------------------------------------- [ GRL ]

GRL GLang where
    mkElem (MkGoal s v) = Elem GOALty s v
    mkElem (MkSoft s v) = Elem SOFTty s v
    mkElem (MkTask s v) = Elem TASKty s v
    mkElem (MkRes  s v) = Elem RESty  s v

    mkIntent (MkImpacts c a b) = ILink IMPACTSty c (mkElem a) (mkElem b)
    mkIntent (MkEffects c a b) = ILink AFFECTSty c (mkElem a) (mkElem b)

    mkStruct (MkAnd a bs) = SLink ANDty (mkElem a) (map mkElem bs)
    mkStruct (MkXor a bs) = SLink XORty (mkElem a) (map mkElem bs)
    mkStruct (MkIor a bs) = SLink IORty (mkElem a) (map mkElem bs)

-- -------------------------------------------------------------------- [ Sort ]
private
record DeclGroups where
  constructor DGroup
  elems : List (GLang ELEM)
  intes : List (GLang INTENT)
  strus : List (GLang STRUCT)

private
getGroups : DList GTy GLang gs -> DeclGroups
getGroups xs = DList.foldr doGrouping (DGroup Nil Nil Nil) xs
  where
    doGrouping : GLang ty -> DeclGroups -> DeclGroups
    doGrouping {ty=ELEM}   x g = record {elems = x :: (elems g)} g
    doGrouping {ty=INTENT} x g = record {intes = x :: (intes g)} g
    doGrouping {ty=STRUCT} x g = record {strus = x :: (strus g)} g

private
recoverList : DeclGroups -> (xs ** DList GTy GLang xs)
recoverList (DGroup es is ss) =
       (_ ** (snd es')
          ++ (snd is')
          ++ (snd ss'))
  where
    es' : (xs ** DList GTy GLang xs)
    es' = fromList es

    is' : (ys ** DList GTy GLang ys)
    is' = fromList is

    ss' : (zs ** DList GTy GLang zs)
    ss' = fromList ss

groupDecls : DList GTy GLang gs -> (gs' ** DList GTy GLang gs')
groupDecls xs = recoverList $ getGroups xs

insertDecls : DList GTy GLang gs -> GModel -> GModel
insertDecls ds m = doInsert (getGroups ds) m
  where
    doInsert' : List (GLang ELEM)
             -> List (GLang STRUCT)
             -> List (GLang INTENT)
             -> GModel
             -> GModel
    doInsert' es ss is m = insertGroup es ss is m

    doInsert : DeclGroups -> GModel -> GModel
    doInsert (DGroup es is ss) m = doInsert' es ss is m

-- -------------------------------------------------------------------- [ Show ]

private
showElem : GLang ELEM -> String
showElem (MkGoal t s) = with List unwords ["[Goal", t, show s, "]"]
showElem (MkSoft t s) = with List unwords ["[Soft", t, show s, "]"]
showElem (MkTask t s) = with List unwords ["[Task", t, show s, "]"]
showElem (MkRes  t s) = with List unwords ["[Res" , t, show s, "]"]

private
showIntent : GLang INTENT -> String
showIntent (MkImpacts c a b) = "[Impacts " ++ show c ++ " " ++ showElem a ++ " " ++ showElem b ++ "]"
showIntent (MkEffects c a b) = "[Effects " ++ show c ++ " " ++ showElem a ++ " " ++ showElem b ++ "]"

private
showElems : List (GLang ELEM) -> String
showElems ys = "[" ++ (unwords $ intersperse "," (map showElem ys)) ++ "]"

private
showStruct : GLang STRUCT -> String
showStruct (MkAnd a bs) = "[And " ++ showElem a ++ " " ++ showElems bs ++ "]"
showStruct (MkXor a bs) = "[And " ++ showElem a ++ " " ++ showElems bs ++ "]"
showStruct (MkIor a bs) = "[And " ++ showElem a ++ " " ++ showElems bs ++ "]"

private
showLang : {ty : GTy} -> GLang ty -> String
showLang {ty=ELEM}   x = showElem x
showLang {ty=INTENT} x = showIntent x
showLang {ty=STRUCT} x = showStruct x

Show (GLang ty) where
    show x = showLang x

-- ---------------------------------------------------------------------- [ Eq ]

private
eqGLangE : GLang ELEM -> GLang ELEM -> Bool
eqGLangE (MkGoal x t) (MkGoal y u) = x == y && t == u
eqGLangE (MkSoft x t) (MkSoft y u) = x == y && t == u
eqGLangE (MkTask x t) (MkTask y u) = x == y && t == u
eqGLangE (MkRes  x t) (MkRes  y u) = x == y && t == u
eqGLangE _            _            = False

private
eqGLangI : GLang INTENT -> GLang INTENT -> Bool
eqGLangI (MkImpacts c a b) (MkImpacts d x y) = c == d && eqGLangE a x && eqGLangE b y
eqGLangI (MkEffects c a b) (MkEffects d x y) = c == d && eqGLangE a x && eqGLangE b y
eqGLangI _                 _                 = False

mutual
  private
  eqGLangS : GLang STRUCT -> GLang STRUCT -> Bool
  eqGLangS (MkAnd a as) (MkAnd b bs) = eqGLangE a b && eqGLangList as bs
  eqGLangS (MkXor a as) (MkXor b bs) = eqGLangE a b && eqGLangList as bs
  eqGLangS (MkIor a as) (MkIor b bs) = eqGLangE a b && eqGLangList as bs
  eqGLangS _            _            = False

  private
  eqGLangList : List (GLang ELEM) -> List (GLang ELEM) -> Bool
  eqGLangList Nil     Nil     = True
  eqGLangList (x::xs) (y::ys) =
      if eqGLangE x y
        then eqGLangList xs ys
        else False
  eqGLangList _       _       = False

private
eqGLang : GLang a -> GLang b -> Bool
eqGLang {a=ELEM}   {b=ELEM}   x y = eqGLangE x y
eqGLang {a=INTENT} {b=INTENT} x y = eqGLangI x y
eqGLang {a=STRUCT} {b=STRUCT} x y = eqGLangS x y
eqGLang _          _              = False

Eq (GLang ty) where
  (==) = eqGLang

-- -------------------------------------------------------------- [ Comparable ]

cmpGLang : GLang x -> GLang y -> Ordering
cmpGLang {x} {y} _ _ = compare x y

Ord (GLang ty) where
  compare x y = cmpGLang x y

-- ---------------------------------------------------------------- [ Synonyms ]
public export
GOAL : Type
GOAL = GLang ELEM

public export
SOFT : Type
SOFT = GLang ELEM

public export
TASK : Type
TASK = GLang ELEM

public export
RES : Type
RES = GLang ELEM

-- ----------------------------------------------------------- [ Pretty Syntax ]

syntax [a] "==>" [b] "|" [c] = mkImpacts c a b
syntax [a] "~~>" [b] "|" [c] = mkEffects c a b
syntax [a] "&=" [b] = mkAnd a b
syntax [a] "X=" [b] = mkXor a b
syntax [a] "|=" [b] = mkIor a b

-- ---------------------------------------------------------------- [ toString ]

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