Concatenative stack-based language with church encoded data structures in Purr.

ConcatChurch.purr

module ConcatChurch is
  import Prelude

  # -- Helpers ---------------------------------------------------------
  export $a get => match $a with
                   | $a' :: _ => $a'
                   end

  export $a to-number => $a depth-start: 0
                         where
                         | $a depth-start: $n => match $a with
                                                 | Nil         => $n
                                                 | $xs' :: Nil => $xs' depth-start: $n + 1
                                                 end
                         end

  export $xs push: $a => $a :: $xs

  # -- Booleans --------------------------------------------------------
  export $xs False => [] :: $xs
  export $xs True  => [[]] :: $xs

  # -- Numbers ---------------------------------------------------------
  export $xs Zero  => $xs False
  export $xs One   => $xs True
  export $xs Two   => $xs One Successor
  export $xs Three => $xs Two Successor
  export $xs Four  => $xs Three Successor
  export $xs Five  => $xs Four Successor
  export $xs Six   => $xs Five Successor
  export $xs Seven => $xs Six Successor
  export $xs Eight => $xs Seven Successor
  export $xs Nine  => $xs Eight Successor
  
  export $xs Successor => match $xs with
                          | $a :: $xs' => [$a] :: $xs'
                          end

  export $xs Predecessor => match $xs with
                            | $a :: $xs' => $a :: $xs'
                            end

  export $xs Add => match $xs with
                    | $a :: ($b :: $xs') => ($a ++ $b) :: $xs'
                    end where
                    | $a ++ $b => if $a === [] then $b
                                               else ($a get) ++ ([$b] Successor get)
                    end

  export $xs Multiply => match $xs with
                         | $a :: ($b :: $xs') => ($a times: $b out: $b) :: $xs'
                         end where
                         | $a times: $b out: $c =>
                                                | $a === []   => [[]]
                                                | $b === []   => [[]]
                                                | $a === [[]] => $c
                                                | otherwise   => $a get
                                                                 times: $b
                                                                 out: [$b, $c] Add get
                         end

  export $xs Eq => match $xs with
                   | $a :: ($b :: $xs') => if $a === $b then ([] True get) :: $xs'
                                                        else ([] False get) :: $xs'
                   end


  # -- Control structures ----------------------------------------------
  export $xs If => match $xs with
                   | $p :: ($t :: ($e :: $xs')) => if $p === [[]] then $t :: $xs' else $e :: $xs'
                   end

  # -- Tuples ----------------------------------------------------------
  export $xs Pair => match $xs with
                     | $a :: ($b :: $xs') => [$a, $b] :: $xs'
                     end

  export $xs First => match $xs with
                      | ($a :: _) :: $xs' => $a :: $xs'
                      end

  export $xs Second => match $xs with
                       | (_ :: ($a :: _)) :: $xs' => $a :: $xs'
                       end

  # -- Stack operations ------------------------------------------------
  export $xs Replicate => match $xs with
                          | $n :: ($a :: $xs') => ($n to-number replicate: $a) :: $xs'
                          end where
                          | $n replicate: $a => if $n === 0 then []
                                                            else $a :: ($n - 1 replicate: $a)
                          end

  export $xs Quote => $xs Successor
  export $xs Eval  => match $xs with
                      | $a :: $xs' => $a fold: (_ interpret: _) from: $xs' 
                      end where
                      | $a get! => match $a with
                                   | $a' Just => $a'
                                   end
                      | $xs interpret: $a => if $a String? then ((self at: $a) get!)($xs)
                                                           else $a :: $xs
                      end

  export $xs Dip => match $xs with
                    | $a :: ($b :: $xs') => match ($a :: $xs') Eval with
                                            | $a' :: $xs'' => $b :: ($a' :: $xs'')
                                            end
                    end

  export $xs Splice    => match $xs with
                          | $a :: $xs' => $a + $xs'
                          end

  export $xs Duplicate => match $xs with
                          | $a :: $xs' => $a :: ($a :: $xs')
                          end

  export $xs Drop => match $xs with
                     | _ :: $xs' => $xs'
                     end

  export $xs Swap => match $xs with
                     | $a :: ($b :: $xs') => $b :: ($a :: $xs')
                     end

end

factorial.purr

let $xs FactInit => $xs One One Pair
let $xs FactNext => $xs Duplicate First Successor Swap Splice Multiply Swap Pair
let $xs Fact => ($xs push: `FactNext) Swap Replicate FactInit Swap Eval Second