{-|
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 #-}

module Syntax
  ( Symbol
  -- * Terms
  , SExpr(..)
  , Cbpv(..)
  , CbpvExp
  -- * Utilities
  , annotate
  , deps
  , is_positive
  , op_list
  , sexpr_to_cbpv )
where

import Control.Comonad.Cofree (Cofree(..))
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.
op_list :: [Symbol]
op_list :: [Symbol]
op_list = [ 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 ( a -> SExpr b -> SExpr a
(a -> b) -> SExpr a -> SExpr b
(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
<$ :: a -> SExpr b -> SExpr a
$c<$ :: forall a b. a -> SExpr b -> SExpr a
fmap :: (a -> b) -> SExpr a -> SExpr b
$cfmap :: forall a b. (a -> b) -> SExpr a -> SExpr b
Functor
           , SExpr a -> Bool
(a -> m) -> SExpr a -> m
(a -> b -> b) -> b -> SExpr a -> b
(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 :: SExpr a -> a
$cproduct :: forall a. Num a => SExpr a -> a
sum :: SExpr a -> a
$csum :: forall a. Num a => SExpr a -> a
minimum :: SExpr a -> a
$cminimum :: forall a. Ord a => SExpr a -> a
maximum :: SExpr a -> a
$cmaximum :: forall a. Ord a => SExpr a -> a
elem :: a -> SExpr a -> Bool
$celem :: forall a. Eq a => a -> SExpr a -> Bool
length :: SExpr a -> Int
$clength :: forall a. SExpr a -> Int
null :: SExpr a -> Bool
$cnull :: forall a. SExpr a -> Bool
toList :: SExpr a -> [a]
$ctoList :: forall a. SExpr a -> [a]
foldl1 :: (a -> a -> a) -> SExpr a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SExpr a -> a
foldr1 :: (a -> a -> a) -> SExpr a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> SExpr a -> a
foldl' :: (b -> a -> b) -> b -> SExpr a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SExpr a -> b
foldl :: (b -> a -> b) -> b -> SExpr a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SExpr a -> b
foldr' :: (a -> b -> b) -> b -> SExpr a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SExpr a -> b
foldr :: (a -> b -> b) -> b -> SExpr a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> SExpr a -> b
foldMap' :: (a -> m) -> SExpr a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SExpr a -> m
foldMap :: (a -> m) -> SExpr a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SExpr a -> m
fold :: 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
(a -> f b) -> SExpr a -> f (SExpr b)
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 :: SExpr (m a) -> m (SExpr a)
$csequence :: forall (m :: * -> *) a. Monad m => SExpr (m a) -> m (SExpr a)
mapM :: (a -> m b) -> SExpr a -> m (SExpr b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SExpr a -> m (SExpr b)
sequenceA :: SExpr (f a) -> f (SExpr a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => SExpr (f a) -> f (SExpr a)
traverse :: (a -> f b) -> SExpr a -> f (SExpr b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SExpr a -> f (SExpr b)
$cp2Traversable :: Foldable SExpr
$cp1Traversable :: Functor SExpr
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 ( a -> Cbpv b -> Cbpv a
(a -> b) -> Cbpv a -> Cbpv b
(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
<$ :: a -> Cbpv b -> Cbpv a
$c<$ :: forall a b. a -> Cbpv b -> Cbpv a
fmap :: (a -> b) -> Cbpv a -> Cbpv b
$cfmap :: forall a b. (a -> b) -> Cbpv a -> Cbpv b
Functor
           , Cbpv a -> Bool
(a -> m) -> Cbpv a -> m
(a -> b -> b) -> b -> Cbpv a -> b
(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 :: Cbpv a -> a
$cproduct :: forall a. Num a => Cbpv a -> a
sum :: Cbpv a -> a
$csum :: forall a. Num a => Cbpv a -> a
minimum :: Cbpv a -> a
$cminimum :: forall a. Ord a => Cbpv a -> a
maximum :: Cbpv a -> a
$cmaximum :: forall a. Ord a => Cbpv a -> a
elem :: a -> Cbpv a -> Bool
$celem :: forall a. Eq a => a -> Cbpv a -> Bool
length :: Cbpv a -> Int
$clength :: forall a. Cbpv a -> Int
null :: Cbpv a -> Bool
$cnull :: forall a. Cbpv a -> Bool
toList :: Cbpv a -> [a]
$ctoList :: forall a. Cbpv a -> [a]
foldl1 :: (a -> a -> a) -> Cbpv a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Cbpv a -> a
foldr1 :: (a -> a -> a) -> Cbpv a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Cbpv a -> a
foldl' :: (b -> a -> b) -> b -> Cbpv a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Cbpv a -> b
foldl :: (b -> a -> b) -> b -> Cbpv a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Cbpv a -> b
foldr' :: (a -> b -> b) -> b -> Cbpv a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Cbpv a -> b
foldr :: (a -> b -> b) -> b -> Cbpv a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Cbpv a -> b
foldMap' :: (a -> m) -> Cbpv a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Cbpv a -> m
foldMap :: (a -> m) -> Cbpv a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Cbpv a -> m
fold :: 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
(a -> f b) -> Cbpv a -> f (Cbpv b)
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 :: Cbpv (m a) -> m (Cbpv a)
$csequence :: forall (m :: * -> *) a. Monad m => Cbpv (m a) -> m (Cbpv a)
mapM :: (a -> m b) -> Cbpv a -> m (Cbpv b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cbpv a -> m (Cbpv b)
sequenceA :: Cbpv (f a) -> f (Cbpv a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Cbpv (f a) -> f (Cbpv a)
traverse :: (a -> f b) -> Cbpv a -> f (Cbpv b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cbpv a -> f (Cbpv b)
$cp2Traversable :: Foldable Cbpv
$cp1Traversable :: Functor Cbpv
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
$(deriveOrd1 ''Cbpv)
$(deriveEq1 ''Cbpv)
$(deriveShow1 ''Cbpv)

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

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

-- | VALIDATE and convert S-expressions to an CBPV intermediate representation.
-- The base type is used for error-reporting; here, we simply report errors as
-- 'String's.
sexpr_to_cbpv :: Show a => Free SExpr a -> Free Cbpv String
sexpr_to_cbpv :: Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Pure a
_) = Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"Unknown error"
sexpr_to_cbpv (Free (IntS Integer
n)) = Cbpv Symbol -> Free Cbpv Symbol
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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
sexpr_to_cbpv (Free (FloatS Double
n)) = Cbpv Symbol -> Free Cbpv Symbol
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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
sexpr_to_cbpv (Free (BoolS Bool
n)) = Cbpv Symbol -> Free Cbpv Symbol
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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
sexpr_to_cbpv (Free (SymS Symbol
n)) = Cbpv Symbol -> Free Cbpv Symbol
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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
sexpr_to_cbpv (Free (ListS [])) = Cbpv Symbol -> Free Cbpv Symbol
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF Cbpv Symbol
forall a. Cbpv a
VoidA
sexpr_to_cbpv (Free (ListS (Free SExpr a
op:[Free SExpr a]
erands))) = case Free SExpr a
op of
  Free (SymS Symbol
"if") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
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
"'if' expression has 3 operands"
      else do
        let cond_cbpv :: Free Cbpv Symbol
cond_cbpv = Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv ([Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0)
        let cond_is_positive :: Bool
cond_is_positive = Free Cbpv Symbol -> Bool
forall a. Free Cbpv a -> Bool
is_positive' Free Cbpv Symbol
cond_cbpv
        if Bool -> Bool
not Bool
cond_is_positive
          then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"Error: conditional expression must be atomic"
          else Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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
                   (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Free SExpr a -> Free Cbpv Symbol)
-> Free SExpr a -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
1)
                   (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Free SExpr a -> Free Cbpv Symbol)
-> Free SExpr a -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
2)
  Free (SymS Symbol
"\\") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
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 Free (ListS [Free SExpr a]
args) = [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0
        Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 ((Free SExpr a -> Symbol) -> [Free SExpr a] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Free (SymS Symbol
s)) -> Symbol
s) [Free SExpr a]
args) (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Free SExpr a -> Free Cbpv Symbol)
-> Free SExpr a -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
1)
  Free (SymS Symbol
"λ") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
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 Free (ListS [Free SExpr a]
args) = [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0
        Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 ((Free SExpr a -> Symbol) -> [Free SExpr a] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Free (SymS Symbol
s)) -> Symbol
s) [Free SExpr a]
args) (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Free SExpr a -> Free Cbpv Symbol)
-> Free SExpr a -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
1)
  Free (SymS Symbol
"let") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
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
"Let binding requires 3 operands"
      else do
        let Free (SymS Symbol
var) = [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0
        Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Free SExpr a -> Free Cbpv Symbol)
-> Free SExpr a -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
1) (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Free SExpr a -> Free Cbpv Symbol)
-> Free SExpr a -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
2 )
  Free (SymS Symbol
"letrec") -> do
    let Free (ListS [Free SExpr a]
bs) = [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0
    [(Symbol, Free Cbpv Symbol)]
bindings <- [Free SExpr a]
-> (Free SExpr a -> 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 [Free SExpr a]
bs ((Free SExpr a -> Free Cbpv (Symbol, Free Cbpv Symbol))
 -> Free Cbpv [(Symbol, Free Cbpv Symbol)])
-> (Free SExpr a -> Free Cbpv (Symbol, Free Cbpv Symbol))
-> Free Cbpv [(Symbol, Free Cbpv Symbol)]
forall a b. (a -> b) -> a -> b
$ \(Free (ListS [Free (SymS Symbol
var), Free SExpr a
exp])) -> do
      (Symbol, Free Cbpv Symbol) -> Free Cbpv (Symbol, Free Cbpv Symbol)
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbol
var, Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv Free SExpr a
exp)
    Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv (Free SExpr a -> Free Cbpv Symbol)
-> Free SExpr a -> Free Cbpv Symbol
forall a b. (a -> b) -> a -> b
$ [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
1)
  Free (SymS Symbol
"shift") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
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
"Not enough arguments for 'shift'"
      else do
        let Free (SymS Symbol
k) = [Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0
        Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv ([Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
1))
  Free (SymS Symbol
"reset") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
erands) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1)
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"'reset' expects one argument"
      else Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv ([Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0))
  Free (SymS Symbol
"!") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
erands) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1)
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"'suspend' expects one argument"
      else Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv ([Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0))
  Free (SymS Symbol
"?") ->
    if (([Free SExpr a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Free SExpr a]
erands) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1)
      then Symbol -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
"'resume' expects one argument"
      else Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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 (Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv ([Free SExpr a]
erands [Free SExpr a] -> Int -> Free SExpr a
forall a. [a] -> Int -> a
!! Int
0))
  Free SExpr a
_ -> do
    -- ensure each operand is atomic
    ([Bool]
all_positive, [Free Cbpv Symbol]
erands') <- (Free SExpr a -> Free Cbpv (Bool, Free Cbpv Symbol))
-> [Free SExpr a] -> Free Cbpv ([Bool], [Free Cbpv Symbol])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (\Free SExpr a
erand -> do
      let erand' :: Free Cbpv Symbol
erand' = Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv Free SExpr a
erand
      let positive :: Bool
positive = Free Cbpv Symbol -> Bool
forall a. Free Cbpv a -> Bool
is_positive' 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')) [Free SExpr a]
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
"Error: operands must always be atomic"
      else let ctor :: [Free Cbpv Symbol] -> Cbpv (Free Cbpv Symbol)
ctor = case Free SExpr a
op of
                        Free (SymS Symbol
sym) ->
                          if Symbol
sym Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Symbol]
op_list
                            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
$ Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv Free SExpr a
op)
                        Free SExpr a
_ -> (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
$ Free SExpr a -> Free Cbpv Symbol
forall a. Show a => Free SExpr a -> Free Cbpv Symbol
sexpr_to_cbpv Free SExpr a
op)
           in  Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Free Cbpv (Free Cbpv Symbol) -> Free Cbpv Symbol)
-> (Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol))
-> Cbpv (Free Cbpv Symbol)
-> Free Cbpv Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cbpv (Free Cbpv Symbol) -> Free Cbpv (Free Cbpv Symbol)
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (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'

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

-- | 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 :: 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 ())
-> m (f (Cofree f ())) -> m (Cofree f ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() () -> f (Cofree f ()) -> Cofree f ()
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:<) (m (f (Cofree f ())) -> m (Cofree f ()))
-> m (f (Cofree f ())) -> m (Cofree f ())
forall a b. (a -> b) -> a -> 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

deps :: Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps :: Map Symbol CbpvExp -> CbpvExp -> [Symbol]
deps Map Symbol CbpvExp
xs CbpvExp
expr = CbpvExp -> [Symbol]
go CbpvExp
expr 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 -> if Symbol -> [Symbol] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Symbol
sym [Symbol]
op_list
      then [Symbol
sym]
      else []
    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  ((CbpvExp -> [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]) -> [CbpvExp] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ ((Symbol, CbpvExp) -> CbpvExp) -> [(Symbol, CbpvExp)] -> [CbpvExp]
forall a b. (a -> b) -> [a] -> [b]
map (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
_ = []