-- | This is a helper module that enables the use of let-bound
-- variables in your S-expression.


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.SCargot.LetBind
    ( -- $intro
      -- * Automatically finding let bindings
      discoverLetBindings
    , DiscoveryGuide(..)
    , nativeGuide
      -- * Expanding
    , letExpand
    )
    where

import           Control.Applicative
import qualified Data.Foldable as F
import           Data.Function (on)
import           Data.List ( sortBy, intercalate )
import           Data.Maybe
import           Data.Monoid
import           Data.SCargot.Repr
import           Data.String
import           Data.Traversable ( mapAccumL )
import           Data.Tuple


-- | This object provides guidance to the 'discoverLetBindings'
-- function, establishing various parameters for the discovery
-- process.
data DiscoveryGuide a str = Guide
    { forall a str. DiscoveryGuide a str -> Int -> Int
maxLetBinds :: Int -> Int
      -- ^ Maximum number of let bindings to generate.  Given the
      -- total number discovered as input to allow the maximum number
      -- to be intelligently determined.

    , forall a str. DiscoveryGuide a str -> Int
minExprSize :: Int
      -- ^ Minimum sexpr size to be considered for a let variable
      -- binding.  Expressions shorter than this will not be
      -- let-bound.

    , forall a str. DiscoveryGuide a str -> Bool
allowRecursion :: Bool
      -- ^ Allow rec bindings, or just direct let bindings?

    , forall a str. DiscoveryGuide a str -> SExpr a -> Int -> Int
weighting :: SExpr a -> Int -> Int
      -- ^ Given an SExpr sub-expression and the count of occurrences
      -- of that sub-expression, return a weighting value that is used
      -- for sorting the discovered let bindings to choose the most
      -- weighty 'maxLetBinds' for substitution.  A sub-expression
      -- with a weight of zero will be ignored (i.e. not let-bound);
      -- one with a weight of 1000000 or more will always be bound.

    , forall a str. DiscoveryGuide a str -> IsString str => str -> a
letMaker :: (IsString str) => str -> a
      -- ^ Called to generate the "let" statement token itself.

    , forall a str.
DiscoveryGuide a str
-> (IsString str, Monoid str) => str -> SExpr a -> a
labelMaker :: (IsString str, Monoid str) => str -> SExpr a -> a
      -- ^ Called to generate the binding variable name token given
      -- the name. Passed the suggested name that will be used for
      -- this binding and also the sub-expression that will be
      -- referenced.  The return will be placed in an SAtom and used
      -- as the variable to reference the bound sub-expression.

    , forall a str.
DiscoveryGuide a str -> IsString str => a -> Maybe str
extractStr :: (IsString str) => a -> Maybe str
    -- ^ Called to extract a string value.  The returned string should
    -- be the string that will be written when the enclosing
    -- S-expression is printed.  This is used to verify that the
    -- variables names extracted for let-binding are unique with
    -- respect to all other printed references.  A return value of
    -- Nothing permits continuation without uniqueness verification,
    -- but at the risk that variable names will be captured in the
    -- result.
    }


-- | Returns a default 'DiscoveryGuide'.
nativeGuide :: (str -> a) -> (str -> SExpr a -> a) -> DiscoveryGuide a str
nativeGuide :: forall str a.
(str -> a) -> (str -> SExpr a -> a) -> DiscoveryGuide a str
nativeGuide str -> a
letMk str -> SExpr a -> a
labelMk = Guide { maxLetBinds :: Int -> Int
maxLetBinds = forall a b. a -> b -> a
const Int
8
                                  , minExprSize :: Int
minExprSize = Int
5
                                  , allowRecursion :: Bool
allowRecursion = Bool
False
                                  , weighting :: SExpr a -> Int -> Int
weighting = forall a. SExpr a -> Int -> Int
defaultWeighting
                                  , letMaker :: IsString str => str -> a
letMaker = str -> a
letMk
                                  , labelMaker :: (IsString str, Monoid str) => str -> SExpr a -> a
labelMaker = str -> SExpr a -> a
labelMk
                                  , extractStr :: IsString str => a -> Maybe str
extractStr = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
                                  }


-- | Provides a default weighting function for evaluating
-- S-expressions.  The general algorithm here is:
--
--   1. S-expressions beginning with an atom on the left probably use
--      that atom as a function name, and are therefore good
--      candidates for clarity.  These sub-expressions get a baseline
--      value of 100.
--
--   2. The frequency of occurrence matters.  It is 4 times more
--      important than the size of the sub-expression.
--
--   3. Bigger sub-expressions are better candidates than smaller
--      sub-expressions.
defaultWeighting :: SExpr a -> Int -> Int
defaultWeighting :: forall a. SExpr a -> Int -> Int
defaultWeighting SExpr a
subexpr Int
cnt =
    let h :: Int
h = forall (t :: * -> *) a. Foldable t => t a -> Int
F.length SExpr a
subexpr
        baseline :: Int
baseline = case SExpr a
subexpr of
                     (SCons (SAtom a
_) SExpr a
_) -> Int
100
                     SExpr a
_ -> Int
0
    in (Int
baseline forall a. Num a => a -> a -> a
+ Int
h forall a. Num a => a -> a -> a
+ (Int
cnt forall a. Num a => a -> a -> a
* Int
4))


