{- | 
Module      : Language.Scheme.Macro.Matches
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : portable

This module contains utility functions used to support macro processing,
by storing and/or manipulating data involving 0-or-many matches.
-}
module Language.Scheme.Macro.Matches (getData, setData) where
import Language.Scheme.Types
import Control.Exception
--import Debug.Trace

-- |Create a nested list
_create :: Int     -- ^ Number of nesting levels
       -> LispVal -- ^ Empty nested list
_create :: Int -> LispVal
_create Int
level 
    | Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1     = String -> LispVal
Nil String
"" -- Error
    | Int
level Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1    = [LispVal] -> LispVal
List []
    | Bool
otherwise = [LispVal] -> LispVal
List [Int -> LispVal
_create (Int -> LispVal) -> Int -> LispVal
forall a b. (a -> b) -> a -> b
$ Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

-- |Fill any empty /holes/ in a list from the beginning to the given length
--
-- The problem here is how to handle case when a requested insertion leaves /holes/.
--
-- For example, in a 2-level nested list: ((1)) we have data as pos 0 but have none at pos 1.
-- If the code then tries to add an element 2 at pos 2 we should end up with:
--
--    ((1) () (2))
--
fill :: [LispVal] -> Int -> [LispVal]
fill :: [LispVal] -> Int -> [LispVal]
fill [LispVal]
l Int
len 
  | [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len  = [LispVal] -> Int -> [LispVal]
fill ([LispVal]
l [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [[LispVal] -> LispVal
List []]) Int
len
  | Bool
otherwise       = [LispVal]
l

-- |Get an element at given location in the nested list
getData :: LispVal -- ^ The nested list to read from
        -> [Int]   -- ^ Location to read an element from, all numbers are 0-based
        -> LispVal -- ^ Value read, or @Nil@ if none
getData :: LispVal -> [Int] -> LispVal
getData (List [LispVal]
lData) (Int
i:[Int]
is) = do
  if [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
lData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i
     then String -> LispVal
Nil String
"" -- Error: there are not enough elements in the list
     else do
       let lst :: [LispVal]
lst = Int -> [LispVal] -> [LispVal]
forall a. Int -> [a] -> [a]
drop Int
i [LispVal]
lData
       if Bool -> Bool
not ([LispVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LispVal]
lst)
          then LispVal -> [Int] -> LispVal
getData ([LispVal] -> LispVal
forall a. [a] -> a
head [LispVal]
lst) [Int]
is
          else String -> LispVal
Nil String
"" -- Error: not enough elements in list
getData LispVal
val [] = LispVal
val -- Base case: we have found the requested element
getData LispVal
val [Int]
_ = LispVal
val -- Should never be reached, just give up and return val 

-- |Add an element to the given nested list
setData :: LispVal -- ^ The nested list to modify
        -> [Int]   -- ^ Location to insert the new element, from top-most to the leaf.
                   --   For example [1, 2] means add to the second top-most list, at
                   --   its 3rd position.
        -> LispVal -- ^ Value to insert 
        -> LispVal -- ^ Resulant list
setData :: LispVal -> [Int] -> LispVal -> LispVal
setData (List [LispVal]
lData) (Int
i:[Int]
is) LispVal
val = do
  -- Fill /holes/ as long as they are not at the leaves.
  --
  -- This is because,  when a match occurs it happens 0 or more  times.
  -- Therefore it is not  possible (at the leaves) for a match to occur 
  -- where that match is not placed at the end of the list. For example
  -- if the pattern is:
  --
  -- a ...
  --
  -- And the input is:
  --
  -- 1 2 3
  --
  -- Then we always store the first match in position 0, second in 1, etc. 
  -- There  are no  holes  in this  case  because there is never a  reason 
  -- to skip any of these positions.
  if Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
is) Bool -> Bool -> Bool
&& [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
lData Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 
     then [LispVal] -> LispVal
set ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> Int -> [LispVal]
fill [LispVal]
lData (Int -> [LispVal]) -> Int -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
     else [LispVal] -> LispVal
set [LispVal]
lData

 where 

--  set listData = case (snd (trace ("content = " ++ show content) content)) of
  set :: [LispVal] -> LispVal
set [LispVal]
listData = do
    let content :: ([LispVal], [LispVal])
content = Int -> [LispVal] -> ([LispVal], [LispVal])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [LispVal]
listData
    case (([LispVal], [LispVal]) -> [LispVal]
forall a b. (a, b) -> b
snd ([LispVal], [LispVal])
content) of
      [] -> [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal]
listData [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
val]
      [LispVal
c] ->    if [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
is Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
                   then [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (([LispVal], [LispVal]) -> [LispVal]
forall a b. (a, b) -> a
fst ([LispVal], [LispVal])
content) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
val] [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
c] -- Base case - Requested pos must be one less than c
                   else [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (([LispVal], [LispVal]) -> [LispVal]
forall a b. (a, b) -> a
fst ([LispVal], [LispVal])
content) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal -> [Int] -> LispVal -> LispVal
setData LispVal
c [Int]
is LispVal
val]
      (LispVal
c:[LispVal]
cs) -> if [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
is Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
                   then [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (([LispVal], [LispVal]) -> [LispVal]
forall a b. (a, b) -> a
fst ([LispVal], [LispVal])
content) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
val] [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal
c] [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
cs -- Base case - Requested pos must be one less than c
                   else [LispVal] -> LispVal
List ([LispVal] -> LispVal) -> [LispVal] -> LispVal
forall a b. (a -> b) -> a -> b
$ (([LispVal], [LispVal]) -> [LispVal]
forall a b. (a, b) -> a
fst ([LispVal], [LispVal])
content) [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal -> [Int] -> LispVal -> LispVal
setData LispVal
c [Int]
is LispVal
val] [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
cs 

setData LispVal
_ [Int]
_ LispVal
val = LispVal
val -- Should never be reached; just return val

-- |Compare actual input with expected
_cmp :: LispVal -> LispVal -> IO ()
_cmp :: LispVal -> LispVal -> IO ()
_cmp LispVal
input LispVal
expected = do
  LispVal -> IO ()
forall a. Show a => a -> IO ()
print LispVal
input
  LispVal -> IO ()
forall a. Show a => a -> IO ()
print (Bool -> LispVal -> LispVal
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (LispVal -> LispVal -> Bool
eqVal LispVal
expected LispVal
input) LispVal
input)

-- |Run this function to test the above code
_test :: IO ()
_test :: IO ()
_test = do
  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal -> LispVal
setData ([LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4]) [Int
4] (Integer -> LispVal
Number Integer
5)) 
               ([LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4, Integer -> LispVal
Number Integer
5])

  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal -> LispVal
setData ([LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4]) [Int
1] (Integer -> LispVal
Number Integer
5)) 
               ([LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
5, Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4])

  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal -> LispVal
setData ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4, Integer -> LispVal
Number Integer
5]]) [Int
1, Int
3] (Integer -> LispVal
Number Integer
6)) 
               ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4, Integer -> LispVal
Number Integer
5, Integer -> LispVal
Number Integer
6]])

  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal -> LispVal
