{-|
Module: Syntax
Description: Various grammars and utilities for manipulating them.
Author: gatlin@niltag.net

== The theory


Call-By-Push-Value is the intermediate language we are using here because

1. it subsumes both call-by-value and call-by-name, and
2. the type system for it is really something.

CBPV is able to subsume both CBV and CBN evaluation strategies because the type
system can enforce at compile-time that all function arguments are so-called
/positive/ terms: fully-evaluated, static, terminated /data/.

These are contrasted with /negative/ terms, which are computations (if you want
to be really precise, they represent transitions of the evaluator virtual
machine).

There is so much more to say here. Stay tuned!

== The implementation

The "Parser" module generates 'SExpr' values, after which you may convert from
'sexpr_to_cbpv'.

The grammars are defined as non-recursive, higher-order types; where they would
reference themselves they instead reference their type parameter.
When "fixed" with the 'Free' monad type, the resulting new type defines a number
of convenient smart constructors for building syntax trees (say, in a 'Parser').

And when fixed with the 'Cofree' comonad type the resulting type defines a new
grammar pairing every "branch" in the tree with some annotation value.

Both of these are very convenient, and what's more, the conversion from the
former to the latter in 'annotate' is quite elegant, I think.
-}

{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PartialTypeSignatures #-}

module Syntax
  ( Symbol
  -- * Terms
  , SExpr(..)
  , Cbpv(..)
  , CbpvExp
  -- * Utilities
  , annotate
  , deps
  , isPositive
  , opList
  , sexprToCbpv
  , boolS
  , intS
  , floatS
  , symS
  , listS
  )
where

import Control.Comonad.Cofree (Cofree(..), unwrap)
import Control.Monad (join, mapAndUnzipM, forM)
import Control.Monad.Free (Free(..), liftF)
import Data.Map (Map)
import qualified Data.Map as M

-- Needed for upstream dependency reasons, not worth fixing yet
import Data.Ord.Deriving
import Data.Eq.Deriving
import Text.Show.Deriving

type Symbol = String

-- | __UNSTABLE__ Canonical list of built-in operators.
opList :: [Symbol]
opList :: [Symbol]
opList =
  [ Symbol
"=?"
  , Symbol
"eq-int"
  , Symbol
"lte-int"
  , Symbol
"gte-int"
  , Symbol
"lt-int"
  , Symbol
"gt-int"
  , Symbol
"eq-float"
  , Symbol
"lte-float"
  , Symbol
"gte-float"
  , Symbol
"lt-float"
  , Symbol
"gt-float"
  , Symbol
"add-int"
  , Symbol
"sub-int"
  , Symbol
"mul-int"
  , Symbol
"div-int"
  , Symbol
"add-float"
  , Symbol
"sub-float"
  , Symbol
"mul-float"
  , Symbol
"div-float"
  , Symbol
"eq-bool"
  , Symbol
"mod-int"
  , Symbol
"mod-float"
  , Symbol
"not"
  , Symbol
"&&"
  , Symbol
"||" ]

-- | A very simple s-expression language.
-- An s-expression is either some atom (symbol, number, boolean) or a
-- white-space-delimited list of s-expressions surrounded by parentheses.
-- For now, any surface syntax (ie, stuff a human such as yours truly would be
-- expected to type) will be based on s-expressions, and be able to make use of
-- the same s-expression parser defined in a sibling module.
-- Conversion to more structured intermediate forms is taken care of by other
-- functions.
data SExpr (a :: *)
  = IntS Integer
  | FloatS Double
  | BoolS Bool
  | SymS Symbol
  | ListS [a]
  deriving ( (forall a b. (a -> b) -> SExpr a -> SExpr b)
-> (forall a b. a -> SExpr b -> SExpr a) -> Functor SExpr
forall a b. a -> SExpr b -> SExpr a
forall a b. (a -> b) -> SExpr a -> SExpr b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> SExpr b -> SExpr a
$c<$ :: forall a b. a -> SExpr b -> SExpr a
fmap :: forall a b. (a -> b) -> SExpr a -> SExpr b
$cfmap :: forall a b. (a -> b) -> SExpr a -> SExpr b
Functor
           , (forall m. Monoid m => SExpr m -> m)
-> (forall m a. Monoid m => (a -> m) -> SExpr a -> m)
-> (forall m a. Monoid m => (a -> m) -> SExpr a -> m)
-> (forall a b. (a -> b -> b) -> b -> SExpr a -> b)
-> (forall a b. (a -> b -> b) -> b -> SExpr a -> b)
-> (forall b a. (b -> a -> b) -> b -> SExpr a -> b)
-> (forall b a. (b -> a -> b) -> b -> SExpr a -> b)
-> (forall a. (a -> a -> a) -> SExpr a -> a)
-> (forall a. (a -> a -> a) -> SExpr a -> a)
-> (forall a. SExpr a -> [a])
-> (forall a. SExpr a -> Bool)
-> (forall a. SExpr a -> Int)
-> (forall a. Eq a => a -> SExpr a -> Bool)
-> (forall a. Ord a => SExpr a -> a)
-> (forall a. Ord a => SExpr a -> a)
-> (forall a. Num a => SExpr a -> a)
-> (forall a. Num a => SExpr a -> a)
-> Foldable SExpr
forall a. Eq a => a -> SExpr a -> Bool
forall a. Num a => SExpr a -> a
forall a. Ord a => SExpr a -> a
forall m. Monoid m => SExpr m -> m
forall a. SExpr a -> Bool
forall a. SExpr a -> Int
forall a. SExpr a -> [a]
forall a. (a -> a -> a) -> SExpr a -> a
forall m a. Monoid m => (a -> m) -> SExpr a -> m
forall b a. (b -> a -> b) -> b -> SExpr a -> b
forall a b. (a -> b -> b) -> b -> SExpr a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => SExpr a -> a
$cproduct :: forall a. Num a => SExpr a -> a
sum :: forall a. Num a => SExpr a -> a
$csum :: forall a. Num a => SExpr a -> a
minimum :: forall a. Ord a => SExpr a -> a
$cminimum :: forall a. Ord a => SExpr a -> a
maximum :: forall a. Ord a => SExpr a -> a
$cmaximum :: forall a. Ord a => SExpr a -> a
elem :: forall a. Eq a => a -> SExpr a -> Bool
$celem :: forall a. Eq a => a -> SExpr a -> Bool
length :: forall a. SExpr a -> Int
$clength :: forall a. SExpr a -> Int
null :: forall a. SExpr a -> Bool
$cnull :: forall a. SExpr a -> Bool
toList :: forall a. SExpr a -> [a]
$ctoList :: forall a. SExpr a -> [a]
foldl1 :: forall a. (a -> a -> a) -> SExpr a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SExpr a -> a
foldr1 :: forall a. (a -> a -> a) -> SExpr a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> SExpr a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> SExpr a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SExpr a -> b
foldl :: forall b a. (b -> a -> b) -> b -> SExpr a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SExpr a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> SExpr a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SExpr a -> b
foldr :: forall a b. (a -> b -> b) -> b -> SExpr a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> SExpr a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> SExpr a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SExpr a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> SExpr a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SExpr a -> m
fold :: forall m. Monoid m => SExpr m -> m
$cfold :: forall m. Monoid m => SExpr m -> m
Foldable
           , Functor SExpr
Foldable SExpr
Functor SExpr
-> Foldable SExpr
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> SExpr a -> f (SExpr b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    SExpr (f a) -> f (SExpr a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> SExpr a -> m (SExpr b))
-> (forall (m :: * -> *) a. Monad m => SExpr (m a) -> m (SExpr a))
-> Traversable SExpr
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => SExpr (m a) -> m (SExpr a)
forall (f :: * -> *) a. Applicative f => SExpr (f a) -> f (SExpr a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SExpr a -> m (SExpr b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SExpr a -> f (SExpr b)
sequence :: forall (m :: * -> *) a. Monad m => SExpr (m a) -> m (SExpr a)
$csequence :: forall (m :: * -> *) a. Monad m => SExpr (m a) -> m (SExpr a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SExpr a -> m (SExpr b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SExpr a -> m (SExpr b)
sequenceA :: forall (f :: * -> *) a. Applicative f => SExpr (f a) -> f (SExpr a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => SExpr (f a) -> f (SExpr a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SExpr a -> f (SExpr b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SExpr a -> f (SExpr b)
Traversable )

-- * Intermediate language: CBPV

-- | Call-By-Push-Value
-- Call-By-Push-Value is a type system which polarizes terms and types into
-- /positive/ and /negative/ kinds.
-- Positive terms are literal values or data; they are "at rest"; "static".
-- Negative terms are functions; "in action"; "dynamic".
-- In doing so the type system is able to enforce evaluation order at compile
-- time.
-- 'Cbpv' is a meta-language chosen because of what can be built on top of it
-- and not because it is particularly pleasant on its own.
data Cbpv (a :: *)
  -- positive terms (values)
  = VoidA -- ^ 1 / ⊥
  | IntA Integer -- ^ integer literal value
  | FloatA Double -- ^ floating point literal value
  | BoolA Bool -- ^ boolean literal value
  | SymA Symbol -- ^ identifier symbol
  | OpA Symbol [a] -- ^ application of an operator to positive terms
  | SuspendA a -- ^ negative -> positive
  -- negative terms (computations)
  | ResumeA a -- ^ positive -> negative
  | FunA [Symbol] a -- ^ pops and binds values from call stack, evals body
  | AppA a [a] -- ^ pushes values onto call stack, evals operator
  | LetA Symbol a a -- ^ evals first computation, binds its value in second
  | LetrecA [(Symbol, a)] a -- ^ mutually recursive bindings
  | ResetA a -- ^ delimits a continuation capture
  | ShiftA Symbol a -- ^ captures and binds a continuation in a computation
  | IfA a a a -- ^ first arg must be positive (boolean), others negative
  deriving ( (forall a b. (a -> b) -> Cbpv a -> Cbpv b)
-> (forall a b. a -> Cbpv b -> Cbpv a) -> Functor Cbpv
forall a b. a -> Cbpv b -> Cbpv a
forall a b. (a -> b) -> Cbpv a -> Cbpv b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Cbpv b -> Cbpv a
$c<$ :: forall a b. a -> Cbpv b -> Cbpv a
fmap :: forall a b. (a -> b) -> Cbpv a -> Cbpv b
$cfmap :: forall a b. (a -> b) -> Cbpv a -> Cbpv b
Functor
           , (forall m. Monoid m => Cbpv m -> m)
-> (forall m a. Monoid m => (a -> m) -> Cbpv a -> m)
-> (forall m a. Monoid m => (a -> m) -> Cbpv a -> m)
-> (forall a b. (a -> b -> b) -> b -> Cbpv a -> b)
-> (forall a b. (a -> b -> b) -> b -> Cbpv a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cbpv a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cbpv a -> b)
-> (forall a. (a -> a -> a) -> Cbpv a -> a)
-> (forall a. (a -> a -> a) -> Cbpv a -> a)
-> (forall a. Cbpv a -> [a])
-> (forall a. Cbpv a -> Bool)
-> (forall a. Cbpv a -> Int)
-> (forall a. Eq a => a -> Cbpv a -> Bool)
-> (forall a. Ord a => Cbpv a -> a)
-> (forall a. Ord a => Cbpv a -> a)
-> (forall a. Num a => Cbpv a -> a)
-> (forall a. Num a => Cbpv a -> a)
-> Foldable Cbpv
forall a. Eq a => a -> Cbpv a -> Bool
forall a. Num a => Cbpv a -> a
forall a. Ord a => Cbpv a -> a
forall m. Monoid m => Cbpv m -> m
forall a. Cbpv a -> Bool
forall a. Cbpv a -> Int
forall a. Cbpv a -> [a]
forall a. (a -> a -> a) -> Cbpv a -> a
forall m a. Monoid m => (a -> m) -> Cbpv a -> m
forall b a. (b -> a -> b) -> b -> Cbpv a -> b
forall a b. (a -> b -> b) -> b -> Cbpv a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Cbpv a -> a
$cproduct :: forall a. Num a => Cbpv a -> a
sum :: forall a. Num a => Cbpv a -> a
$csum :: forall a. Num a => Cbpv a -> a
minimum :: forall a. Ord a => Cbpv a -> a
$cminimum :: forall a. Ord a => Cbpv a -> a
maximum :: forall a. Ord a => Cbpv a -> a
$cmaximum :: forall a. Ord a => Cbpv a -> a
elem :: forall a. Eq a => a -> Cbpv a -> Bool
$celem :: forall a. Eq a => a -> Cbpv a -> Bool
length :: forall a. Cbpv a -> Int
$clength :: forall a. Cbpv a -> Int
null :: forall a. Cbpv a -> Bool
$cnull :: forall a. Cbpv a -> Bool
toList :: forall a. Cbpv a -> [a]
$ctoList :: forall a. Cbpv a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Cbpv a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Cbpv a -> a
foldr1 :: forall a. (a -> a -> a) -> Cbpv a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Cbpv a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Cbpv a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Cbpv a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Cbpv a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Cbpv a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Cbpv a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Cbpv a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Cbpv a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Cbpv a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Cbpv a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Cbpv a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Cbpv a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Cbpv a -> m
fold :: forall m. Monoid m => Cbpv m -> m
$cfold :: forall m. Monoid m => Cbpv m -> m
Foldable
           , Functor Cbpv
Foldable Cbpv
Functor Cbpv
-> Foldable Cbpv
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Cbpv a -> f (Cbpv b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Cbpv (f a) -> f (Cbpv a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Cbpv a -> m (Cbpv b))
-> (forall (m :: * -> *) a. Monad m => Cbpv (m a) -> m (Cbpv a))
-> Traversable Cbpv
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Cbpv (m a) -> m (Cbpv a)
forall (f :: * -> *) a. Applicative f => Cbpv (f a) -> f (Cbpv a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cbpv a -> m (Cbpv b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cbpv a -> f (Cbpv b)
sequence :: forall (m :: * -> *) a. Monad m => Cbpv (m a) -> m (Cbpv a)
$csequence :: forall (m :: * -> *) a. Monad m => Cbpv (m a) -> m (Cbpv a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cbpv a -> m (Cbpv b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cbpv a -> m (Cbpv b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Cbpv (f a) -> f (Cbpv a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Cbpv (f a) -> f (Cbpv a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cbpv a -> f (Cbpv b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cbpv a -> f (Cbpv b)
Traversable
           , Cbpv a -> Cbpv a -> Bool
(Cbpv a -> Cbpv a -> Bool)
-> (Cbpv a -> Cbpv a -> Bool) -> Eq (Cbpv a)
forall a. Eq a => Cbpv a -> Cbpv a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cbpv a -> Cbpv a -> Bool
$c/= :: forall a. Eq a => Cbpv a -> Cbpv a -> Bool
== :: Cbpv a -> Cbpv a -> Bool
$c== :: forall a. Eq a => Cbpv a -> Cbpv a -> Bool
Eq )

-- these instances are needed for library reasons I need to sort out
$(deriveEq1 ''Cbpv)
$(deriveOrd1 ''Cbpv)
$(deriveShow1 ''Cbpv)

-- | Helper function answering the question: is this 'Free Cbpv a' expression
-- atomic?
isPositive :: Cbpv a -> Bool
isPositive :: forall a. Cbpv a -> Bool
isPositive (IntA Integer
_) = Bool
True
isPositive (FloatA Double
_) = Bool
True
isPositive (BoolA Bool
_) = Bool
True
isPositive (SymA Symbol
_) = Bool
True
isPositive Cbpv a
VoidA = Bool
True
isPositive (SuspendA a
_) = Bool
True
isPositive (OpA Symbol
_ [a]
_) = Bool
True
isPositive Cbpv a
_ = Bool
False

isPositive' :: Free Cbpv a -> Bool
isPositive' :: forall a. Free Cbpv a -> Bool
isPositive' (Free Cbpv (Free Cbpv a)
cbpvexp) = Cbpv (Free Cbpv a) -> Bool
forall a. Cbpv a -> Bool
isPositive Cbpv (Free Cbpv a)
cbpvexp

-- | This function converts a free monad representation of a language into one
-- which annotates each expression with arbitrary metadata.
-- One example use-case is annotating expressions with type information.
annotate :: (Monad m, Traversable f, Show a) => Free f a -> m (Cofree f ())
annotate :: forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f, Show a) =>
Free f a -> m (Cofree f ())
annotate (Pure a
s) = Symbol -> m (Cofree f ())
forall a. HasCallStack => Symbol -> a
error (a -> Symbol
forall a. Show a => a -> Symbol
show a
s)
annotate (Free f (Free f a)
m) = (() () -> f (Cofree f ()) -> Cofree f ()
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:<) (f (Cofree f ()) -> Cofree f ())
-> m (f (Cofree f ())) -> m (Cofree f ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Free f a -> m (Cofree f ()))
-> f (Free f a) -> m (f (Cofree f ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Free f a -> m (Cofree f ())
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Traversable f, Show a) =>
Free f a -> m (Cofree f ())
annotate f (Free f a)
m

-- | Builds a `Cbpv` expression from an `SExpr` syntax tree.
sexprToCbpv :: Cofree SExpr () -> Free Cbpv String
sexprToCbpv :: Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv = SExpr (Cofree SExpr ()) -> Free Cbpv Symbol
begin (SExpr (Cofree SExpr ()) -> Free Cbpv Symbol)
-> (Cofree SExpr () -> SExpr (Cofree SExpr ()))
-> Cofree SExpr ()
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cofree SExpr () -> SExpr (Cofree SExpr ())
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap  where
  begin :: SExpr (Cofree SExpr ()) -> Free Cbpv String
  begin :: SExpr (Cofree SExpr ()) -> Free Cbpv Symbol
begin (IntS Integer
n) = Cbpv Symbol -> Free Cbpv Symbol
forall {a}. Cbpv a -> Free Cbpv a
simple (Cbpv Symbol -> Free Cbpv Symbol)
-> Cbpv Symbol -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Integer -> Cbpv Symbol
forall a. Integer -> Cbpv a
IntA Integer
n
  begin (FloatS Double
n) = Cbpv Symbol -> Free Cbpv Symbol
forall {a}. Cbpv a -> Free Cbpv a
simple (Cbpv Symbol -> Free Cbpv Symbol)
-> Cbpv Symbol -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Double -> Cbpv Symbol
forall a. Double -> Cbpv a
FloatA Double
n
  begin (BoolS Bool
n) = Cbpv Symbol -> Free Cbpv Symbol
forall {a}. Cbpv a -> Free Cbpv a
simple (Cbpv Symbol -> Free Cbpv Symbol)
-> Cbpv Symbol -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Bool -> Cbpv Symbol
forall a. Bool -> Cbpv a
BoolA Bool
n
  begin (SymS Symbol
n) = Cbpv Symbol -> Free Cbpv Symbol
forall {a}. Cbpv a -> Free Cbpv a
simple (Cbpv Symbol -> Free Cbpv Symbol)
-> Cbpv Symbol -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Symbol -> Cbpv Symbol
forall a. Symbol -> Cbpv a
SymA Symbol
n
  begin (ListS [Cofree SExpr ()]
xs) = [Cofree SExpr ()] -> Free Cbpv Symbol
compound_list [Cofree SExpr ()]
xs

  compound_list :: [Cofree SExpr ()] -> Free Cbpv String
  compound_list :: [Cofree SExpr ()] -> Free Cbpv Symbol
compound_list [] = Cbpv Symbol -> Free Cbpv Symbol
forall {a}. Cbpv a -> Free Cbpv a
simple Cbpv Symbol
forall a. Cbpv a
VoidA
  compound_list (Cofree SExpr ()
op:[Cofree SExpr ()]
erands) = SExpr (Cofree SExpr ()) -> [Cofree SExpr ()] -> Free Cbpv Symbol
compound_op (Cofree SExpr () -> SExpr (Cofree SExpr ())
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap Cofree SExpr ()
op) [Cofree SExpr ()]
erands

  compound_op
    :: SExpr (Cofree SExpr ())
    -> [Cofree SExpr ()]
    -> Free Cbpv String
  compound_op :: SExpr (Cofree SExpr ()) -> [Cofree SExpr ()] -> Free Cbpv Symbol
compound_op (SymS Symbol
"if") [Cofree SExpr ()]
erands =
    if [Cofree SExpr ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cofree SExpr ()]
erands Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol -> Free Cbpv Symbol) -> Symbol -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$
        Symbol
"'if' expression has 3 arguments, not " Symbol -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Symbol
forall a. Show a => a -> Symbol
show ([Cofree SExpr ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cofree SExpr ()]
erands)
      else do
        let cond_cbpv :: Free Cbpv Symbol
cond_cbpv = Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv ([Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands)
        let cond_isPositive :: Bool
cond_isPositive = Free Cbpv Symbol -> Bool
forall a. Free Cbpv a -> Bool
isPositive' Free Cbpv Symbol
cond_cbpv
        if Bool -> Bool
not Bool
cond_isPositive
          then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"conditional expression must be atomic"
          else Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$
            Free Cbpv Symbol
-> Free Cbpv Symbol -> Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. a -> a -> a -> Cbpv a
IfA Free Cbpv Symbol
cond_cbpv
              (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (Cofree SExpr () -> Free Cbpv Symbol)
-> Cofree SExpr () -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()]
erands [Cofree SExpr ()] -> Int -> Cofree SExpr ()
forall a. [a] -> Int -> a
!! Int
1)
              (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (Cofree SExpr () -> Free Cbpv Symbol)
-> Cofree SExpr () -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()]
erands [Cofree SExpr ()] -> Int -> Cofree SExpr ()
forall a. [a] -> Int -> a
!! Int
2)

  compound_op (SymS Symbol
"\\") [Cofree SExpr ()]
erands = SExpr (Cofree SExpr ()) -> [Cofree SExpr ()] -> Free Cbpv Symbol
compound_op (Symbol -> SExpr (Cofree SExpr ())
forall a. Symbol -> SExpr a
SymS Symbol
"λ") [Cofree SExpr ()]
erands
  compound_op (SymS Symbol
"λ") [Cofree SExpr ()]
erands =
    if [Cofree SExpr ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cofree SExpr ()]
erands Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"malformed function definition"
      else do
        let (ListS [Cofree SExpr ()]
args) = Cofree SExpr () -> SExpr (Cofree SExpr ())
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap (Cofree SExpr () -> SExpr (Cofree SExpr ()))
-> Cofree SExpr () -> SExpr (Cofree SExpr ())
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands
        Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$
          [Symbol] -> Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. [Symbol] -> a -> Cbpv a
FunA
            ((\(()
_ :< (SymS Symbol
s)) -> Symbol
s) (Cofree SExpr () -> Symbol) -> [Cofree SExpr ()] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Cofree SExpr ()]
args)
            (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (Cofree SExpr () -> Free Cbpv Symbol)
-> Cofree SExpr () -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()]
erands [Cofree SExpr ()] -> Int -> Cofree SExpr ()
forall a. [a] -> Int -> a
!! Int
1)

  compound_op (SymS Symbol
"let") [Cofree SExpr ()]
erands =
    if [Cofree SExpr ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cofree SExpr ()]
erands Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol -> Free Cbpv Symbol) -> Symbol -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$
         Symbol
"let-binding requires 3 arguments, not " Symbol -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Symbol
forall a. Show a => a -> Symbol
show ([Cofree SExpr ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cofree SExpr ()]
erands) 
      else do
        let (SymS Symbol
var) = Cofree SExpr () -> SExpr (Cofree SExpr ())
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap (Cofree SExpr () -> SExpr (Cofree SExpr ()))
-> Cofree SExpr () -> SExpr (Cofree SExpr ())
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands
        Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$
          Symbol
-> Free Cbpv Symbol -> Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. Symbol -> a -> a -> Cbpv a
LetA Symbol
var (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (Cofree SExpr () -> Free Cbpv Symbol)
-> Cofree SExpr () -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()]
erands [Cofree SExpr ()] -> Int -> Cofree SExpr ()
forall a. [a] -> Int -> a
!! Int
1) (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (Cofree SExpr () -> Free Cbpv Symbol)
-> Cofree SExpr () -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()]
erands [Cofree SExpr ()] -> Int -> Cofree SExpr ()
forall a. [a] -> Int -> a
!! Int
2)

  compound_op (SymS Symbol
"letrec") [Cofree SExpr ()]
erands = do
    let (ListS [Cofree SExpr ()]
bs) = Cofree SExpr () -> SExpr (Cofree SExpr ())
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap ([Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands)
    [(Symbol, Free Cbpv Symbol)]
bindings <- [Cofree SExpr ()]
-> (Cofree SExpr () -> Free Cbpv (Symbol, Free Cbpv Symbol))
-> Free Cbpv [(Symbol, Free Cbpv Symbol)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Cofree SExpr ()]
bs ((Cofree SExpr () -> Free Cbpv (Symbol, Free Cbpv Symbol))
 -> Free Cbpv [(Symbol, Free Cbpv Symbol)])
-> (Cofree SExpr () -> Free Cbpv (Symbol, Free Cbpv Symbol))
-> Free Cbpv [(Symbol, Free Cbpv Symbol)]
forall a b. (a -> b) -> a -> b
$ \(()
_ :< (ListS [()
_ :< (SymS Symbol
var), Cofree SExpr ()
exp])) -> do
      (Symbol, Free Cbpv Symbol) -> Free Cbpv (Symbol, Free Cbpv Symbol)
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol
var, Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv Cofree SExpr ()
exp)
    Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [(Symbol, Free Cbpv Symbol)]
-> Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. [(Symbol, a)] -> a -> Cbpv a
LetrecA [(Symbol, Free Cbpv Symbol)]
bindings (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (Cofree SExpr () -> Free Cbpv Symbol)
-> Cofree SExpr () -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Cofree SExpr ()]
erands [Cofree SExpr ()] -> Int -> Cofree SExpr ()
forall a. [a] -> Int -> a
!! Int
1)

  compound_op (SymS Symbol
"shift") [Cofree SExpr ()]
erands =
    if [Cofree SExpr ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cofree SExpr ()]
erands Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol -> Free Cbpv Symbol) -> Symbol -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$
        Symbol
"'shift' takes 2 arguments, not " Symbol -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Symbol
forall a. Show a => a -> Symbol
show ([Cofree SExpr ()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Cofree SExpr ()]
erands)
      else do
        let (SymS Symbol
k) = Cofree SExpr () -> SExpr (Cofree SExpr ())
forall (f :: * -> *) (w :: * -> *) a.
ComonadCofree f w =>
w a -> f (w a)
unwrap ([Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands)
        Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Symbol -> Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. Symbol -> a -> Cbpv a
ShiftA Symbol
k (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv ([Cofree SExpr ()]
erands [Cofree SExpr ()] -> Int -> Cofree SExpr ()
forall a. [a] -> Int -> a
!! Int
1))

  compound_op (SymS Symbol
"reset") [Cofree SExpr ()]
erands =
    if [Cofree SExpr ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cofree SExpr ()]
erands
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"'reset' expects one argument"
      else Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. a -> Cbpv a
ResetA (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv ([Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands))

  compound_op (SymS Symbol
"!") [Cofree SExpr ()]
erands =
    if [Cofree SExpr ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cofree SExpr ()]
erands
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"'suspend' expects one argument"
      else Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. a -> Cbpv a
SuspendA (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv ([Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands))

  compound_op (SymS Symbol
"?") [Cofree SExpr ()]
erands =
    if [Cofree SExpr ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cofree SExpr ()]
erands
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"'resume' expects one argument"
      else Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ Free Cbpv Symbol -> Cbpv (Free Cbpv Symbol)
forall a. a -> Cbpv a
ResumeA (Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv ([Cofree SExpr ()] -> Cofree SExpr ()
forall a. [a] -> a
head [Cofree SExpr ()]
erands))

  compound_op SExpr (Cofree SExpr ())
op [Cofree SExpr ()]
erands = do
    ([Bool]
all_positive, [Free Cbpv Symbol]
erands') <- (Cofree SExpr () -> Free Cbpv (Bool, Free Cbpv Symbol))
-> [Cofree SExpr ()] -> Free Cbpv ([Bool], [Free Cbpv Symbol])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (\Cofree SExpr ()
erand -> do
      let erand' :: Free Cbpv Symbol
erand' = Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv Cofree SExpr ()
erand
      let positive :: Bool
positive = Free Cbpv Symbol -> Bool
forall a. Free Cbpv a -> Bool
isPositive' Free Cbpv Symbol
erand'
      (Bool, Free Cbpv Symbol) -> Free Cbpv (Bool, Free Cbpv Symbol)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
positive, Free Cbpv Symbol
erand')) [Cofree SExpr ()]
erands
    if Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
all_positive)
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"arguments must always be atomic"
      else let ctor :: [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol)
ctor = case SExpr (Cofree SExpr ())
op of
                        (SymS Symbol
sym) ->
                          if Symbol
sym Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
opList
                            then Symbol -> [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol)
forall a. Symbol -> [a] -> Cbpv a
OpA Symbol
sym
                            else Free Cbpv Symbol -> [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol)
forall a. a -> [a] -> Cbpv a
AppA (Free Cbpv Symbol -> [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol))
-> Free Cbpv Symbol
-> [Free Cbpv Symbol]
-> Cbpv (Free Cbpv Symbol)
forall a b. (a -> b) -> a -> b
$ Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (() () -> SExpr (Cofree SExpr ()) -> Cofree SExpr ()
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< SExpr (Cofree SExpr ())
op)
                        SExpr (Cofree SExpr ())
_ -> Free Cbpv Symbol -> [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol)
forall a. a -> [a] -> Cbpv a
AppA (Free Cbpv Symbol -> [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol))
-> Free Cbpv Symbol
-> [Free Cbpv Symbol]
-> Cbpv (Free Cbpv Symbol)
forall a b. (a -> b) -> a -> b
$ Cofree SExpr () -> Free Cbpv Symbol
sexprToCbpv (() () -> SExpr (Cofree SExpr ()) -> Cofree SExpr ()
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< SExpr (Cofree SExpr ())
op)
           in  Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall {a}. Cbpv (Free Cbpv a) -> Free Cbpv a
compound (Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol)
ctor [Free Cbpv Symbol]
erands'

  simple :: Cbpv a -> Free Cbpv a
simple = Cbpv a -> Free Cbpv a
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF
  compound :: Cbpv (Free Cbpv a) -> Free Cbpv a
compound = Free Cbpv (Free Cbpv a) -> Free Cbpv a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv a) -> Free Cbpv a)
-> (Cbpv (Free Cbpv a) -> Free Cbpv (Free Cbpv a))
-> Cbpv (Free Cbpv a)
-> Free Cbpv a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv a) -> Free Cbpv (Free Cbpv a)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF

-- | The primary form of our intermediate language.
type CbpvExp = Cofree Cbpv ()

deps :: Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps :: Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps Map Symbol CbpvExp
xs = CbpvExp -> [Symbol]
go where
  go :: CbpvExp -> [Symbol]
go (()
_ :< (SymA Symbol
sym)) = case Symbol -> Map Symbol CbpvExp -> Maybe CbpvExp
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Symbol
sym Map Symbol CbpvExp
xs of
    Maybe CbpvExp
Nothing -> [Symbol
sym | Symbol
sym Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
opList ]
    Just CbpvExp
_ -> [Symbol
sym]
  go (()
_ :< (AppA CbpvExp
op [CbpvExp]
erands)) = CbpvExp -> [Symbol]
go CbpvExp
op [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ (CbpvExp -> [Symbol]) -> [CbpvExp] -> [Symbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CbpvExp -> [Symbol]
go [CbpvExp]
erands
  go (()
_ :< (FunA [Symbol]
_ CbpvExp
body)) = CbpvExp -> [Symbol]
go CbpvExp
body
  go (()
_ :< (IfA CbpvExp
c CbpvExp
t CbpvExp
e)) = CbpvExp -> [Symbol]
go CbpvExp
c [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ CbpvExp -> [Symbol]
go CbpvExp
t [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ CbpvExp -> [Symbol]
go CbpvExp
e
  go (()
_ :< (ResetA CbpvExp
exp)) = CbpvExp -> [Symbol]
go CbpvExp
exp
  go (()
_ :< (ShiftA Symbol
var CbpvExp
exp)) = CbpvExp -> [Symbol]
go CbpvExp
exp [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps (Symbol -> CbpvExp -> Map Symbol CbpvExp -> Map Symbol CbpvExp
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Symbol
var (() () -> Cbpv CbpvExp -> CbpvExp
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Cbpv CbpvExp
forall a. Cbpv a
VoidA) Map Symbol CbpvExp
xs) CbpvExp
exp
  go (()
_ :< (LetA Symbol
var CbpvExp
exp CbpvExp
body)) = CbpvExp -> [Symbol]
go CbpvExp
exp [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps (Symbol -> CbpvExp -> Map Symbol CbpvExp -> Map Symbol CbpvExp
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Symbol
var (() () -> Cbpv CbpvExp -> CbpvExp
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Cbpv CbpvExp
forall a. Cbpv a
VoidA) Map Symbol CbpvExp
xs) CbpvExp
body
  go (()
_ :< (LetrecA [(Symbol, CbpvExp)]
bindings CbpvExp
body)) =
    let xs' :: Map Symbol CbpvExp
xs' = Map Symbol CbpvExp -> Map Symbol CbpvExp -> Map Symbol CbpvExp
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union ([(Symbol, CbpvExp)] -> Map Symbol CbpvExp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Symbol, CbpvExp)]
bindings) Map Symbol CbpvExp
xs
    in  ((Symbol, CbpvExp) -> [Symbol]) -> [(Symbol, CbpvExp)] -> [Symbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps Map Symbol CbpvExp
xs' (CbpvExp -> [Symbol])
-> ((Symbol, CbpvExp) -> CbpvExp) -> (Symbol, CbpvExp) -> [Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol, CbpvExp) -> CbpvExp
forall a b. (a, b) -> b
snd) [(Symbol, CbpvExp)]
bindings [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps Map Symbol CbpvExp
xs' CbpvExp
body
  go (()
_ :< (SuspendA CbpvExp
comp)) = CbpvExp -> [Symbol]
go CbpvExp
comp
  go (()
_ :< (ResumeA CbpvExp
val)) = CbpvExp -> [Symbol]
go CbpvExp
val
  go (()
_ :< (OpA Symbol
op [CbpvExp]
erands)) = CbpvExp -> [Symbol]
go (() () -> Cbpv CbpvExp -> CbpvExp
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Symbol -> Cbpv CbpvExp
forall a. Symbol -> Cbpv a
SymA Symbol
op) [Symbol] -> [Symbol] -> [Symbol]
forall a. [a] -> [a] -> [a]
++ (CbpvExp -> [Symbol]) -> [CbpvExp] -> [Symbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CbpvExp -> [Symbol]
go [CbpvExp]
erands
  go CbpvExp
_ = []

-- * Smart constructors for 'Free SExpr` terms.
floatS :: Double -> Free SExpr ()
floatS :: Double -> Free SExpr ()
floatS = SExpr () -> Free SExpr ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (SExpr () -> Free SExpr ())
-> (Double -> SExpr ()) -> Double -> Free SExpr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> SExpr ()
forall a. Double -> SExpr a
FloatS

intS :: Integer -> Free SExpr ()
intS :: Integer -> Free SExpr ()
intS = SExpr () -> Free SExpr ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (SExpr () -> Free SExpr ())
-> (Integer -> SExpr ()) -> Integer -> Free SExpr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> SExpr ()
forall a. Integer -> SExpr a
IntS

symS :: Symbol -> Free SExpr ()
symS :: Symbol -> Free SExpr ()
symS = SExpr () -> Free SExpr ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (SExpr () -> Free SExpr ())
-> (Symbol -> SExpr ()) -> Symbol -> Free SExpr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> SExpr ()
forall a. Symbol -> SExpr a
SymS

boolS :: Bool -> Free SExpr ()
boolS :: Bool -> Free SExpr ()
boolS = SExpr () -> Free SExpr ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (SExpr () -> Free SExpr ())
-> (Bool -> SExpr ()) -> Bool -> Free SExpr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SExpr ()
forall a. Bool -> SExpr a
BoolS

listS :: [Free SExpr a] -> Free SExpr a
listS :: forall a. [Free SExpr a] -> Free SExpr a
listS = Free SExpr (Free SExpr a) -> Free SExpr a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free SExpr (Free SExpr a) -> Free SExpr a)
-> ([Free SExpr a] -> Free SExpr (Free SExpr a))
-> [Free SExpr a]
-> Free SExpr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SExpr (Free SExpr a) -> Free SExpr (Free SExpr a)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (SExpr (Free SExpr a) -> Free SExpr (Free SExpr a))
-> ([Free SExpr a] -> SExpr (Free SExpr a))
-> [Free SExpr a]
-> Free SExpr (Free SExpr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Free SExpr a] -> SExpr (Free SExpr a)
forall a. [a] -> SExpr a
ListS