-- | Called to convert a plain S-expression into one with let-bound
-- variables.  The let bindings are "discovered" with the assistance
-- of the guide.
discoverLetBindings :: (Monoid str, IsString str, Eq str, Eq a, Show a) =>
                        DiscoveryGuide a str -> SExpr a -> SExpr a
discoverLetBindings :: forall str a.
(Monoid str, IsString str, Eq str, Eq a, Show a) =>
DiscoveryGuide a str -> SExpr a -> SExpr a
discoverLetBindings DiscoveryGuide a str
guide SExpr a
inp =
    let (MyMap a
inpMap,ExprInfo a
annotInp) = forall a str.
Eq a =>
DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
explore DiscoveryGuide a str
guide forall a. MyMap a
startingLoc SExpr a
inp
        locs :: [Location a]
locs = forall a str.
DiscoveryGuide a str -> ExprInfo a -> [Location a] -> [Location a]
bestBindings DiscoveryGuide a str
guide ExprInfo a
annotInp forall a b. (a -> b) -> a -> b
$ forall a. MyMap a -> [Location a]
points MyMap a
inpMap
        lbn :: [NamedLoc a]
lbn = forall a str.
(Show a, Eq a, IsString str, Monoid str) =>
DiscoveryGuide a str -> SExpr a -> [Location a] -> [NamedLoc a]
assignLBNames DiscoveryGuide a str
guide SExpr a
inp [Location a]
locs
        varNameCollisions :: UniquenessResult a
varNameCollisions = forall str a.
(IsString str, Eq str, Eq a) =>
DiscoveryGuide a str
-> [NamedLoc a] -> SExpr a -> UniquenessResult a
verifyNamesUnique DiscoveryGuide a str
guide [NamedLoc a]
lbn SExpr a
inp
        letPart :: SExpr a
letPart = forall atom. atom -> SExpr atom
SAtom forall a b. (a -> b) -> a -> b
$ forall a str. DiscoveryGuide a str -> IsString str => str -> a
letMaker DiscoveryGuide a str
guide str
"let"
        (SExpr a
lbvdefs, SExpr a
subsInp) = forall a str.
Eq a =>
DiscoveryGuide a str
-> [NamedLoc a] -> ExprInfo a -> (SExpr a, SExpr a)
substLBRefs DiscoveryGuide a str
guide [NamedLoc a]
lbn ExprInfo a
annotInp
    in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null UniquenessResult a
varNameCollisions
       then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NamedLoc a]
lbn
            then SExpr a
inp
            else forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr a
letPart forall a b. (a -> b) -> a -> b
$ forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr a
lbvdefs (forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr a
subsInp forall atom. SExpr atom
SNil)
       else forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => [Location a] -> UniquenessResult a -> [Char]
verificationFailureReport [Location a]
locs UniquenessResult a
varNameCollisions

{- $intro

This module allows let bindings to be introduced into the S-Expression
syntax.

For example, instead of:

>    (concat (if (enabled x) (+ (width x) (width y)) (width y))
>            " meters")

this can be re-written with let bindings:

>    (let ((wy    (width y))
>          (wboth (+ (width x) wy))
>          (wide  (if (enabled x) wboth wy))
>         )
>      (concat wide " meters"))

As S-expressions grow larger, let-binding can help readability for
those expressions.  This module provides the 'discoverLetBindings'
function that will convert an S-expression into one containing
let-bound variables, and the inverse function 'letExpand' which will
expand let-bound variables back into the expression.

>    id = letExpand . discoverLetBindings guide

The typical use is to add let bindings before serializing to
disk, and then expand the bindings after reading from the disk but
before passing to other processing; this process allows the
application using the S-Expressions to be unaware of the let-binding
compression, although it does not obtain corresponding advantages of
the re-use of let-bound variables.

The 'discoverLetBindings' function can be called to automatically
assign let bindings based on a weighting algorithm of discovered
S-expression phrases.  The discovery is guided by parameters provided
by the caller in the 'DiscoveryGuide'; this guide also provides the
functions used to create the variables and the top-level let statement
in the language of the current S-expression.

The 'weighting' function of the 'DiscoveryGuide' can be used to assign
weights to various S-expression phrases: the S-expressions with the
highest weights will be let-bound to variables (up to the
'maxLetBinds' limit).  A weighting value of 0 will cause the
sub-expression to be ignored (never let-bound) and a value equal to or
greater than 1000000 will *always* insert a let-binding, ignoring all
other limits.

-}

alwaysBindWeight :: Int
alwaysBindWeight :: Int
alwaysBindWeight = Int
1000000

bestBindings :: DiscoveryGuide a str -> ExprInfo a -> [Location a] -> [Location a]
bestBindings :: forall a str.
DiscoveryGuide a str -> ExprInfo a -> [Location a] -> [Location a]
bestBindings DiscoveryGuide a str
guide ExprInfo a
exprs [Location a]
locs = [Location a]
getMaxBest
    where getMaxBest :: [Location a]
getMaxBest = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$
                       -- Sometimes a lengthy binding "swallows"
                       -- everything else; skipping over it would
                       -- result in more available bindings.  Try the
                       -- first 3 combinations and take the one
                       -- yielding the most bindings.
                       forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (t :: * -> *) a. Foldable t => t a -> Int
