-- | 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 qualified Data.List.NonEmpty as NE
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 = Int -> Int -> Int
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 = SExpr a -> Int -> Int
forall a. SExpr a -> Int -> Int
defaultWeighting
                                  , letMaker :: IsString str => str -> a
letMaker = str -> a
IsString str => str -> a
letMk
                                  , labelMaker :: (IsString str, Monoid str) => str -> SExpr a -> a
labelMaker = str -> SExpr a -> a
(IsString str, Monoid str) => str -> SExpr a -> a
labelMk
                                  , extractStr :: IsString str => a -> Maybe str
extractStr = Maybe str -> a -> Maybe str
forall a b. a -> b -> a
const Maybe str
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 = SExpr a -> Int
forall a. SExpr a -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
cnt Int -> Int -> Int
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) = DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
forall a str.
Eq a =>
DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
explore DiscoveryGuide a str
guide MyMap a
forall a. MyMap a
startingLoc SExpr a
inp
        locs :: [Location a]
locs = DiscoveryGuide a str -> ExprInfo a -> [Location a] -> [Location a]
forall a str.
DiscoveryGuide a str -> ExprInfo a -> [Location a] -> [Location a]
bestBindings DiscoveryGuide a str
guide ExprInfo a
annotInp ([Location a] -> [Location a]) -> [Location a] -> [Location a]
forall a b. (a -> b) -> a -> b
$ MyMap a -> [Location a]
forall a. MyMap a -> [Location a]
points MyMap a
inpMap
        lbn :: [NamedLoc a]
lbn = DiscoveryGuide a str -> SExpr a -> [Location a] -> [NamedLoc a]
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 = DiscoveryGuide a str
-> [NamedLoc a] -> SExpr a -> UniquenessResult a
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 = a -> SExpr a
forall atom. atom -> SExpr atom
SAtom (a -> SExpr a) -> a -> SExpr a
forall a b. (a -> b) -> a -> b
$ DiscoveryGuide a str -> IsString str => str -> a
forall a str. DiscoveryGuide a str -> IsString str => str -> a
letMaker DiscoveryGuide a str
guide str
"let"
        (SExpr a
lbvdefs, SExpr a
subsInp) = DiscoveryGuide a str
-> [NamedLoc a] -> ExprInfo a -> (SExpr a, SExpr a)
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 UniquenessResult a -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null UniquenessResult a
varNameCollisions
       then if [NamedLoc a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NamedLoc a]
lbn
            then SExpr a
inp
            else SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr a
letPart (SExpr a -> SExpr a) -> SExpr a -> SExpr a
forall a b. (a -> b) -> a -> b
$ SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr a
lbvdefs (SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr a
subsInp SExpr a
forall atom. SExpr atom
SNil)
       else [Char] -> SExpr a
forall a. HasCallStack => [Char] -> a
error ([Char] -> SExpr a) -> [Char] -> SExpr a
forall a b. (a -> b) -> a -> b
$ [Location a] -> UniquenessResult a -> [Char]
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 = NonEmpty [Location a] -> [Location a]
forall a. NonEmpty a -> a
NE.head (NonEmpty [Location a] -> [Location a])
-> NonEmpty [Location a] -> [Location a]
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.
                       ([Location a] -> [Location a] -> Ordering)
