{-# OPTIONS_GHC -Wno-unused-top-binds #-}

-- | Internals for building simple expressions. Do not use unless you know what you are doing
module Language.Haskell.TH.Natural.Syntax.Expr.Internal (
    -- * Binding (Let, do bind)
    Binding (..),
    bindingToDec,

    -- * Deconstruction
    Deconstruct (..),
    deconstructToDec,
    deconstructToPat,
    mergeDeconstructs,
    mergeDeconstruct,
    --- * Lenses
    conName,
    fieldPatterns,
    src,
    totalFieldCount,
) where

import Control.Lens
import Control.Monad
import Data.List (intersectBy, partition)
import Data.Maybe
import qualified Language.Haskell.TH as TH
import Text.Printf

data Binding = MkBind {Binding -> Name
_varName :: TH.Name, Binding -> Exp
_bound :: TH.Exp, Binding -> Bool
_strict :: Bool} deriving (Binding -> Binding -> Bool
(Binding -> Binding -> Bool)
-> (Binding -> Binding -> Bool) -> Eq Binding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Binding -> Binding -> Bool
== :: Binding -> Binding -> Bool
$c/= :: Binding -> Binding -> Bool
/= :: Binding -> Binding -> Bool
Eq, Int -> Binding -> ShowS
[Binding] -> ShowS
Binding -> String
(Int -> Binding -> ShowS)
-> (Binding -> String) -> ([Binding] -> ShowS) -> Show Binding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Binding -> ShowS
showsPrec :: Int -> Binding -> ShowS
$cshow :: Binding -> String
show :: Binding -> String
$cshowList :: [Binding] -> ShowS
showList :: [Binding] -> ShowS
Show)

bindingToDec :: Binding -> TH.Dec
bindingToDec :: Binding -> Dec
bindingToDec (MkBind Name
n Exp
expr Bool
s) = Pat -> Body -> [Dec] -> Dec
TH.ValD ((if Bool
s then Pat -> Pat
TH.BangP else Pat -> Pat
forall a. a -> a
id) (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
TH.VarP Name
n) (Exp -> Body
TH.NormalB Exp
expr) []

data Deconstruct = MkDec
    { Deconstruct -> Either Int Name
_conName :: Either Int TH.Name
    -- ^ Left is for tuples. The Int represents the size of the tuple
    , Deconstruct -> [(Int, Pat)]
_fieldPatterns :: [(Int, TH.Pat)]
    , Deconstruct -> Exp
_src :: TH.Exp
    , Deconstruct -> Int
_totalFieldCount :: Int
    }
    deriving (Deconstruct -> Deconstruct -> Bool
(Deconstruct -> Deconstruct -> Bool)
-> (Deconstruct -> Deconstruct -> Bool) -> Eq Deconstruct
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Deconstruct -> Deconstruct -> Bool
== :: Deconstruct -> Deconstruct -> Bool
$c/= :: Deconstruct -> Deconstruct -> Bool
/= :: Deconstruct -> Deconstruct -> Bool
Eq, Int -> Deconstruct -> ShowS
[Deconstruct] -> ShowS
Deconstruct -> String
(Int -> Deconstruct -> ShowS)
-> (Deconstruct -> String)
-> ([Deconstruct] -> ShowS)
-> Show Deconstruct
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Deconstruct -> ShowS
showsPrec :: Int -> Deconstruct -> ShowS
$cshow :: Deconstruct -> String
show :: Deconstruct -> String
$cshowList :: [Deconstruct] -> ShowS
showList :: [Deconstruct] -> ShowS
Show)

makeLenses ''Deconstruct

deconstructToPat :: Deconstruct -> TH.Pat
deconstructToPat :: Deconstruct -> Pat
deconstructToPat MkDec{Int
[(Int, Pat)]
Either Int Name
Exp
_conName :: Deconstruct -> Either Int Name
_fieldPatterns :: Deconstruct -> [(Int, Pat)]
_src :: Deconstruct -> Exp
_totalFieldCount :: Deconstruct -> Int
_conName :: Either Int Name
_fieldPatterns :: [(Int, Pat)]
_src :: Exp
_totalFieldCount :: Int
..} =
    let conPat :: [Pat] -> Pat
conPat = (Int -> [Pat] -> Pat)
-> (Name -> [Pat] -> Pat) -> Either Int Name -> [Pat] -> Pat
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([Pat] -> Pat) -> Int -> [Pat] -> Pat
forall a b. a -> b -> a
const [Pat] -> Pat
TH.TupP) (Name -> [Type] -> [Pat] -> Pat
`TH.ConP` []) Either Int Name
_conName
     in [Pat] -> Pat
conPat ([Int
0 .. Int
_totalFieldCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] [Int] -> (Int -> Pat) -> [Pat]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
i -> Pat -> Maybe Pat -> Pat
forall a. a -> Maybe a -> a
fromMaybe Pat
TH.WildP (Int -> [(Int, Pat)] -> Maybe Pat
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, Pat)]
_fieldPatterns))