length) forall a b. (a -> b) -> a -> b
$
                       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> [Location a]
getBestSkipping [Int
0..Int
2]
          getBestSkipping :: Int -> [Location a]
getBestSkipping Int
n = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$  -- extract list of Locations
                              -- determine top-set of best bindings to apply
                              forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a.
(Int, (Int, [Location a]))
-> (Int, Location a) -> (Int, (Int, [Location a]))
bestB (Int
n, (Int
maxbinds, [])) forall a b. (a -> b) -> a -> b
$
                              -- sorted by heaviest -> lightest
                              forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$
                              forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
                              forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(/=) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$  -- remove weights of 0
                              -- add weights
                              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Location a
l -> (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a str. DiscoveryGuide a str -> SExpr a -> Int -> Int
weighting DiscoveryGuide a str
guide) forall a b. (a -> b) -> a -> b
$ forall {a}. Location a -> (SExpr a, Int)
lwi Location a
l, Location a
l)) forall a b. (a -> b) -> a -> b
$
                              [Location a]
locs
          -- bestB picks the best N bindings, where the bindings are
          -- already sorted by weight, and optionally skipping an
          -- initial count.  As an override, any binding whose weight
          -- is 1_000_000 or above is *always* included in the
          -- results.
          bestB :: (Int, (Int, [Location a]))
                -> (Int, Location a)
                -> (Int, (Int, [Location a]))
                   -- ^ ((skipcnt, ?), (numRemaining, selectedBinds))
          bestB :: forall a.
(Int, (Int, [Location a]))
-> (Int, Location a) -> (Int, (Int, [Location a]))
bestB acc :: (Int, (Int, [Location a]))
acc@(Int
_, (Int
numRemaining, [Location a]
binds)) (Int
w,Location a
e) =
              let subs :: [ExprInfo a]
subs = forall {a} {a}. Location a -> [Location a] -> [ExprInfo a]
subBindings Location a
e [Location a]
binds
              in if Int
numRemaining forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&&
                     (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExprInfo a]
subs Bool -> Bool -> Bool
|| forall a str. DiscoveryGuide a str -> Bool
allowRecursion DiscoveryGuide a str
guide Bool -> Bool -> Bool
|| Int
w forall a. Ord a => a -> a -> Bool
>= Int
alwaysBindWeight)
                 then forall {a} {p}.
(Ord a, Num a) =>
(Int, (a, [p])) -> Int -> p -> (Int, (a, [p]))
addUnlessSkipping (Int, (Int, [Location a]))
acc Int
w Location a
e
                 else (Int, (Int, [Location a]))
acc
          subBindings :: Location a -> [Location a] -> [ExprInfo a]
subBindings Location a
x = forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a} {a}. Location a -> Location a -> Maybe (ExprInfo a)
isSub Location a
x)
          isSub :: Location a -> Location a -> Maybe (ExprInfo a)
isSub Location a
x Location a
startingFrom = do ExprInfo a
sloc <- forall a. Int -> ExprInfo a -> Maybe (ExprInfo a)
findLocation (forall a. Location a -> Int
locId Location a
startingFrom) ExprInfo a
exprs
                                    forall a. Int -> ExprInfo a -> Maybe (ExprInfo a)
findLocation (forall a. Location a -> Int
locId Location a
x) ExprInfo a
sloc
          addUnlessSkipping :: (Int, (a, [p])) -> Int -> p -> (Int, (a, [p]))
addUnlessSkipping (Int
skip, (a
numRemaining, [p]
binds)) Int
w p
e =
              let addE :: (Int, (a, [p]))
addE = (forall a str. DiscoveryGuide a str -> Int
minExprSize DiscoveryGuide a str
guide, (a
numRemainingforall a. Num a => a -> a -> a
-a
1, p
eforall a. a -> [a] -> [a]
:[p]
binds))
                  skipE :: (Int, (a, [p]))
skipE = (Int
skipforall a. Num a => a -> a -> a
-Int
1, (a
numRemaining, [p]
binds))
              in if Int
w forall a. Ord a => a -> a -> Bool
>= Int
alwaysBindWeight
                 then (Int, (a, [p]))
addE
                 else if a
numRemaining forall a. Ord a => a -> a -> Bool
> a
0 Bool -> Bool -> Bool
&& Int
skip forall a. Eq a => a -> a -> Bool
== Int
0
                      then (Int, (a, [p]))
addE
                      else (Int, (a, [p]))
skipE
          lwi :: Location a -> (SExpr a, Int)
lwi Location a
l = (forall a. Location a -> SExpr a
locExpr Location a
l, forall a. Location a -> Int
locCount Location a
l)
          maxbinds :: Int
maxbinds = forall a str. DiscoveryGuide a str -> Int -> Int
maxLetBinds DiscoveryGuide a str
guide (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Location a]
locs)


type LocationId = Int

data Location a = Location { forall a. Location a -> SExpr a
locExpr :: SExpr a
                           , forall a. Location a -> Int
locCount :: Int
                           , forall a. Location a -> Int
locId :: LocationId
                           }
                deriving Int -> Location a -> ShowS