-> NonEmpty [Location a] -> NonEmpty [Location a]
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ([Location a] -> Int)
-> [Location a]
-> [Location a]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` [Location a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) (NonEmpty [Location a] -> NonEmpty [Location a])
-> NonEmpty [Location a] -> NonEmpty [Location a]
forall a b. (a -> b) -> a -> b
$
                       (Int -> [Location a]) -> NonEmpty Int -> NonEmpty [Location a]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> [Location a]
getBestSkipping (NonEmpty Int -> NonEmpty [Location a])
-> NonEmpty Int -> NonEmpty [Location a]
forall a b. (a -> b) -> a -> b
$
                       Int
0 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
NE.:| [Int
1, Int
2]
          getBestSkipping :: Int -> [Location a]
getBestSkipping Int
n = (Int, [Location a]) -> [Location a]
forall a b. (a, b) -> b
snd ((Int, [Location a]) -> [Location a])
-> (Int, [Location a]) -> [Location a]
forall a b. (a -> b) -> a -> b
$ (Int, (Int, [Location a])) -> (Int, [Location a])
forall a b. (a, b) -> b
snd ((Int, (Int, [Location a])) -> (Int, [Location a]))
-> (Int, (Int, [Location a])) -> (Int, [Location a])
forall a b. (a -> b) -> a -> b
$  -- extract list of Locations
                              -- determine top-set of best bindings to apply
                              ((Int, (Int, [Location a]))
 -> (Int, Location a) -> (Int, (Int, [Location a])))
-> (Int, (Int, [Location a]))
-> [(Int, Location a)]
-> (Int, (Int, [Location a]))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Int, (Int, [Location a]))
-> (Int, Location a) -> (Int, (Int, [Location a]))
forall a.
(Int, (Int, [Location a]))
-> (Int, Location a) -> (Int, (Int, [Location a]))
bestB (Int
n, (Int
maxbinds, [])) ([(Int, Location a)] -> (Int, (Int, [Location a])))
-> [(Int, Location a)] -> (Int, (Int, [Location a]))
forall a b. (a -> b) -> a -> b
$
                              -- sorted by heaviest -> lightest
                              [(Int, Location a)] -> [(Int, Location a)]
forall a. [a] -> [a]
reverse ([(Int, Location a)] -> [(Int, Location a)])
-> [(Int, Location a)] -> [(Int, Location a)]
forall a b. (a -> b) -> a -> b
$
                              ((Int, Location a) -> (Int, Location a) -> Ordering)
-> [(Int, Location a)] -> [(Int, Location a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Int, Location a) -> Int)
-> (Int, Location a)
-> (Int, Location a)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, Location a) -> Int
forall a b. (a, b) -> a
fst) ([(Int, Location a)] -> [(Int, Location a)])
-> [(Int, Location a)] -> [(Int, Location a)]
forall a b. (a -> b) -> a -> b
$
                              ((Int, Location a) -> Bool)
-> [(Int, Location a)] -> [(Int, Location a)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(/=) Int
0 (Int -> Bool)
-> ((Int, Location a) -> Int) -> (Int, Location a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Location a) -> Int
forall a b. (a, b) -> a
fst) ([(Int, Location a)] -> [(Int, Location a)])
-> [(Int, Location a)] -> [(Int, Location a)]
forall a b. (a -> b) -> a -> b
$  -- remove weights of 0
                              -- add weights
                              (Location a -> (Int, Location a))
-> [Location a] -> [(Int, Location a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Location a
l -> ((SExpr a -> Int -> Int) -> (SExpr a, Int) -> Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DiscoveryGuide a str -> SExpr a -> Int -> Int
forall a str. DiscoveryGuide a str -> SExpr a -> Int -> Int
weighting DiscoveryGuide a str
guide) ((SExpr a, Int) -> Int) -> (SExpr a, Int) -> Int
forall a b. (a -> b) -> a -> b
$ Location a -> (SExpr a, Int)
forall {a}. Location a -> (SExpr a, Int)
lwi Location a
l, Location a
l)) ([Location a] -> [(Int, Location a)])
-> [Location a] -> [(Int, Location a)]
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 = Location a -> [Location a] -> [ExprInfo a]
forall {a} {a}. Location a -> [Location a] -> [ExprInfo a]
subBindings Location a
e [Location a]
binds
              in if Int
numRemaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&&
                     ([ExprInfo a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExprInfo a]
subs Bool -> Bool -> Bool
|| DiscoveryGuide a str -> Bool
forall a str. DiscoveryGuide a str -> Bool
allowRecursion DiscoveryGuide a str
guide Bool -> Bool -> Bool
|| Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
alwaysBindWeight)
                 then (Int, (Int, [Location a]))
-> Int -> Location a -> (Int, (Int, [Location a]))
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 = [Maybe (ExprInfo a)] -> [ExprInfo a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ExprInfo a)] -> [ExprInfo a])
-> ([Location a] -> [Maybe (ExprInfo a)])
-> [Location a]
-> [ExprInfo a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Location a -> Maybe (ExprInfo a))
-> [Location a] -> [Maybe (ExprInfo a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location a -> Location a -> Maybe (ExprInfo a)
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 <- Int -> ExprInfo a -> Maybe (ExprInfo a)
forall a. Int -> ExprInfo a -> Maybe (ExprInfo a)
findLocation (Location a -> Int
forall a. Location a -> Int
locId Location a
startingFrom) ExprInfo a
exprs
                                    Int -> ExprInfo a -> Maybe (ExprInfo a)
forall a. Int -> ExprInfo a -> Maybe (ExprInfo a)
findLocation (Location a -> Int
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 = (DiscoveryGuide a str -> Int
forall a str. DiscoveryGuide a str -> Int
minExprSize DiscoveryGuide a str
guide, (a
numRemaininga -> a -> a
forall a. Num a => a -> a -> a
-a
1, p
ep -> [p] -> [p]
forall a. a -> [a] -> [a]
:[p]
binds))
                  skipE :: (Int, (a, [p]))
skipE = (Int
skipInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1, (a
numRemaining, [p]
binds))
              in if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
alwaysBindWeight
                 then (Int, (a, [p]))
addE
                 else if a
numRemaining a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 Bool -> Bool -> Bool
&& Int
skip Int -> Int -> Bool
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 = (Location a -> SExpr a
forall a. Location a -> SExpr a
locExpr Location a
l, Location a -> Int
forall a. Location a -> Int
locCount Location a
l)
          maxbinds :: Int
maxbinds = DiscoveryGuide a str -> Int -> Int
forall a str. DiscoveryGuide a str -> Int -> Int
maxLetBinds DiscoveryGuide a str
guide ([Location a] -> Int
forall a. [a] -> Int
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
[Location a] -> ShowS
Location a -> [Char]
(Int -> Location a -> ShowS)
-> (Location a -> [Char])
-> ([Location a] -> ShowS)
-> Show (Location a)
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
$cshowsPrec :: forall a. Show a => Int -> Location a -> ShowS
showsPrec :: Int -> Location a -> ShowS
$cshow :: forall a. Show a => Location a -> [Char]
show :: Location a -> [Char]
$cshowList :: forall a. Show a => [Location a] -> ShowS
showList :: [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
[NamedLoc a] -> ShowS
NamedLoc a -> [Char]
(Int -> NamedLoc a -> ShowS)
-> (NamedLoc a -> [Char])
-> ([NamedLoc a] -> ShowS)
-> Show (NamedLoc a)
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
$cshowsPrec :: forall a. Show a => Int -> NamedLoc a -> ShowS
showsPrec :: Int -> NamedLoc a -> ShowS
$cshow :: forall a. Show a => NamedLoc a -> [Char]
show :: NamedLoc a -> [Char]
$cshowList :: forall a. Show a => [NamedLoc a] -> ShowS
showList :: [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 = [Location a] -> MyMap a
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, ExprInfo a
forall a. ExprInfo a
EINil)
explore DiscoveryGuide a str
_ MyMap a
mymap (SAtom a
a) = (MyMap a
mymap, a -> ExprInfo a
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) = DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
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) = DiscoveryGuide a str -> MyMap a -> SExpr a -> (MyMap a, ExprInfo a)
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) = DiscoveryGuide a str -> SExpr a -> MyMap a -> (MyMap a, Int)
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, Int -> ExprInfo a -> ExprInfo a -> ExprInfo a
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 (MyMap a -> [Location a]
forall a. MyMap a -> [Location a]
points MyMap a
mymap)
    in (MyMap a
mymap { points = p }, Int
i)
    where addOrUpdate :: [Location a] -> ([Location a], Int)
addOrUpdate [] = ([ Location { locExpr :: SExpr a
locExpr=SExpr a
point, locCount :: Int
locCount=Int -> Int
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 Location a -> SExpr a
forall a. Location a -> SExpr a
locExpr Location a
p SExpr a -> SExpr a -> Bool
forall a. Eq a => a -> a -> Bool
/= SExpr a
point
                                  then (Location a
p Location a -> [Location a] -> [Location a]
forall a. a -> [a] -> [a]
: [Location a]
sm, Int
si)
                                  else (Location a
p { locCount = succCnt(locCount p) } Location a -> [Location a] -> [Location a]
forall a. a -> [a] -> [a]
: [Location a]
ps, Location a -> Int
forall a. Location a -> Int
locId Location a
p)
          lId :: Int
lId = [Location a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (MyMap a -> [Location a]
forall a. MyMap a -> [Location a]
points MyMap a
mymap)
          succCnt :: a -> a
succCnt a
n = if SExpr a -> Int
forall a. SExpr a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
F.length SExpr a
point Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (DiscoveryGuide a str -> Int
forall a str. DiscoveryGuide a str -> Int
minExprSize DiscoveryGuide a str
guide) then a
n a -> a -> a
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 = ExprInfo a -> Maybe (ExprInfo a)
forall {a}. ExprInfo a -> Maybe (ExprInfo a)
fndLoc
    where fndLoc :: ExprInfo a -> Maybe (ExprInfo a)
fndLoc ExprInfo a
EINil = Maybe (ExprInfo a)
forall a. Maybe a
Nothing
          fndLoc (EIAtom a
_) = Maybe (ExprInfo a)
forall a. Maybe a
Nothing
          fndLoc e :: ExprInfo a
e@(EICons Int
el ExprInfo a
l ExprInfo a
r) = if Int
el Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
loc then ExprInfo a -> Maybe (ExprInfo a)
forall a. a -> Maybe a
Just ExprInfo a
e else ExprInfo a -> Maybe (ExprInfo a)
fndLoc ExprInfo a
l Maybe (ExprInfo a) -> Maybe (ExprInfo a) -> Maybe (ExprInfo a)
forall a. Maybe a -> Maybe a -> Maybe a
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 = ((Int, Int), [NamedLoc a]) -> [NamedLoc a]
forall a b. (a, b) -> b
snd (((Int, Int), [NamedLoc a]) -> [NamedLoc a])
-> ([Location a] -> ((Int, Int), [NamedLoc a]))
-> [Location a]
-> [NamedLoc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> Location a -> ((Int, Int), NamedLoc a))
-> (Int, Int) -> [Location a] -> ((Int, Int), [NamedLoc a])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Int, Int) -> Location a -> ((Int, Int), NamedLoc a)
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 = DiscoveryGuide a str
-> (IsString str, Monoid str) => str -> SExpr a -> a
forall a str.
DiscoveryGuide a str
-> (IsString str, Monoid str) => str -> SExpr a -> a
labelMaker DiscoveryGuide a str
guide str
suggestedName (SExpr a -> a) -> SExpr a -> a
forall a b. (a -> b) -> a -> b
$ Location a -> SExpr a
forall a. Location a -> SExpr a
locExpr Location a
l
                                   suggestedName :: str
suggestedName = str
"var" str -> str -> str
forall a. Semigroup a => a -> a -> a
<> [Char] -> str
forall a. IsString a => [Char] -> a
fromString (a -> [Char]
forall a. Show a => a -> [Char]
show a
i)
                               in case (a -> Bool) -> SExpr a -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) a
nm) SExpr a
inp of
                                    Maybe a
Nothing -> ((a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1,b
0), NamedLoc { nlocId :: Int
nlocId = Location a -> Int
forall a. Location a -> Int
locId Location a
l
                                                                  , nlocVar :: SExpr a
nlocVar = a -> SExpr a
forall atom. atom -> SExpr atom
SAtom a
nm
                                                                  })
                                    Just a
_ -> if b
t b -> b -> Bool
forall a. Ord a => a -> a -> Bool
< b
100
                                              then (a, b) -> Location a -> ((a, b), NamedLoc a)
mkNamedLoc (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1,b
tb -> b -> b
forall a. Num a => a -> a -> a
+b
1) Location a
l  -- collision, try another varname
                                              else [Char] -> ((a, b), NamedLoc a)
forall a. HasCallStack => [Char] -> a
error ([Char] -> ((a, b), NamedLoc a)) -> [Char] -> ((a, b), NamedLoc a)
forall a b. (a -> b) -> a -> b
$ [Char]
"Too many failed attempts \
                                                           \to generate a unique let var name: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> [Char]
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 =
    (NamedLoc a -> UniquenessResult a -> UniquenessResult a)
-> UniquenessResult a -> [NamedLoc a] -> UniquenessResult a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamedLoc a -> UniquenessResult a -> UniquenessResult a
forall {a}.
NamedLoc a
-> [(NamedLoc a, [Either a (SExpr a)])]
-> [(NamedLoc a, [Either a (SExpr a)])]
checkUniqueInExpr ([NamedLoc a] -> UniquenessResult a
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
_ = Maybe str
forall a. Maybe a
Nothing
          atom2str :: a -> Maybe str
atom2str = DiscoveryGuide a str -> IsString str => a -> Maybe str
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 (SExpr a -> Maybe str) -> SExpr a -> Maybe str
forall a b. (a -> b) -> a -> b
$ NamedLoc a -> SExpr a
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, [t -> Either a t
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 NamedLoc a -> Int
forall a. NamedLoc a -> Int
nlocId NamedLoc a
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== NamedLoc a -> Int
forall a. NamedLoc a -> Int
nlocId NamedLoc a
nloc
                                               then (NamedLoc a
nloc, t -> Either a t
forall a b. b -> Either a b
Right t
subexp Either a t -> [Either a t] -> [Either a t]
forall a. a -> [a] -> [a]
: [Either a t]
dl) (NamedLoc a, [Either a t])
-> [(NamedLoc a, [Either a t])] -> [(NamedLoc a, [Either a t])]
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 str -> Maybe str
forall a. a -> Maybe a
Just str
s Maybe str -> Maybe str -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe str
atom2str a
a
                                               then SExpr a -> Maybe (SExpr a)
forall a. a -> Maybe a
Just SExpr a
e
                                               else Maybe (SExpr a)
forall a. Maybe a
Nothing
                  matchExpHead str
s e :: SExpr a
e@(SCons (SAtom a
a) SExpr a
r) = if str -> Maybe str
forall a. a -> Maybe a
Just str
s Maybe str -> Maybe str -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe str
atom2str a
a
                                                         then SExpr a -> Maybe (SExpr a)
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 = Maybe (SExpr a)
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 Maybe (SExpr a) -> Maybe (SExpr a) -> Maybe (SExpr a)
forall a. Maybe a -> Maybe a -> Maybe a
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 -> [(NamedLoc a, [Either a (SExpr a)])]
-> (SExpr a -> [(NamedLoc a, [Either a (SExpr a)])])
-> Maybe (SExpr a)
-> [(NamedLoc a, [Either a (SExpr a)])]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(NamedLoc a, [Either a (SExpr a)])]
dups ([(NamedLoc a, [Either a (SExpr a)])]
-> SExpr a -> [(NamedLoc a, [Either a (SExpr a)])]
forall {a} {t}.
[(NamedLoc a, [Either a t])] -> t -> [(NamedLoc a, [Either a t])]
addDup [(NamedLoc a, [Either a (SExpr a)])]
dups) (Maybe (SExpr a) -> [(NamedLoc a, [Either a (SExpr a)])])
-> Maybe (SExpr a) -> [(NamedLoc a, [Either a (SExpr a)])]
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 = ((NamedLoc a, [NamedLoc a])
 -> (NamedLoc a, [Either (NamedLoc a) b]))
-> [(NamedLoc a, [NamedLoc a])]
-> [(NamedLoc a, [Either (NamedLoc a) b])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([NamedLoc a] -> [Either (NamedLoc a) b])
-> (NamedLoc a, [NamedLoc a])
-> (NamedLoc a, [Either (NamedLoc a) b])
forall a b. (a -> b) -> (NamedLoc a, a) -> (NamedLoc a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NamedLoc a -> Either (NamedLoc a) b)
-> [NamedLoc a] -> [Either (NamedLoc a) b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedLoc a -> Either (NamedLoc a) b
forall a b. a -> Either a b
Left)) ([(NamedLoc a, [NamedLoc a])]
 -> [(NamedLoc a, [Either (NamedLoc a) b])])
-> ([NamedLoc a] -> [(NamedLoc a, [NamedLoc a])])
-> [NamedLoc a]
-> [(NamedLoc a, [Either (NamedLoc a) b])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([NamedLoc a], [(NamedLoc a, [NamedLoc a])])
-> [(NamedLoc a, [NamedLoc a])]
forall a b. (a, b) -> b
snd
                             (([NamedLoc a], [(NamedLoc a, [NamedLoc a])])
 -> [(NamedLoc a, [NamedLoc a])])
-> ([NamedLoc a] -> ([NamedLoc a], [(NamedLoc a, [NamedLoc a])]))
-> [NamedLoc a]
-> [(NamedLoc a, [NamedLoc a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(NamedLoc a, [NamedLoc a])]
-> ([NamedLoc a], [(NamedLoc a, [NamedLoc a])])
forall {a} {a}. [(a, [a])] -> ([a], [(a, [a])])
splitDups ([(NamedLoc a, [NamedLoc a])]
 -> ([NamedLoc a], [(NamedLoc a, [NamedLoc a])]))
-> ([NamedLoc a] -> [(NamedLoc a, [NamedLoc a])])
-> [NamedLoc a]
-> ([NamedLoc a], [(NamedLoc a, [NamedLoc a])])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedLoc a
 -> [(NamedLoc a, [NamedLoc a])] -> [(NamedLoc a, [NamedLoc a])])
-> [(NamedLoc a, [NamedLoc a])]
-> [NamedLoc a]
-> [(NamedLoc a, [NamedLoc a])]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamedLoc a
-> [(NamedLoc a, [NamedLoc a])] -> [(NamedLoc a, [NamedLoc a])]
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 NamedLoc a -> SExpr a
forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
nloc SExpr a -> SExpr a -> Bool
forall a. Eq a => a -> a -> Bool
== NamedLoc a -> SExpr a
forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
d
                                         then (NamedLoc a
d,NamedLoc a
nlocNamedLoc a -> [NamedLoc a] -> [NamedLoc a]
forall a. a -> [a] -> [a]
:[NamedLoc a]
ls)(NamedLoc a, [NamedLoc a])
-> [(NamedLoc a, [NamedLoc a])] -> [(NamedLoc a, [NamedLoc a])]
forall a. a -> [a] -> [a]
:[(NamedLoc a, [NamedLoc a])]
ds
                                         else (NamedLoc a
d,[NamedLoc a]
ls) (NamedLoc a, [NamedLoc a])
-> [(NamedLoc a, [NamedLoc a])] -> [(NamedLoc a, [NamedLoc a])]
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
nloca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
u, [(a, [a])]
d)
                          isDup (a, [a])
e ([a]
u,[(a, [a])]
d) = ([a]
u, (a, [a])
e(a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
:[(a, [a])]
d)
                      in ((a, [a]) -> ([a], [(a, [a])]) -> ([a], [(a, [a])]))
-> ([a], [(a, [a])]) -> [(a, [a])] -> ([a], [(a, [a])])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, [a]) -> ([a], [(a, [a])]) -> ([a], [(a, [a])])
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 = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char])
-> (UniquenessResult a -> [[Char]]) -> UniquenessResult a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NamedLoc a, [Either (NamedLoc a) (SExpr a)]) -> [Char])
-> UniquenessResult a -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NamedLoc a, [Either (NamedLoc a) (SExpr a)]) -> [Char]
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 = (Either (NamedLoc a) (SExpr a) -> [Char])
-> [Either (NamedLoc a) (SExpr a)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (NamedLoc a) (SExpr a) -> [Char]
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) = NamedLoc a -> [Char]
forall a. Show a => NamedLoc a -> [Char]
var NamedLoc a
nloc
                  fl (Right SExpr a
e) = [Char]
"other portion of S-expression: "
                                 [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (SExpr a -> [Char]
forall a. Show a => a -> [Char]
show (SExpr a -> [Char]) -> SExpr a -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> SExpr a -> SExpr a
forall a. Int -> SExpr a -> SExpr a
truncateExpr Int
4 SExpr a
e)
                  var :: NamedLoc a -> [Char]
var NamedLoc a
v = [Char]
"let variable \"" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (SExpr a -> [Char]
forall a. Show a => a -> [Char]
show (SExpr a -> [Char]) -> SExpr a -> [Char]
forall a b. (a -> b) -> a -> b
$ NamedLoc a -> SExpr a
forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
v)
                          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\" ["
                          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Maybe (SExpr a) -> [Char]
forall a. Show a => a -> [Char]
show (Maybe (SExpr a) -> [Char]) -> Maybe (SExpr a) -> [Char]
forall a b. (a -> b) -> a -> b
$ (Int -> SExpr a -> SExpr a
forall a. Int -> SExpr a -> SExpr a
truncateExpr Int
2 (SExpr a -> SExpr a)
-> (Location a -> SExpr a) -> Location a -> SExpr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location a -> SExpr a
forall a. Location a -> SExpr a
locExpr) (Location a -> SExpr a) -> Maybe (Location a) -> Maybe (SExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                   (Location a -> Bool) -> [Location a] -> Maybe (Location a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) (NamedLoc a -> Int
forall a. NamedLoc a -> Int
nlocId NamedLoc a
v) (Int -> Bool) -> (Location a -> Int) -> Location a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location a -> Int
forall a. Location a -> Int
locId) [Location a]
locs)
                          [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" ...]"
              in [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n    " ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
                     ([Char]
"ERR: duplicated " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (NamedLoc a -> [Char]
forall a. Show a => NamedLoc a -> [Char]
var NamedLoc a
l) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" at: ") [Char] -> [[Char]] -> [[Char]]
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 = SExpr a
forall atom. SExpr atom
SNil
truncateExpr Int
_ e :: SExpr a
e@(SAtom a
_) = SExpr a
e
truncateExpr Int
0 SExpr a
_ = SExpr a
forall atom. SExpr atom
SNil
truncateExpr Int
n (SCons SExpr a
l SExpr a
r) = let trunc :: SExpr a -> SExpr a
trunc = Int -> SExpr a -> SExpr a
forall a. Int -> SExpr a -> SExpr a
truncateExpr (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                             in SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (SExpr a -> SExpr a
forall {a}. SExpr a -> SExpr a
trunc SExpr a
l) (SExpr a -> SExpr a
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 = (SExpr a, SExpr a) -> (SExpr a, SExpr a)
forall a b. (a, b) -> (b, a)
swap ((SExpr a, SExpr a) -> (SExpr a, SExpr a))
-> (ExprInfo a -> (SExpr a, SExpr a))
-> ExprInfo a
-> (SExpr a, SExpr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(SExpr a, SExpr a)] -> SExpr a)
-> (SExpr a, [(SExpr a, SExpr a)]) -> (SExpr a, SExpr a)
forall a b. (a -> b) -> (SExpr a, a) -> (SExpr a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(SExpr a, SExpr a)] -> SExpr a
declVars ((SExpr a, [(SExpr a, SExpr a)]) -> (SExpr a, SExpr a))
-> (ExprInfo a -> (SExpr a, [(SExpr a, SExpr a)]))
-> ExprInfo a
-> (SExpr a, SExpr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(SExpr a, SExpr a)], SExpr a) -> (SExpr a, [(SExpr a, SExpr a)])
forall a b. (a, b) -> (b, a)
swap (([(SExpr a, SExpr a)], SExpr a)
 -> (SExpr a, [(SExpr a, SExpr a)]))
-> (ExprInfo a -> ([(SExpr a, SExpr a)], SExpr a))
-> ExprInfo a
-> (SExpr a, [(SExpr a, SExpr a)])
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, SExpr a
forall atom. SExpr atom
SNil)
          subsRefs [(SExpr a, SExpr a)]
b (EIAtom a
a) = ([(SExpr a, SExpr a)]
b, a -> SExpr a
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 = SExpr a -> SExpr a -> SExpr a
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 -> (((NamedLoc a -> SExpr a
forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
loc), SExpr a
here) (SExpr a, SExpr a) -> [(SExpr a, SExpr a)] -> [(SExpr a, SExpr a)]
forall a. a -> [a] -> [a]
: [(SExpr a, SExpr a)]
c', (SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (NamedLoc a -> SExpr a
forall a. NamedLoc a -> SExpr a
nlocVar NamedLoc a
loc) SExpr a
forall atom. SExpr atom
SNil))
          hasBinding :: Int -> Maybe (NamedLoc a)
hasBinding Int
i = (NamedLoc a -> Bool) -> [NamedLoc a] -> Maybe (NamedLoc a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
F.find (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
(==) Int
i (Int -> Bool) -> (NamedLoc a -> Int) -> NamedLoc a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedLoc a -> Int
forall a. NamedLoc a -> Int
nlocId) [NamedLoc a]
nlocs
          declVars :: [(SExpr a, SExpr a)] -> SExpr a
declVars = (SExpr a -> (SExpr a, SExpr a) -> SExpr a)
-> SExpr a -> [(SExpr a, SExpr a)] -> SExpr a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SExpr a -> (SExpr a, SExpr a) -> SExpr a
forall {atom}. SExpr atom -> (SExpr atom, SExpr atom) -> SExpr atom
addVar SExpr a
forall atom. SExpr atom
SNil ([(SExpr a, SExpr a)] -> SExpr a)
-> ([(SExpr a, SExpr a)] -> [(SExpr a, SExpr a)])
-> [(SExpr a, SExpr a)]
-> SExpr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(SExpr a, SExpr a)]
 -> (SExpr a, SExpr a) -> [(SExpr a, SExpr a)])
-> [(SExpr a, SExpr a)]
-> [(SExpr a, SExpr a)]
-> [(SExpr a, SExpr a)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [(SExpr a, SExpr a)] -> (SExpr a, SExpr a) -> [(SExpr a, SExpr a)]
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 a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
vn [(a, b)]
vl of
                                         Maybe b
Nothing -> (a, b)
v (a, b) -> [(a, b)] -> [(a, b)]
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) = SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
vn (SExpr atom -> SExpr atom -> SExpr atom
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons SExpr atom
vv SExpr atom
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 Maybe str -> Maybe str -> Bool
forall a. Eq a => a -> a -> Bool
== str -> Maybe str
forall a. a -> Maybe a
Just str
"let"
              then SExpr a -> SExpr a -> SExpr a
expLet SExpr a
lbvdefs SExpr a
subsInp
              else SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (a -> SExpr a
forall atom. atom -> SExpr atom
SAtom a
a) (SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (SExpr a -> SExpr a
findExpLet SExpr a
lbvdefs) (SExpr a -> SExpr a -> SExpr a
forall atom. SExpr atom -> SExpr atom -> SExpr atom
SCons (SExpr a -> SExpr a
findExpLet SExpr a
subsInp) SExpr a
forall atom. SExpr atom
SNil))
          findExpLet SExpr a
e = SExpr a
e
          expLet :: SExpr a -> SExpr a -> SExpr a
expLet SExpr a
lb = [(SExpr a, SExpr a)] -> SExpr a -> SExpr a
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 = [(SExpr a, SExpr a)] -> SExpr a -> [(SExpr a, SExpr a)]
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) (SExpr atom, SExpr atom)
-> [(SExpr atom, SExpr atom)] -> [(SExpr atom, SExpr atom)]
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 = [Char] -> [(SExpr atom, SExpr atom)]
forall a. HasCallStack => [Char] -> a
error ([Char] -> [(SExpr atom, SExpr atom)])
-> [Char] -> [(SExpr atom, SExpr atom)]
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected a var, got: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> SExpr atom -> [Char]
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 = SExpr atom
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 SExpr atom -> [(SExpr atom, SExpr atom)] -> Maybe (SExpr atom)
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 SExpr atom -> [(SExpr atom, SExpr atom)] -> Maybe (SExpr atom)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SExpr atom
e [(SExpr atom, SExpr atom)]
vdefs of
                Maybe (SExpr atom)
Nothing -> SExpr atom -> SExpr atom -> SExpr atom
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