{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      : Text.EDE.Internal.AST
-- Copyright   : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com>
-- License     : This Source Code Form is subject to the terms of
--               the Mozilla Public License, v. 2.0.
--               A copy of the MPL can be found in the LICENSE file or
--               you can obtain it at http://mozilla.org/MPL/2.0/.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- /Warning/: this is an internal module, and does not have a stable
-- API or name. Functions in this module may not check or enforce
-- preconditions expected by public modules. Use at your own risk!
--
-- AST smart constructors.
module Text.EDE.Internal.AST where

import qualified Control.Comonad as Comonad
import Control.Comonad.Cofree (Cofree ((:<)))
import Data.Aeson.Types (Value (..))
import qualified Data.Foldable as Foldable
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Maybe as Maybe
import Text.EDE.Internal.Types

newtype Fix f = Fix (f (Fix f))

cofreeFix :: Functor f => a -> Fix f -> Cofree f a
cofreeFix :: a -> Fix f -> Cofree f a
cofreeFix a
x = Fix f -> Cofree f a
forall (f :: * -> *). Functor f => Fix f -> Cofree f a
go
  where
    go :: Fix f -> Cofree f a
go (Fix f (Fix f)
f) = a
x a -> f (Cofree f a) -> Cofree f a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< (Fix f -> Cofree f a) -> f (Fix f) -> f (Cofree f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Fix f -> Cofree f a
go f (Fix f)
f
{-# INLINEABLE cofreeFix #-}

var :: Id -> Var
var :: Id -> Var
var = NonEmpty Id -> Var
Var (NonEmpty Id -> Var) -> (Id -> NonEmpty Id) -> Id -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id -> [Id] -> NonEmpty Id
forall a. a -> [a] -> NonEmpty a
:| [])
{-# INLINEABLE var #-}

eapp :: a -> [Exp a] -> Exp a
eapp :: a -> [Exp a] -> Exp a
eapp a
x [] = a -> Fix ExpF -> Exp a
forall (f :: * -> *) a. Functor f => a -> Fix f -> Cofree f a
cofreeFix a
x Fix ExpF
blank
eapp a
_ [Exp a
e] = Exp a
e
eapp a
_ (Exp a
e : [Exp a]
es) = (Exp a -> Exp a -> Exp a) -> Exp a -> [Exp a] -> Exp a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\Exp a
x Exp a
y -> Exp a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
Comonad.extract Exp a
x a -> ExpF (Exp a) -> Exp a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Exp a -> Exp a -> ExpF (Exp a)
forall a. a -> a -> ExpF a
EApp Exp a
x Exp a
y) Exp a
e [Exp a]
es
{-# INLINEABLE eapp #-}

efun :: Id -> Exp a -> Exp a
efun :: Id -> Exp a -> Exp a
efun Id
i Exp a
e = let x :: a
x = Exp a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
Comonad.extract Exp a
e in a
x a -> ExpF (Exp a) -> Exp a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Exp a -> Exp a -> ExpF (Exp a)
forall a. a -> a -> ExpF a
EApp (a
x a -> ExpF (Exp a) -> Exp a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Id -> ExpF (Exp a)
forall a. Id -> ExpF a
EFun Id
i) Exp a
e
{-# INLINEABLE efun #-}

efilter :: Exp a -> (Id, [Exp a]) -> Exp a
efilter :: Exp a -> (Id, [Exp a]) -> Exp a
efilter Exp a
e (Id
i, [Exp a]
ps) = let x :: a
x = Exp a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
Comonad.extract Exp a
e in a -> [Exp a] -> Exp a
forall a. a -> [Exp a] -> Exp a
eapp a
x ((a
x a -> ExpF (Exp a) -> Exp a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Id -> ExpF (Exp a)
forall a. Id -> ExpF a
EFun Id
i) Exp a -> [Exp a] -> [Exp a]
forall a. a -> [a] -> [a]
: Exp a
e Exp a -> [Exp a] -> [Exp a]
forall a. a -> [a] -> [a]
: [Exp a]
ps)
{-# INLINEABLE efilter #-}

elet :: Maybe (Id, Exp a) -> Exp a -> Exp a
elet :: Maybe (Id, Exp a) -> Exp a -> Exp a
elet Maybe (Id, Exp a)
m Exp a
e = Exp a -> ((Id, Exp a) -> Exp a) -> Maybe (Id, Exp a) -> Exp a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Exp a
e (\(Id
i, Exp a
b) -> Exp a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
Comonad.extract Exp a
b a -> ExpF (Exp a) -> Exp a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Id -> Exp a -> Exp a -> ExpF (Exp a)
forall a. Id -> a -> a -> ExpF a
ELet Id
i Exp a
b Exp a
e) Maybe (Id, Exp a)
m
{-# INLINEABLE elet #-}

ecase ::
  Exp a ->
  [Alt (Exp a)] ->
  Maybe (Exp a) ->
  Exp a
ecase :: Exp a -> [Alt (Exp a)] -> Maybe (Exp a) -> Exp a
ecase Exp a
p [Alt (Exp a)]
ws Maybe (Exp a)
f = Exp a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
Comonad.extract Exp a
p a -> ExpF (Exp a) -> Exp a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Exp a -> [Alt (Exp a)] -> ExpF (Exp a)
forall a. a -> [Alt a] -> ExpF a
ECase Exp a
p ([Alt (Exp a)]
ws [Alt (Exp a)] -> [Alt (Exp a)] -> [Alt (Exp a)]
forall a. [a] -> [a] -> [a]
++ [Alt (Exp a)]
-> (Exp a -> [Alt (Exp a)]) -> Maybe (Exp a) -> [Alt (Exp a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Alt (Exp a) -> [Alt (Exp a)] -> [Alt (Exp a)]
forall a. a -> [a] -> [a]
: []) (Alt (Exp a) -> [Alt (Exp a)])
-> (Exp a -> Alt (Exp a)) -> Exp a -> [Alt (Exp a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp a -> Alt (Exp a)
forall a. Exp a -> Alt (Exp a)
wild) Maybe (Exp a)
f)
{-# INLINEABLE ecase #-}

eif ::
  (Exp a, Exp a) ->
  [(Exp a, Exp a)] ->
  Maybe (Exp a) ->
  Exp a
eif :: (Exp a, Exp a) -> [(Exp a, Exp a)] -> Maybe (Exp a) -> Exp a
eif (Exp a, Exp a)
t [(Exp a, Exp a)]
ts Maybe (Exp a)
f =
  ((Exp a, Exp a) -> Exp a -> Exp a)
-> Exp a -> [(Exp a, Exp a)] -> Exp a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Foldable.foldr'
    (Exp a, Exp a) -> Exp a -> Exp a
forall a.
(Cofree ExpF a, Cofree ExpF a) -> Cofree ExpF a -> Cofree ExpF a
c
    (Exp a -> Maybe (Exp a) -> Exp a
forall a. a -> Maybe a -> a
Maybe.fromMaybe (Exp a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
Comonad.extract ((Exp a, Exp a) -> Exp a
forall a b. (a, b) -> a
fst (Exp a, Exp a)
t) a -> Fix ExpF -> Exp a
forall (f :: * -> *) a. Functor f => a -> Fix f -> Cofree f a
`cofreeFix` Fix ExpF
blank) Maybe (Exp a)
f)
    ((Exp a, Exp a)
t (Exp a, Exp a) -> [(Exp a, Exp a)] -> [(Exp a, Exp a)]
forall a. a -> [a] -> [a]
: [(Exp a, Exp a)]
ts)
  where
    c :: (Cofree ExpF a, Cofree ExpF a) -> Cofree ExpF a -> Cofree ExpF a
c (Cofree ExpF a
p, Cofree ExpF a
w) Cofree ExpF a
e = Cofree ExpF a -> a
forall (w :: * -> *) a. Comonad w => w a -> a
Comonad.extract Cofree ExpF a
p a -> ExpF (Cofree ExpF a) -> Cofree ExpF a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
:< Cofree ExpF a -> [Alt (Cofree ExpF a)] -> ExpF (Cofree ExpF a)
forall a. a -> [Alt a] -> ExpF a
ECase Cofree ExpF a
p [Cofree ExpF a -> Alt (Cofree ExpF a)
forall a. Exp a -> Alt (Exp a)
true Cofree ExpF a
w, Cofree ExpF a -> Alt (Cofree ExpF a)
forall a. Exp a -> Alt (Exp a)
false Cofree ExpF a
e]
{-# INLINEABLE eif #-}

eempty :: Exp a -> Exp a -> Maybe (Exp a) -> Exp a
eempty :: Exp a -> Exp a -> Maybe (Exp a) -> Exp a
eempty Exp a
v Exp a
e = Exp a -> (Exp a -> Exp a) -> Maybe (Exp a) -> Exp a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Exp a
e ((Exp a, Exp a) -> [(Exp a, Exp a)] -> Maybe (Exp a) -> Exp a
forall a.
(Exp a, Exp a) -> [(Exp a, Exp a)] -> Maybe (Exp a) -> Exp a
eif (Id -> Exp a -> Exp a
forall a. Id -> Exp a -> Exp a
efun Id
"!" (Id -> Exp a -> Exp a
forall a. Id -> Exp a -> Exp a
efun Id
"empty" Exp a
v), Exp a
e) [] (Maybe (Exp a) -> Exp a)
-> (Exp a -> Maybe (Exp a)) -> Exp a -> Exp a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp a -> Maybe (Exp a)
forall a. a -> Maybe a
Just)
{-# INLINEABLE eempty #-}

true, false, wild :: Exp a -> Alt (Exp a)
true :: Exp a -> Alt (Exp a)
true = (Value -> Pat
PLit (Bool -> Value
Bool Bool
True),)
false :: Exp a -> Alt (Exp a)
false = (Value -> Pat
PLit (Bool -> Value
Bool Bool
False),)
wild :: Exp a -> Alt (Exp a)
wild = (Pat
PWild,)
{-# INLINEABLE true #-}
{-# INLINEABLE false #-}
{-# INLINEABLE wild #-}

blank :: Fix ExpF
blank :: Fix ExpF
blank = ExpF (Fix ExpF) -> Fix ExpF
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Value -> ExpF (Fix ExpF)
forall a. Value -> ExpF a
ELit (Id -> Value
String Id
forall a. Monoid a => a
mempty))
{-# INLINEABLE blank #-}