forall a. Show a => Int -> Location a -> ShowS
forall a. Show a => [Location a] -> ShowS
forall a. Show a => Location a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Location a] -> ShowS
$cshowList :: forall a. Show a => [Location a] -> ShowS
show :: Location a -> [Char]
$cshow :: forall a. Show a => Location a -> [Char]
showsPrec :: Int -> Location a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Location a -> ShowS
Show

data NamedLoc a = NamedLoc { forall a. NamedLoc a -> Int
nlocId :: LocationId
                           , forall a. NamedLoc a -> SExpr a
nlocVar :: SExpr a
                           }
                deriving Int -> NamedLoc a -> ShowS
forall a. Show a => Int -> NamedLoc a -> ShowS
forall a. Show a => [NamedLoc a] -> ShowS
forall a. Show a => NamedLoc a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NamedLoc a] -> ShowS
$cshowList :: forall a. Show a => [NamedLoc a] -> ShowS
show :: NamedLoc a -> [Char]
$cshow :: forall a. Show a => NamedLoc a -> [Char]
showsPrec :: Int -> NamedLoc a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NamedLoc a -> ShowS
Show

data MyMap a = MyMap { forall a. MyMap a -> [Location a]
points :: [Location a]
                     }

startingLoc :: MyMap a
startingLoc :: forall a. MyMap a
startingLoc = forall a. [Location a] -> MyMap a
MyMap []

data ExprInfo a = EINil | EIAtom a | EICons LocationId (ExprInfo a) (ExprInfo a)


explore :: Eq a => DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
explore :: forall a str.
Eq a =>
DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
explore DiscoveryGuide a str
_ MyMap a
mymap SExpr a
SNil = (MyMap a
mymap, forall a. ExprInfo a
EINil)
explore DiscoveryGuide a str
_ MyMap a
mymap (SAtom a
a) = (MyMap a
mymap, forall a. a -> ExprInfo a
EIAtom a
a)
explore DiscoveryGuide a str
guide MyMap a
mymap h :: SExpr a
h@(SCons SExpr a
l SExpr a
r) =
    let (MyMap a
lc,ExprInfo a
le) = forall a str.
Eq a =>
DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
explore DiscoveryGuide a str
guide MyMap a
mymap SExpr a
l
        (MyMap a
rc,ExprInfo a
re) = forall a str.
Eq a =>
DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
explore DiscoveryGuide a str
guide MyMap a
lc SExpr a
r
        (MyMap a
hm,Int
hi) = forall a str.
Eq a =>
DiscoveryGuide a str -> SExpr a -> MyMap a -> (MyMap a, Int)
updateMap DiscoveryGuide a str
guide SExpr a
h MyMap a
rc
    in (MyMap a
hm, forall a. Int -> ExprInfo a -> ExprInfo a -> ExprInfo a
EICons Int
hi ExprInfo a
le ExprInfo a
re)


updateMap :: Eq a => DiscoveryGuide a str -> SExpr a -> MyMap a -> (MyMap a, LocationId)
updateMap :: forall a str.
Eq a =>
DiscoveryGuide a str -> SExpr a -> MyMap a -> (MyMap a, Int)
updateMap DiscoveryGuide a str
guide SExpr a
point MyMap a
mymap =
    let ([Location a]
p, Int
i) = [Location a] -> ([Location a], Int)
addOrUpdate (forall a. MyMap a -> [Location a]
points MyMap a
mymap)
    in (MyMap a
mymap { points :: [Location a]
points = [Location a]
p }, Int
i)
    where addOrUpdate :: [Location a] -> ([Location a], Int)
addOrUpdate [] = ([ Location { locExpr :: SExpr a
locExpr=SExpr a
point, locCount :: Int
locCount=forall {a}. Num a => a -> a
succCnt(Int
0), locId :: Int
locId=Int
lId} ], Int
lId)
          addOrUpdate (Location a
p:[Location a]
ps) = let ([Location a]
sm,Int
si) = [Location a] -> ([Location a], Int)
addOrUpdate [Location a]
ps
                               in if forall a. Location a -> SExpr a
locExpr Location a
p forall a. Eq a => a -> a -> Bool
/= SExpr a
point
                                  then (Location a
p forall a. a -> [a] -> [a]
: [Location a]
sm, Int
si)
                                  else (Location a
p { locCount :: Int
locCount = forall {a}. Num a => a -> a
succCnt(forall a. Location a -> Int
locCount Location a
p) } forall a. a -> [a] -> [a]
: [Location a]
ps, forall a. Location a -> Int
locId Location a
p)
          lId :: Int
lId = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. MyMap a -> [Location a]
points MyMap a
mymap)
          succCnt :: a -> a
succCnt a
n = if forall (t :: * -> *) a. Foldable t => t a -> Int
F.length SExpr a
point forall a. Ord a => a -> a -> Bool
> (forall a str. DiscoveryGuide a str -> Int
minExprSize DiscoveryGuide a str
guide) then a
n forall a. Num a => a -> a -> a
+ a
1 else a
n  -- ignore short SExprs


findLocation :: LocationId -> ExprInfo a -> Maybe (ExprInfo a)
findLocation :: forall a. Int -> ExprInfo a -> Maybe (ExprInfo a)
findLocation Int
loc = forall {a}. ExprInfo a -> Maybe (ExprInfo a)
fndLoc
    where fndLoc :: ExprInfo a -> Maybe (ExprInfo a)