deconstructToDec :: Deconstruct -> TH.Dec
deconstructToDec :: Deconstruct -> Dec
deconstructToDec Deconstruct
d = Pat -> Body -> [Dec] -> Dec
TH.ValD (Deconstruct -> Pat
deconstructToPat Deconstruct
d) (Exp -> Body
TH.NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Deconstruct -> Exp
_src Deconstruct
d) []

-- | Merge 'Deconstruct's that have the same 'src'
mergeDeconstructs :: (MonadFail m) => [Deconstruct] -> m [Deconstruct]
mergeDeconstructs :: forall (m :: * -> *).
MonadFail m =>
[Deconstruct] -> m [Deconstruct]
mergeDeconstructs [] = [Deconstruct] -> m [Deconstruct]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mergeDeconstructs (Deconstruct
d : [Deconstruct]
ds) = case (Deconstruct -> Bool)
-> [Deconstruct] -> ([Deconstruct], [Deconstruct])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\Deconstruct
d' -> Deconstruct
d Deconstruct -> Getting Exp Deconstruct Exp -> Exp
forall s a. s -> Getting a s a -> a
^. Getting Exp Deconstruct Exp
Lens' Deconstruct Exp
src Exp -> Exp -> Bool
forall a. Eq a => a -> a -> Bool
== Deconstruct
d' Deconstruct -> Getting Exp Deconstruct Exp -> Exp
forall s a. s -> Getting a s a -> a
^. Getting Exp Deconstruct Exp
Lens' Deconstruct Exp
src) [Deconstruct]
ds of
    ([], [Deconstruct]
_) -> (Deconstruct
d Deconstruct -> [Deconstruct] -> [Deconstruct]
forall a. a -> [a] -> [a]
:) ([Deconstruct] -> [Deconstruct])
-> m [Deconstruct] -> m [Deconstruct]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Deconstruct] -> m [Deconstruct]
forall (m :: * -> *).
MonadFail m =>
[Deconstruct] -> m [Deconstruct]
mergeDeconstructs [Deconstruct]
ds
    ([Deconstruct]
relatedDs, [Deconstruct]
ds') -> do
        d' <- (Deconstruct -> Deconstruct -> m Deconstruct)
-> Deconstruct -> [Deconstruct] -> m Deconstruct
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Deconstruct -> Deconstruct -> m Deconstruct
forall (m :: * -> *).
MonadFail m =>
Deconstruct -> Deconstruct -> m Deconstruct
mergeDeconstruct Deconstruct
d [Deconstruct]
relatedDs
        (d' :) <$> mergeDeconstructs ds'

-- | Merge two 'Deconstruct's. Will fail if the constructor does not match or if the totalFeildCount are not equal
mergeDeconstruct :: (MonadFail m) => Deconstruct -> Deconstruct -> m Deconstruct
mergeDeconstruct :: forall (m :: * -> *).
MonadFail m =>
Deconstruct -> Deconstruct -> m Deconstruct
mergeDeconstruct Deconstruct
d1 Deconstruct
d2 = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Deconstruct
d1 Deconstruct
-> Getting (Either Int Name) Deconstruct (Either Int Name)
-> Either Int Name
forall s a. s -> Getting a s a -> a
^. Getting (Either Int Name) Deconstruct (Either Int Name)
Lens' Deconstruct (Either Int Name)
conName Either Int Name -> Either Int Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Deconstruct
d2 Deconstruct
-> Getting (Either Int Name) Deconstruct (Either Int Name)
-> Either Int Name
forall s a. s -> Getting a s a -> a
^. Getting (Either Int Name) Deconstruct (Either Int Name)
Lens' Deconstruct (Either Int Name)
conName) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
            String -> String -> ShowS
forall r. PrintfType r => String -> r
printf
                String
"The following expression has already been deconstructed with the %s constructor: %s"
                (Either Int Name -> String
forall a. Show a => a -> String
show (Either Int Name -> String) -> Either Int Name -> String
forall a b. (a -> b) -> a -> b
$ Deconstruct
d1 Deconstruct
-> Getting (Either Int Name) Deconstruct (Either Int Name)
-> Either Int Name
forall s a. s -> Getting a s a -> a
^. Getting (Either Int Name) Deconstruct (Either Int Name)
Lens' Deconstruct (Either Int Name)
conName)
                (Exp -> String
forall a. Show a => a -> String
show (Exp -> String) -> Exp -> String
forall a b. (a -> b) -> a -> b
$ Deconstruct
d1 Deconstruct -> Getting Exp Deconstruct Exp -> Exp
forall s a. s -> Getting a s a -> a
^. Getting Exp Deconstruct Exp
Lens' Deconstruct Exp
src)
    let duplicates :: [(Int, Pat)]
duplicates = ((Int, Pat) -> (Int, Pat) -> Bool)
-> [(Int, Pat)] -> [(Int, Pat)] -> [(Int, Pat)]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
intersectBy (\(Int
a, Pat
_) (Int
b, Pat
_) -> Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b) (Deconstruct
d1 Deconstruct
-> Getting [(Int, Pat)] Deconstruct [(Int, Pat)] -> [(Int, Pat)]
forall s a. s -> Getting a s a -> a
^. Getting [(Int, Pat)] Deconstruct [(Int, Pat)]
Lens' Deconstruct [(Int, Pat)]
fieldPatterns) (Deconstruct
d2 Deconstruct
-> Getting [(Int, Pat)] Deconstruct [(Int, Pat)] -> [(Int, Pat)]
forall s a. s -> Getting a s a -> a
^. Getting [(Int, Pat)] Deconstruct [(Int, Pat)]
Lens' Deconstruct [(Int, Pat)]
fieldPatterns)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Int, Pat)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Pat)]
duplicates) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
            String -> String -> ShowS
forall r. PrintfType r => String -> r
printf
                String
"When deconstructing the following expression,  fields %s have been bounds twice or more: %s"
                ([(Int, Pat)] -> String
forall a. Show a => a -> String
show [(Int, Pat)]
duplicates)
                (Exp -> String
forall a. Show a => a -> String
show (Exp -> String) -> Exp -> String
forall a b. (a -> b) -> a -> b
$ Deconstruct
d1 Deconstruct -> Getting Exp Deconstruct Exp -> Exp
forall s a. s -> Getting a s a -> a
^. Getting Exp Deconstruct Exp
Lens' Deconstruct Exp
src)
    Deconstruct -> m Deconstruct
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Deconstruct -> m Deconstruct) -> Deconstruct -> m Deconstruct
forall a b. (a -> b) -> a -> b
$ Deconstruct
d1{_fieldPatterns = d1 ^. fieldPatterns ++ d2 ^. fieldPatterns}