setData ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4, Integer -> LispVal
Number Integer
5]]) [Int
1, Int
2] (Integer -> LispVal
Number Integer
6)) 
               ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4, Integer -> LispVal
Number Integer
6, Integer -> LispVal
Number Integer
5]])

  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal -> LispVal
setData ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4, Integer -> LispVal
Number Integer
5]]) [Int
0, Int
2] (Integer -> LispVal
Number Integer
6)) 
               ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
6], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4, Integer -> LispVal
Number Integer
5]])

  let a :: LispVal
a = Int -> LispVal
_create Int
2
  LispVal -> LispVal -> IO ()
_cmp LispVal
a 
      ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List []])

  let b :: LispVal
b = LispVal -> [Int] -> LispVal -> LispVal
setData LispVal
a [Int
0, Int
0] (LispVal -> LispVal) -> LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"test"
  LispVal -> LispVal -> IO ()
_cmp LispVal
b ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [String -> LispVal
Atom String
"test"]])

  let c :: LispVal
c = LispVal -> [Int] -> LispVal -> LispVal
setData LispVal
b [Int
0, Int
1] (LispVal -> LispVal) -> LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"test2"
  LispVal -> LispVal -> IO ()
_cmp LispVal
c ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [String -> LispVal
Atom String
"test", String -> LispVal
Atom String
"test2"]])


-- An invalid test case because it attempts to initialize a leaf by adding at a non-zero leaf position.
--_cmp (setData (List []) [0, 1, 2] $ Atom "test") 
--               (List [List[List [], List[List [], List[], Atom "test"]]])
--   A correct test is below:
  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal -> LispVal
setData ([LispVal] -> LispVal
List []) [Int
0, Int
1, Int
0] (LispVal -> LispVal) -> LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"test") 
               ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List[[LispVal] -> LispVal
List [], [LispVal] -> LispVal
List[String -> LispVal
Atom String
"test"]]])

  -- Illustrates an important point, that if we are adding into 
  -- a /hole/, we need to create a list there first
  let cc :: LispVal
cc = LispVal -> [Int] -> LispVal -> LispVal
setData LispVal
b [Int
1, Int
0] (LispVal -> LispVal) -> LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"test2"
  LispVal -> LispVal -> IO ()
_cmp LispVal
cc ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [String -> LispVal
Atom String
"test"], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"test2"]])

  let cc2 :: LispVal
cc2 = LispVal -> [Int] -> LispVal -> LispVal
setData LispVal
b [Int
1, Int
4] (LispVal -> LispVal) -> LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"test2"
  LispVal -> LispVal -> IO ()
_cmp LispVal
cc2 ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [String -> LispVal
Atom String
"test"], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"test2"]])

  let cc3 :: LispVal
cc3 = LispVal -> [Int] -> LispVal -> LispVal
setData LispVal
b [Int
4, Int
0] (LispVal -> LispVal) -> LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Atom String
"test2"
  LispVal -> LispVal -> IO ()
_cmp LispVal
cc3 ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [String -> LispVal
Atom String
"test"], [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"test2"]])

  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal -> LispVal
setData ([LispVal] -> LispVal
List []) [Int
4, Int
0] (Integer -> LispVal
Number Integer
5)) 
               ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
5]])

  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal
getData ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [[LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [Integer -> LispVal
Number Integer
1, Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4]]]) [Int
0, Int
1, Int
2]) 
               (Integer -> LispVal
Number Integer
3)

--  _cmp (getData (List [List [List [], List [Number 1, Number 2, Number 3, Number 4]]]) [0, 1, 20]) 
--               (Nil "")

  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal
getData ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [[LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"1", Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4]]]) [Int
0, Int
1, Int
0]) 
               (String -> LispVal
Atom String
"1")

  -- Real world case, we would like to take the list (all leaves) at [0, 1]
  LispVal -> LispVal -> IO ()
_cmp (LispVal -> [Int] -> LispVal
getData ([LispVal] -> LispVal
List [[LispVal] -> LispVal
List [[LispVal] -> LispVal
List [], [LispVal] -> LispVal
List [String -> LispVal
Atom String
"1", Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4]]]) [Int
0, Int
1]) 
               ([LispVal] -> LispVal
List [String -> LispVal
Atom String
"1", Integer -> LispVal
Number Integer
2, Integer -> LispVal
Number Integer
3, Integer -> LispVal
Number Integer
4])