fndLoc ExprInfo a
EINil = forall a. Maybe a
Nothing
          fndLoc (EIAtom a
_) = forall a. Maybe a
Nothing
          fndLoc e :: ExprInfo a
e@(EICons Int
el ExprInfo a
l ExprInfo a
r) = if Int
el forall a. Eq a => a -> a -> Bool
== Int
loc then forall a. a -> Maybe a
Just ExprInfo a
e else ExprInfo a -> Maybe (ExprInfo a)
fndLoc ExprInfo a
l forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExprInfo a -> Maybe (ExprInfo a)
fndLoc ExprInfo a
r


assignLBNames :: (Show a, Eq a, IsString str, Monoid str) =>
                 DiscoveryGuide a str -> SExpr a -> [Location a] -> [NamedLoc a]
assignLBNames :: forall a str.
(Show a, Eq a, IsString str, Monoid str) =>
DiscoveryGuide a str -> SExpr a -> [Location a] -> [NamedLoc a]
assignLBNames DiscoveryGuide a str
guide SExpr a
inp = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {b} {a} {b}.
(Ord b, Num a, Num b, Num b, Show a) =>
(a, b) -> Location a -> ((a, b), NamedLoc a)
mkNamedLoc (Int
1::Int, Int
0::Int)
    where mkNamedLoc :: (a, b) -> Location a -> ((a, b), NamedLoc a)
mkNamedLoc (a
i,b
t) Location a
l = let nm :: a
nm = forall a str.
DiscoveryGuide a str
-> (IsString str, Monoid str) => str -> SExpr a -> a
labelMaker DiscoveryGuide a str
guide str
suggestedName forall a b. (a -> b) -> a -> b
$ forall a. Location a -> SExpr a
locExpr Location a
l
                                   suggestedName :: str
suggestedName = str
"var" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall a. Show a => a -> [Char]
show a
i)
                               in case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (forall a. Eq a => a -> a -> Bool
(==) a
nm) SExpr a
inp of
                                    Maybe a
Nothing -> ((a
iforall a. Num a => a -> a -> a
+a
1,b
0), NamedLoc { nlocId :: Int
nlocId = forall a. Location a -> Int
locId Location a
l
                                                                  , nlocVar :: SExpr a
nlocVar = forall atom. atom -> SExpr atom
SAtom a
nm
                                                                  })
                                    Just a
_ -> if b
t forall a. Ord a => a -> a -> Bool
< b
100
                                              then (a, b) -> Location a -> ((a, b), NamedLoc a)
mkNamedLoc (a
iforall a. Num a => a -> a -> a
+a
1,b
tforall a. Num a => a -> a -> a
+b
1) Location a
l  -- collision, try another varname
                                              else forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Too many failed attempts \
                                                           \to generate a unique let var name: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
nm


type UniquenessResult a = [(NamedLoc a, [Either (NamedLoc a) (SExpr a)])]

verifyNamesUnique :: (IsString str, Eq str, Eq a) =>
                     DiscoveryGuide a str
                  -> [NamedLoc a]
                  -> SExpr a
                  -> UniquenessResult a
verifyNamesUnique :: forall str a.
(IsString str, Eq str, Eq a) =>
DiscoveryGuide a str
-> [NamedLoc a] -> SExpr a -> UniquenessResult a
verifyNamesUnique DiscoveryGuide a str
guide [NamedLoc a]
names SExpr a
sexpr =
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
NamedLoc a
-> [(NamedLoc a, [Either a (SExpr a)])]
-> [(NamedLoc a, [Either a (SExpr a)])]
checkUniqueInExpr (forall {b}. [NamedLoc a] -> [(NamedLoc a, [Either (NamedLoc a) b])]
checkUniqueNames [NamedLoc a]
names) [NamedLoc a]
names
    where
          varname :: SExpr a -> Maybe str
varname (SAtom a
a) = a -> Maybe str
atom2str a
a
          varname SExpr a
_ = forall a. Maybe a
Nothing
          atom2str :: a -> Maybe str
atom2str = forall a str.
DiscoveryGuide a str -> IsString str => a -> Maybe str
extractStr DiscoveryGuide a str
guide
          checkUniqueInExpr :: NamedLoc a
-> [(NamedLoc a, [Either a (SExpr a)])]
-> [(NamedLoc a, [Either a (SExpr a)])]
checkUniqueInExpr NamedLoc a
nloc [(NamedLoc a, [Either a (SExpr a)])]
dups =
              let locname :: Maybe str
locname = SExpr a -> Maybe str
varname forall a b. (a -> b) -> a -> b
$ forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
nloc
                  addDup :: [(NamedLoc a, [Either a t])] -> t -> [(NamedLoc a, [Either a t])]
addDup [] t
otherexp = [(NamedLoc a
nloc, [forall a b. b -> Either a b
Right t
otherexp])]
                  addDup ((NamedLoc a
l,[Either a t]
dl):[(NamedLoc a, [Either a t])]
dls) t
subexp = if forall a. NamedLoc a -> Int
nlocId NamedLoc a
l forall a. Eq a => a -> a -> Bool
== forall a. NamedLoc a -> Int
nlocId NamedLoc a
nloc
                                               then (NamedLoc a
nloc, forall a b. b -> Either a b
Right t
subexp forall a. a -> [a] -> [a]
: [Either a t]
dl) forall a. a -> [a] -> [a]
: [(NamedLoc a, [Either a t])]
dls
                                               else [(NamedLoc a, [Either a t])] -> t -> [(NamedLoc a, [Either a t])]
addDup [(NamedLoc a, [Either a t])]
dls t
subexp
                  matchExpHead :: str -> SExpr a -> Maybe (SExpr a)
matchExpHead str
s e :: SExpr a
e@(SAtom a
a) = if forall a. a -> Maybe a
Just str
s forall a. Eq a => a -> a -> Bool
== a -> Maybe str
atom2str a
a
                                               then forall a. a -> Maybe a
Just SExpr a
e
                                               else forall a. Maybe a
Nothing
                  matchExpHead str
s e :: SExpr a
e@(SCons (SAtom a
a) SExpr a
r) = if forall a. a -> Maybe a
Just str
s forall a. Eq a => a -> a -> Bool
== a -> Maybe str
atom2str a
a
                                                         then forall a. a -> Maybe a
Just SExpr a
e
                                                         else str -> SExpr a -> Maybe (SExpr a)
matchExpHead str
s SExpr a
r
                  matchExpHead str
_ SExpr a
SNil = forall a. Maybe a
Nothing
                  matchExpHead str
s (SCons SExpr a
l SExpr a
r) = str -> SExpr a -> Maybe (SExpr a)
matchExpHead str
s SExpr a
l forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> str -> SExpr a -> Maybe (SExpr a)
matchExpHead str
s SExpr a
r
              in case Maybe str
locname of
                   Maybe str
Nothing -> [(NamedLoc a, [Either a (SExpr a)])]
dups
                   Just str
nstr -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(NamedLoc a, [Either a (SExpr a)])]
dups (forall {a} {t}.
[(NamedLoc a, [Either a t])] -> t -> [(NamedLoc a, [Either a t])]
addDup [(NamedLoc a, [Either a (SExpr a)])]
dups) forall a b. (a -> b) -> a -> b
$ str -> SExpr a -> Maybe (SExpr a)
matchExpHead str
nstr SExpr a
sexpr

          checkUniqueNames :: [NamedLoc a] -> [(NamedLoc a, [Either (NamedLoc a) b])]
checkUniqueNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. [(a, [a])] -> ([a], [(a, [a])])
splitDups forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
Eq a =>
NamedLoc a
-> [(NamedLoc a, [NamedLoc a])] -> [(NamedLoc a, [NamedLoc a])]
combineDups []
          combineDups :: NamedLoc a
-> [(NamedLoc a, [NamedLoc a])] -> [(NamedLoc a, [NamedLoc a])]
combineDups NamedLoc a
nloc [] = [(NamedLoc a
nloc, [])]
          combineDups NamedLoc a
nloc ((NamedLoc a
d,[NamedLoc a]
ls):[(NamedLoc a, [NamedLoc a])]
ds) = if forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
nloc forall a. Eq a => a -> a -> Bool
== forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
d
                                         then (NamedLoc a
d,NamedLoc a
nlocforall a. a -> [a] -> [a]
:[NamedLoc a]
ls)forall a. a -> [a] -> [a]
:[(NamedLoc a, [NamedLoc a])]
ds
                                         else (NamedLoc a
d,[NamedLoc a]
ls) forall a. a -> [a] -> [a]
: NamedLoc a
-> [(NamedLoc a, [NamedLoc a])] -> [(NamedLoc a, [NamedLoc a])]
combineDups NamedLoc a
nloc [(NamedLoc a, [NamedLoc a])]
ds
          splitDups :: [(a, [a])] -> ([a], [(a, [a])])
splitDups = let isDup :: (a, [a]) -> ([a], [(a, [a])]) -> ([a], [(a, [a])])
isDup (a
nloc, []) ([a]
u,[(a, [a])]
d) = (a
nlocforall a. a -> [a] -> [a]
:[a]
u, [(a, [a])]
d)
                          isDup (a, [a])
e ([a]
u,[(a, [a])]
d) = ([a]
u, (a, [a])
eforall a. a -> [a] -> [a]
:[(a, [a])]
d)
                      in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {a}. (a, [a]) -> ([a], [(a, [a])]) -> ([a], [(a, [a])])
isDup ([],[])


verificationFailureReport :: Show a => [Location a] -> UniquenessResult a -> String
verificationFailureReport :: forall a. Show a => [Location a] -> UniquenessResult a -> [Char]
verificationFailureReport [Location a]
locs = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a} {a}.
(Show a, Show a, Show a) =>
(NamedLoc a, [Either (NamedLoc a) (SExpr a)]) -> [Char]
vfRep
    where vfRep :: (NamedLoc a, [Either (NamedLoc a) (SExpr a)]) -> [Char]
vfRep (NamedLoc a
l, [Either (NamedLoc a) (SExpr a)]
vf) =
              let fs :: [[Char]]
fs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a}.
(Show a, Show a) =>
Either (NamedLoc a) (SExpr a) -> [Char]
fl [Either (NamedLoc a) (SExpr a)]
vf
                  fl :: Either (NamedLoc a) (SExpr a) -> [Char]
fl (Left NamedLoc a
nloc) = forall a. Show a => NamedLoc a -> [Char]
var NamedLoc a
nloc
                  fl (Right SExpr a
e) = [Char]
"other portion of S-expression: "
                                 forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. Int -> SExpr a -> SExpr a
truncateExpr Int
4 SExpr a
e)
                  var :: NamedLoc a -> [Char]
var NamedLoc a
v = [Char]
"let variable \"" forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
v)
                          forall a. Semigroup a => a -> a -> a
<> [Char]
"\" ["
                          forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ (forall a. Int -> SExpr a -> SExpr a
truncateExpr Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Location a -> SExpr a
locExpr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                   forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (forall a. Eq a => a -> a -> Bool
(==) (forall a. NamedLoc a -> Int
nlocId NamedLoc a
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Location a -> Int
locId) [Location a]
locs)
                          forall a. Semigroup a => a -> a -> a
<> [Char]
" ...]"
              in forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n    " forall a b. (a -> b) -> a -> b
$
                     ([Char]
"ERR: duplicated " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => NamedLoc a -> [Char]
var NamedLoc a
l) forall a. Semigroup a => a -> a -> a
<> [Char]
" at: ") forall a. a -> [a] -> [a]
: [[Char]]
fs

truncateExpr :: Int -> SExpr a -> SExpr a
truncateExpr :: forall a. Int -> SExpr a -> SExpr a
truncateExpr Int
_ SExpr a
SNil = forall atom. SExpr atom
SNil
truncateExpr Int
_ e :: SExpr a
e@(SAtom a
_) = SExpr a
e
truncateExpr Int
0 SExpr a
_ = forall atom. SExpr atom
SNil
truncateExpr Int
n (SCons SExpr a
l SExpr a
r) = let trunc :: SExpr a -> SExpr a
trunc = forall a. Int -> SExpr a -> SExpr a
truncateExpr (Int
n forall a. Num a => a -> a -> a
- Int
1)
                             in forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (forall {a}. SExpr a -> SExpr a
trunc SExpr a
l) (forall {a}. SExpr a -> SExpr a
trunc SExpr a
r)

substLBRefs :: Eq a =>
               DiscoveryGuide a str -> [NamedLoc a] -> ExprInfo a
            -> (SExpr a, SExpr a)
               -- ^ (varbindings, exprwithvars)
substLBRefs :: forall a str.
Eq a =>
DiscoveryGuide a str
-> [NamedLoc a] -> ExprInfo a -> (SExpr a, SExpr a)
substLBRefs DiscoveryGuide a str
_ [NamedLoc a]
nlocs = forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(SExpr a, SExpr a)] -> SExpr a
declVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SExpr a, SExpr a)]
-> ExprInfo a -> ([(SExpr a, SExpr a)], SExpr a)
subsRefs []
    where subsRefs :: [(SExpr a, SExpr a)]
-> ExprInfo a -> ([(SExpr a, SExpr a)], SExpr a)
subsRefs [(SExpr a, SExpr a)]
b ExprInfo a
EINil = ([(SExpr a, SExpr a)]
b, forall atom. SExpr atom
SNil)
          subsRefs [(SExpr a, SExpr a)]
b (EIAtom a
a) = ([(SExpr a, SExpr a)]
b, forall atom. atom -> SExpr atom
SAtom a
a)
          subsRefs [(SExpr a, SExpr a)]
b (EICons Int
i ExprInfo a
l ExprInfo a
r) = let ([(SExpr a, SExpr a)]
b',SExpr a
l') = [(SExpr a, SExpr a)]
-> ExprInfo a -> ([(SExpr a, SExpr a)], SExpr a)
subsRefs [(SExpr a, SExpr a)]
b ExprInfo a
l
                                          ([(SExpr a, SExpr a)]
c',SExpr a
r') = [(SExpr a, SExpr a)]
-> ExprInfo a -> ([(SExpr a, SExpr a)], SExpr a)
subsRefs [(SExpr a, SExpr a)]
b' ExprInfo a
r
                                          here :: SExpr a
here = forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr a
l' SExpr a
r'
                                      in case Int -> Maybe (NamedLoc a)
hasBinding Int
i of
                                           Maybe (NamedLoc a)
Nothing -> ([(SExpr a, SExpr a)]
c', SExpr a
here)
                                           Just NamedLoc a
loc -> (((forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
loc), SExpr a
here) forall a. a -> [a] -> [a]
: [(SExpr a, SExpr a)]
c', (forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
loc) forall atom. SExpr atom
SNil))
          hasBinding :: Int -> Maybe (NamedLoc a)
hasBinding Int
i = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (forall a. Eq a => a -> a -> Bool
(==) Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedLoc a -> Int
nlocId) [NamedLoc a]
nlocs
          declVars :: [(SExpr a, SExpr a)] -> SExpr a
declVars = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {atom}. SExpr atom -> (SExpr atom, SExpr atom) -> SExpr atom
addVar forall atom. SExpr atom
SNil forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a} {b}. Eq a => [(a, b)] -> (a, b) -> [(a, b)]
addVarIfUnique []
          addVarIfUnique :: [(a, b)] -> (a, b) -> [(a, b)]
addVarIfUnique [(a, b)]
vl v :: (a, b)
v@(a
vn,b
_) = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
vn [(a, b)]
vl of
                                         Maybe b
Nothing -> (a, b)
v forall a. a -> [a] -> [a]
: [(a, b)]
vl
                                         Just b
_ -> [(a, b)]
vl
          addVar :: SExpr atom -> (SExpr atom, SExpr atom) -> SExpr atom
addVar SExpr atom
vl (SExpr atom
vn,SExpr atom
vv) = forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
vn (forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
vv forall atom. SExpr atom
SNil)) SExpr atom
vl


-- ----------------------------------------------------------------------

-- | The 'letExpand' function is passed an S-expression that (may)
-- contain let-bound variables and will return an equivalent
-- S-expression that does not contain any let bindings, where let
-- bindings have been expanded into the expression.
letExpand :: (Eq a, Show a, Eq str, IsString str) =>
             (a -> Maybe str) -> SExpr a -> SExpr a
letExpand :: forall a str.
(Eq a, Show a, Eq str, IsString str) =>
(a -> Maybe str) -> SExpr a -> SExpr a
letExpand a -> Maybe str
atomToText = SExpr a -> SExpr a
findExpLet
    where findExpLet :: SExpr a -> SExpr a
findExpLet (SCons (SAtom a
a) (SCons SExpr a
lbvdefs (SCons SExpr a
subsInp SExpr a
SNil))) =
              if a -> Maybe str
atomToText a
a forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just str
"let"
              then SExpr a -> SExpr a -> SExpr a
expLet SExpr a
lbvdefs SExpr a
subsInp
              else forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (forall atom. atom -> SExpr atom
SAtom a
a) (forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (SExpr a -> SExpr a
findExpLet SExpr a
lbvdefs) (forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (SExpr a -> SExpr a
findExpLet SExpr a
subsInp) forall atom. SExpr atom
SNil))
          findExpLet SExpr a
e = SExpr a
e
          expLet :: SExpr a -> SExpr a -> SExpr a
expLet SExpr a
lb = forall {atom}.
Eq atom =>
[(SExpr atom, SExpr atom)] -> SExpr atom -> SExpr atom
expandWith (SExpr a -> [(SExpr a, SExpr a)]
bindings SExpr a
lb)
          bindings :: SExpr a -> [(SExpr a, SExpr a)]
bindings = forall {atom}.
Show atom =>
[(SExpr atom, SExpr atom)]
-> SExpr atom -> [(SExpr atom, SExpr atom)]
parseVar []
          parseVar :: [(SExpr atom, SExpr atom)]
-> SExpr atom -> [(SExpr atom, SExpr atom)]
parseVar [(SExpr atom, SExpr atom)]
vdefs (SCons (SCons SExpr atom
vn (SCons SExpr atom
vv SExpr atom
SNil)) SExpr atom
r) = (SExpr atom
vn, SExpr atom
vv) forall a. a -> [a] -> [a]
: [(SExpr atom, SExpr atom)]
-> SExpr atom -> [(SExpr atom, SExpr atom)]
parseVar [(SExpr atom, SExpr atom)]
vdefs SExpr atom
r
          parseVar [(SExpr atom, SExpr atom)]
vdefs SExpr atom
SNil = [(SExpr atom, SExpr atom)]
vdefs
          parseVar [(SExpr atom, SExpr atom)]
_ SExpr atom
e = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a var, got: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show SExpr atom
e
          expandWith :: [(SExpr atom, SExpr atom)] -> SExpr atom -> SExpr atom
expandWith [(SExpr atom, SExpr atom)]
_ SExpr atom
SNil = forall atom. SExpr atom
SNil
          expandWith [(SExpr atom, SExpr atom)]
vdefs e :: SExpr atom
e@(SCons v :: SExpr atom
v@(SAtom atom
_) SExpr atom
SNil) =
              case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SExpr atom
v [(SExpr atom, SExpr atom)]
vdefs of
                Maybe (SExpr atom)
Nothing -> SExpr atom
e
                Just SExpr atom
vv -> [(SExpr atom, SExpr atom)] -> SExpr atom -> SExpr atom
expandWith [(SExpr atom, SExpr atom)]
vdefs SExpr atom
vv
          expandWith [(SExpr atom, SExpr atom)]
vdefs e :: SExpr atom
e@(SCons SExpr atom
l SExpr atom
r) =
              case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SExpr atom
e [(SExpr atom, SExpr atom)]
vdefs of
                Maybe (SExpr atom)
Nothing -> forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons ([(SExpr atom, SExpr atom)] -> SExpr atom -> SExpr atom
expandWith [(SExpr atom, SExpr atom)]
vdefs SExpr atom
l) ([(SExpr atom, SExpr atom)] -> SExpr atom -> SExpr atom
expandWith [(SExpr atom, SExpr atom)]
vdefs SExpr atom
r)
                Just SExpr atom
vv -> [(SExpr atom, SExpr atom)] -> SExpr atom -> SExpr atom
expandWith [(SExpr atom, SExpr atom)]
vdefs SExpr atom
vv
          expandWith [(SExpr atom, SExpr atom)]
_ e :: SExpr atom
e@(SAtom atom
_) = SExpr atom
e