{-# LANGUAGE CPP                #-}
{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE KindSignatures     #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE StandaloneDeriving #-}
module Overloaded.Plugin.Categories where

import Data.Bifunctor       (Bifunctor (..))
import Data.Bifunctor.Assoc (Assoc (..))
import Data.Kind            (Type)
import Data.Map.Strict      (Map)
import Data.Void            (Void, absurd)

import qualified Data.Generics   as SYB
import qualified Data.Map.Strict as Map
import qualified GHC.Compat.All  as GHC
import           GHC.Compat.Expr

#if MIN_VERSION_ghc(9,0,0)
import qualified GHC.Plugins     as Plugins
#else
import qualified GhcPlugins      as Plugins
#endif

import Overloaded.Plugin.Diagnostics
import Overloaded.Plugin.Names
import Overloaded.Plugin.Rewrite

-------------------------------------------------------------------------------
-- Rewriter
-------------------------------------------------------------------------------

transformCategories
    :: Names
    -> LHsExpr GhcRn
    -> Rewrite (LHsExpr GhcRn)
transformCategories :: Names -> LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)
transformCategories Names
names (L SrcSpan
_l (HsProc XProc GhcRn
_ LPat GhcRn
pat (L SrcSpan
_ (HsCmdTop XCmdTop GhcRn
_ LHsCmd GhcRn
cmd)))) = do
    SomePattern Pattern sh Name
pat' <- LPat GhcRn -> Rewrite (SomePattern Name)
parsePat LPat GhcRn
pat
    Continuation (LHsExpr GhcRn) (Var (Index sh) Void)
kont <- Names
-> Map Name (Index sh)
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var (Index sh) Void))
forall b a.
Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseCmd Names
names (Pattern sh Name -> Map Name (Index sh)
forall a (sh :: Shape). Ord a => Pattern sh a -> Map a (Index sh)
patternMap Pattern sh Name
pat') LHsCmd GhcRn
cmd
    let proc :: Proc (LHsExpr GhcRn) Void
        proc :: Proc (LHsExpr GhcRn) Void
proc = Pattern sh String
-> Continuation (LHsExpr GhcRn) (Var (Index sh) Void)
-> Proc (LHsExpr GhcRn) Void
forall (sh :: Shape) term a.
Pattern sh String
-> Continuation term (Var (Index sh) a) -> Proc term a
Proc (Name -> String
nameToString (Name -> String) -> Pattern sh Name -> Pattern sh String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern sh Name
pat') Continuation (LHsExpr GhcRn) (Var (Index sh) Void)
kont

        morp :: Morphism (LHsExpr GhcRn)
        morp :: Morphism (LHsExpr GhcRn)
morp = (Void -> Morphism (LHsExpr GhcRn))
-> Proc (LHsExpr GhcRn) Void -> Morphism (LHsExpr GhcRn)
forall a term. (a -> Morphism term) -> Proc term a -> Morphism term
desugar Void -> Morphism (LHsExpr GhcRn)
forall a. Void -> a
absurd Proc (LHsExpr GhcRn) Void
proc

        expr :: LHsExpr GhcRn
        expr :: LHsExpr GhcRn
expr = Names -> Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
generate Names
names Morphism (LHsExpr GhcRn)
morp

    -- _ <- Error $ \dflags -> putError dflags _l $ GHC.text "DEBUG"
    --     GHC.$$ GHC.text (show $ first (GHC.showPpr dflags) proc)
    --     GHC.$$ GHC.text (show $ fmap  (GHC.showPpr dflags) morp)
    --     GHC.$$ GHC.ppr expr

    LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return LHsExpr GhcRn
expr

transformCategories Names
_ LHsExpr GhcRn
_ = Rewrite (LHsExpr GhcRn)
forall a. Rewrite a
NoRewrite

-------------------------------------------------------------------------------
-- Parsing
-------------------------------------------------------------------------------

parsePat :: LPat GhcRn -> Rewrite (SomePattern GHC.Name)
#if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(8,10,1)
parsePat (XPat (L l pat)) = parsePat' l pat
parsePat pat              = parsePat' noSrcSpan pat
#else
parsePat :: LPat GhcRn -> Rewrite (SomePattern Name)
parsePat (L l pat) = SrcSpan -> Pat GhcRn -> Rewrite (SomePattern Name)
parsePat' SrcSpan
l Pat GhcRn
pat
#endif

parsePat' :: SrcSpan -> Pat GhcRn -> Rewrite (SomePattern GHC.Name)
parsePat' :: SrcSpan -> Pat GhcRn -> Rewrite (SomePattern Name)
parsePat' SrcSpan
_ WildPat {} =
    SomePattern Name -> Rewrite (SomePattern Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePattern Name -> Rewrite (SomePattern Name))
-> SomePattern Name -> Rewrite (SomePattern Name)
forall a b. (a -> b) -> a -> b
$ Pattern 'One Name -> SomePattern Name
forall (x :: Shape) a. Pattern x a -> SomePattern a
SomePattern Pattern 'One Name
forall a. Pattern 'One a
PatternWild
parsePat' SrcSpan
_ (VarPat XVarPat GhcRn
_ (L SrcSpan
_ IdP GhcRn
name)) =
    SomePattern Name -> Rewrite (SomePattern Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePattern Name -> Rewrite (SomePattern Name))
-> SomePattern Name -> Rewrite (SomePattern Name)
forall a b. (a -> b) -> a -> b
$ Pattern 'One Name -> SomePattern Name
forall (x :: Shape) a. Pattern x a -> SomePattern a
SomePattern (Pattern 'One Name -> SomePattern Name)
-> Pattern 'One Name -> SomePattern Name
forall a b. (a -> b) -> a -> b
$ Name -> Pattern 'One Name
forall a. a -> Pattern 'One a
PatternVar IdP GhcRn
Name
name
parsePat' SrcSpan
_ (TuplePat XTuplePat GhcRn
_ [LPat GhcRn
x, LPat GhcRn
y] Boxity
Plugins.Boxed) = do
    SomePattern Pattern sh Name
x' <- LPat GhcRn -> Rewrite (SomePattern Name)
parsePat LPat GhcRn
x
    SomePattern Pattern sh Name
y' <- LPat GhcRn -> Rewrite (SomePattern Name)
parsePat LPat GhcRn
y
    SomePattern Name -> Rewrite (SomePattern Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePattern Name -> Rewrite (SomePattern Name))
-> SomePattern Name -> Rewrite (SomePattern Name)
forall a b. (a -> b) -> a -> b
$ Pattern ('Two sh sh) Name -> SomePattern Name
forall (x :: Shape) a. Pattern x a -> SomePattern a
SomePattern (Pattern ('Two sh sh) Name -> SomePattern Name)
-> Pattern ('Two sh sh) Name -> SomePattern Name
forall a b. (a -> b) -> a -> b
$ Pattern sh Name -> Pattern sh Name -> Pattern ('Two sh sh) Name
forall (l :: Shape) a (r :: Shape).
Pattern l a -> Pattern r a -> Pattern ('Two l r) a
PatternTuple Pattern sh Name
x' Pattern sh Name
y'
parsePat' SrcSpan
l TuplePat {} = (DynFlags -> IO ()) -> Rewrite (SomePattern Name)
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ()) -> Rewrite (SomePattern Name))
-> (DynFlags -> IO ()) -> Rewrite (SomePattern Name)
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Overloaded:Categories: only boxed tuples of arity 2 are supported"
parsePat' SrcSpan
l Pat GhcRn
pat = (DynFlags -> IO ()) -> Rewrite (SomePattern Name)
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ()) -> Rewrite (SomePattern Name))
-> (DynFlags -> IO ()) -> Rewrite (SomePattern Name)
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Cannot parse pattern for Overloaded:Categories"
        SDoc -> SDoc -> SDoc
GHC.$$ Pat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Pat GhcRn
pat
        SDoc -> SDoc -> SDoc
GHC.$$ String -> SDoc
GHC.text (Pat GhcRn -> String
forall a. Data a => a -> String
SYB.gshow Pat GhcRn
pat)

parseExpr
    :: Names
    -> Map GHC.Name b
    -> LHsExpr GhcRn
    -> Rewrite (Expression (Var b a))
parseExpr :: Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx (L SrcSpan
_ (HsPar XPar GhcRn
_ LHsExpr GhcRn
expr)) =
    Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
expr
parseExpr Names
_     Map Name b
ctx (L SrcSpan
_ (HsVar XVar GhcRn
_ (L SrcSpan
l IdP GhcRn
name)))
    | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName (Boxity -> Arity -> DataCon
GHC.tupleDataCon Boxity
GHC.Boxed Arity
0)
    = Expression (Var b a) -> Rewrite (Expression (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Var b a)
forall a. Expression a
ExpressionUnit
    | Bool
otherwise
    = case Name -> Map Name b -> Maybe b
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup IdP GhcRn
Name
name Map Name b
ctx of
        Maybe b
Nothing -> (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ()) -> Rewrite (Expression (Var b a)))
-> (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
            DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Overloaded:Categories: Unbound variable" SDoc -> SDoc -> SDoc
GHC.<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr IdP GhcRn
Name
name
        Just b
b -> Expression (Var b a) -> Rewrite (Expression (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Var b a) -> Rewrite (Expression (Var b a)))
-> Expression (Var b a) -> Rewrite (Expression (Var b a))
forall a b. (a -> b) -> a -> b
$ Var b a -> Expression (Var b a)
forall a. a -> Expression a
ExpressionVar (b -> Var b a
forall b a. b -> Var b a
B b
b)
parseExpr Names
names Map Name b
ctx (L SrcSpan
_ (ExplicitTuple XExplicitTuple GhcRn
_ [L SrcSpan
_ (Present XPresent GhcRn
_ LHsExpr GhcRn
x), L SrcSpan
_ (Present XPresent GhcRn
_ LHsExpr GhcRn
y)] Boxity
Plugins.Boxed)) = do
    Expression (Var b a)
x' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
x
    Expression (Var b a)
y' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
y
    Expression (Var b a) -> Rewrite (Expression (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Var b a)
-> Expression (Var b a) -> Expression (Var b a)
forall a. Expression a -> Expression a -> Expression a
ExpressionTuple Expression (Var b a)
x' Expression (Var b a)
y')
parseExpr Names
_     Map Name b
_ (L SrcSpan
l ExplicitTuple {}) = (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ()) -> Rewrite (Expression (Var b a)))
-> (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Overloaded:Categories: only boxed tuples of arity 2 are supported"
parseExpr Names
names Map Name b
ctx (L SrcSpan
_ (HsApp XApp GhcRn
_ (L SrcSpan
_ (HsVar XVar GhcRn
_ (L SrcSpan
l IdP GhcRn
fName))) LHsExpr GhcRn
x))
    | IdP GhcRn
Name
fName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Names -> Name
conLeftName Names
names = do
        Expression (Var b a)
x' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
x
        Expression (Var b a) -> Rewrite (Expression (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Var b a) -> Expression (Var b a)
forall a. Expression a -> Expression a
ExpressionLeft Expression (Var b a)
x')
    | IdP GhcRn
Name
fName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Names -> Name
conRightName Names
names = do
        Expression (Var b a)
x' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
x
        Expression (Var b a) -> Rewrite (Expression (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Var b a) -> Expression (Var b a)
forall a. Expression a -> Expression a
ExpressionRight Expression (Var b a)
x')
    | Bool
otherwise = (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ()) -> Rewrite (Expression (Var b a)))
-> (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
        DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Overloaded:Categories: only applications of Left and Right are supported"
parseExpr Names
_     Map Name b
_   (L SrcSpan
l HsExpr GhcRn
expr) = (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ()) -> Rewrite (Expression (Var b a)))
-> (DynFlags -> IO ()) -> Rewrite (Expression (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Cannot parse -< right-hand-side for Overloaded:Categories"
        SDoc -> SDoc -> SDoc
GHC.$$ HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr HsExpr GhcRn
expr
        SDoc -> SDoc -> SDoc
GHC.$$ String -> SDoc
GHC.text (HsExpr GhcRn -> String
forall a. Data a => a -> String
SYB.gshow HsExpr GhcRn
expr)

parseCmd
    :: Names
    -> Map GHC.Name b
    -> LHsCmd GhcRn
    -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseCmd :: Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseCmd Names
names Map Name b
ctx (L SrcSpan
_ (HsCmdDo XCmdDo GhcRn
_ (L SrcSpan
l [CmdLStmt GhcRn]
stmts))) =
    Names
-> Map Name b
-> SrcSpan
-> [CmdLStmt GhcRn]
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall b a.
Names
-> Map Name b
-> SrcSpan
-> [CmdLStmt GhcRn]
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseStmts Names
names Map Name b
ctx SrcSpan
l [CmdLStmt GhcRn]
stmts
parseCmd Names
names Map Name b
ctx (L SrcSpan
_ (HsCmdArrApp XCmdArrApp GhcRn
_ LHsExpr GhcRn
morp LHsExpr GhcRn
expr HsArrAppType
HsFirstOrderApp Bool
_)) = do
    Morphism (LHsExpr GhcRn)
morp' <- Names -> LHsExpr GhcRn -> Rewrite (Morphism (LHsExpr GhcRn))
parseTerm Names
names LHsExpr GhcRn
morp
    Expression (Var b a)
expr' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
expr
    Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Continuation (LHsExpr GhcRn) (Var b a)
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ Either (Expression (Var b a)) (Morphism (LHsExpr GhcRn))
-> Expression (Var b a) -> Continuation (LHsExpr GhcRn) (Var b a)
forall a term.
Either (Expression a) (Morphism term)
-> Expression a -> Continuation term a
Last (Morphism (LHsExpr GhcRn)
-> Either (Expression (Var b a)) (Morphism (LHsExpr GhcRn))
forall a b. b -> Either a b
Right Morphism (LHsExpr GhcRn)
morp') Expression (Var b a)
expr'
parseCmd Names
names Map Name b
ctx (L SrcSpan
_ (HsCmdArrApp XCmdArrApp GhcRn
_ LHsExpr GhcRn
morp LHsExpr GhcRn
expr HsArrAppType
HsHigherOrderApp Bool
_)) = do
    Expression (Var b a)
morp' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
morp
    Expression (Var b a)
expr' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
expr
    Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Continuation (LHsExpr GhcRn) (Var b a)
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ Either (Expression (Var b a)) (Morphism (LHsExpr GhcRn))
-> Expression (Var b a) -> Continuation (LHsExpr GhcRn) (Var b a)
forall a term.
Either (Expression a) (Morphism term)
-> Expression a -> Continuation term a
Last (Expression (Var b a)
-> Either (Expression (Var b a)) (Morphism (LHsExpr GhcRn))
forall a b. a -> Either a b
Left Expression (Var b a)
morp') Expression (Var b a)
expr'
parseCmd Names
names Map Name b
ctx (L SrcSpan
_ (HsCmdCase XCmdCase GhcRn
_ LHsExpr GhcRn
expr MatchGroup GhcRn (LHsCmd GhcRn)
matchGroup)) =
    case MatchGroup GhcRn (LHsCmd GhcRn)
-> Located [LMatch GhcRn (LHsCmd GhcRn)]
forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts MatchGroup GhcRn (LHsCmd GhcRn)
matchGroup of
#if MIN_VERSION_ghc(9,0,1)
        L _ [ L _ Match { m_pats = [L _ (ConPat _ (L _ acon) aargs)], m_grhss = abody' }
            , L _ Match { m_pats = [L _ (ConPat _ (L _ bcon) bargs)], m_grhss = bbody' }
            ]
#elif MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(8,10,1)
        L _ [ L _ Match { m_pats = [XPat (L _ (ConPatIn (L _ acon) aargs))], m_grhss = abody' }
            , L _ Match { m_pats = [XPat (L _ (ConPatIn (L _ bcon) bargs))], m_grhss = bbody' }
            ]
#else
        L SrcSpan
_ [ L SrcSpan
_ Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [L _ (ConPatIn (L _ acon) aargs)], m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (LHsCmd GhcRn)
abody' }
            , L SrcSpan
_ Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = [L _ (ConPatIn (L _ bcon) bargs)], m_grhss :: forall p body. Match p body -> GRHSs p body
m_grhss = GRHSs GhcRn (LHsCmd GhcRn)
bbody' }
            ]
#endif
            -- Left and Right, or Right and Left
            |  [IdP GhcRn
Name
acon,IdP GhcRn
Name
bcon] [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== [Names -> Name
conLeftName Names
names,Names -> Name
conRightName Names
names]
            Bool -> Bool -> Bool
|| [IdP GhcRn
Name
acon,IdP GhcRn
Name
bcon] [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== [Names -> Name
conRightName Names
names,Names -> Name
conLeftName Names
names]
            -- only one argument
            , [LPat GhcRn
aarg] <- HsConPatDetails GhcRn -> [LPat GhcRn]
forall p. HsConPatDetails p -> [LPat p]
hsConPatArgs HsConPatDetails GhcRn
aargs
            , [LPat GhcRn
barg] <- HsConPatDetails GhcRn -> [LPat GhcRn]
forall p. HsConPatDetails p -> [LPat p]
hsConPatArgs HsConPatDetails GhcRn
bargs
            -- and simple bodies
            , Just LHsCmd GhcRn
abody <- GRHSs GhcRn (LHsCmd GhcRn) -> Maybe (LHsCmd GhcRn)
forall body. GRHSs GhcRn body -> Maybe body
simpleGRHSs GRHSs GhcRn (LHsCmd GhcRn)
abody'
            , Just LHsCmd GhcRn
bbody <- GRHSs GhcRn (LHsCmd GhcRn) -> Maybe (LHsCmd GhcRn)
forall body. GRHSs GhcRn body -> Maybe body
simpleGRHSs GRHSs GhcRn (LHsCmd GhcRn)
bbody'

            -> do
                Expression (Var b a)
expr' <- Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
forall b a.
Names
-> Map Name b -> LHsExpr GhcRn -> Rewrite (Expression (Var b a))
parseExpr Names
names Map Name b
ctx LHsExpr GhcRn
expr

                SomePattern Pattern sh Name
apat <- LPat GhcRn -> Rewrite (SomePattern Name)
parsePat LPat GhcRn
aarg
                SomePattern Pattern sh Name
bpat <- LPat GhcRn -> Rewrite (SomePattern Name)
parsePat LPat GhcRn
barg

                Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
acont <- Names
-> Map Name (Var (Index sh) b)
-> LHsCmd GhcRn
-> Rewrite
     (Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a))
forall b a.
Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseCmd Names
names (Map Name b -> Pattern sh Name -> Map Name (Var (Index sh) b)
forall b (sh :: Shape).
Map Name b -> Pattern sh Name -> Map Name (Var (Index sh) b)
combineMaps Map Name b
ctx Pattern sh Name
apat) LHsCmd GhcRn
abody
                Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
bcont <- Names
-> Map Name (Var (Index sh) b)
-> LHsCmd GhcRn
-> Rewrite
     (Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a))
forall b a.
Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseCmd Names
names (Map Name b -> Pattern sh Name -> Map Name (Var (Index sh) b)
forall b (sh :: Shape).
Map Name b -> Pattern sh Name -> Map Name (Var (Index sh) b)
combineMaps Map Name b
ctx Pattern sh Name
bpat) LHsCmd GhcRn
bbody

                -- Error $ \dflags -> putError dflags noSrcSpan $ GHC.text "TODO"
                --     GHC.$$ GHC.ppr acon
                --     GHC.$$ GHC.ppr bcon
                --     GHC.$$ GHC.ppr aarg
                --     GHC.$$ GHC.ppr barg
                --     GHC.$$ GHC.ppr abody
                --     GHC.$$ GHC.ppr bbody

                Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Continuation (LHsExpr GhcRn) (Var b a)
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ Expression (Var b a)
-> Pattern sh Name
-> Pattern sh Name
-> Continuation (LHsExpr GhcRn) (Var (Index sh) (Var b a))
-> Continuation (LHsExpr GhcRn) (Var (Index sh) (Var b a))
-> Continuation (LHsExpr GhcRn) (Var b a)
forall a (shA :: Shape) (shB :: Shape).
Expression a
-> Pattern shA Name
-> Pattern shB Name
-> Continuation (LHsExpr GhcRn) (Var (Index shA) a)
-> Continuation (LHsExpr GhcRn) (Var (Index shB) a)
-> Continuation (LHsExpr GhcRn) a
caseCont Expression (Var b a)
expr' Pattern sh Name
apat Pattern sh Name
bpat ((Var (Var (Index sh) b) a -> Var (Index sh) (Var b a))
-> Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
-> Continuation (LHsExpr GhcRn) (Var (Index sh) (Var b a))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Var (Var (Index sh) b) a -> Var (Index sh) (Var b a)
forall (p :: * -> * -> *) a b c.
Assoc p =>
p (p a b) c -> p a (p b c)
assoc Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
acont) ((Var (Var (Index sh) b) a -> Var (Index sh) (Var b a))
-> Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
-> Continuation (LHsExpr GhcRn) (Var (Index sh) (Var b a))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Var (Var (Index sh) b) a -> Var (Index sh) (Var b a)
forall (p :: * -> * -> *) a b c.
Assoc p =>
p (p a b) c -> p a (p b c)
assoc Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
bcont)

        L SrcSpan
l [LMatch GhcRn (LHsCmd GhcRn)]
_ -> (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ())
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
            DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Overloaded:Categories only case of Left and Right are supported"
                SDoc -> SDoc -> SDoc
GHC.$$ String -> SDoc
GHC.text (Located [LMatch GhcRn (LHsCmd GhcRn)] -> String
forall a. Data a => a -> String
SYB.gshow (MatchGroup GhcRn (LHsCmd GhcRn)
-> Located [LMatch GhcRn (LHsCmd GhcRn)]
forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts MatchGroup GhcRn (LHsCmd GhcRn)
matchGroup))
parseCmd Names
_     Map Name b
_   (L SrcSpan
l HsCmd GhcRn
cmd) =
    (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ())
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
        DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Unsupported command in proc for Overloaded:Categories"
            SDoc -> SDoc -> SDoc
GHC.$$ HsCmd GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr HsCmd GhcRn
cmd
            SDoc -> SDoc -> SDoc
GHC.$$ String -> SDoc
GHC.text (HsCmd GhcRn -> String
forall a. Data a => a -> String
SYB.gshow HsCmd GhcRn
cmd)

simpleGRHSs :: GRHSs GhcRn body -> Maybe body
simpleGRHSs :: GRHSs GhcRn body -> Maybe body
simpleGRHSs (GRHSs XCGRHSs GhcRn body
_ [L SrcSpan
_ (GRHS XCGRHS GhcRn body
_ [] body
body)] (L SrcSpan
_ (EmptyLocalBinds XEmptyLocalBinds GhcRn GhcRn
_))) = body -> Maybe body
forall a. a -> Maybe a
Just body
body
simpleGRHSs GRHSs GhcRn body
_ = Maybe body
forall a. Maybe a
Nothing

parseTerm
    :: Names
    -> LHsExpr GhcRn
    -> Rewrite (Morphism (LHsExpr GhcRn))
parseTerm :: Names -> LHsExpr GhcRn -> Rewrite (Morphism (LHsExpr GhcRn))
parseTerm Names {catNames :: Names -> CatNames
catNames = CatNames {Name
catEvalName :: CatNames -> Name
catDistrName :: CatNames -> Name
catFaninName :: CatNames -> Name
catInrName :: CatNames -> Name
catInlName :: CatNames -> Name
catFanoutName :: CatNames -> Name
catProj2Name :: CatNames -> Name
catProj1Name :: CatNames -> Name
catTerminalName :: CatNames -> Name
catComposeName :: CatNames -> Name
catIdentityName :: CatNames -> Name
catEvalName :: Name
catDistrName :: Name
catFaninName :: Name
catInrName :: Name
catInlName :: Name
catFanoutName :: Name
catProj2Name :: Name
catProj1Name :: Name
catTerminalName :: Name
catComposeName :: Name
catIdentityName :: Name
..}} (L SrcSpan
_ (HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
name)))
    | IdP GhcRn
Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
catIdentityName = Morphism (LHsExpr GhcRn) -> Rewrite (Morphism (LHsExpr GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return Morphism (LHsExpr GhcRn)
forall term. Morphism term
MId
parseTerm Names
_ LHsExpr GhcRn
term = Morphism (LHsExpr GhcRn) -> Rewrite (Morphism (LHsExpr GhcRn))
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr GhcRn -> Morphism (LHsExpr GhcRn)
forall term. term -> Morphism term
MTerm LHsExpr GhcRn
term)

parseStmts
    :: Names
    -> Map GHC.Name b
    -> SrcSpan
    -> [CmdLStmt GhcRn]
    -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
#if MIN_VERSION_ghc(9,0,1)
parseStmts names ctx _ (L l (BindStmt _ pat body) : next) = do
#else
parseStmts :: Names
-> Map Name b
-> SrcSpan
-> [CmdLStmt GhcRn]
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseStmts Names
names Map Name b
ctx SrcSpan
_ (L SrcSpan
l (BindStmt XBindStmt GhcRn GhcRn (LHsCmd GhcRn)
_ LPat GhcRn
pat LHsCmd GhcRn
body SyntaxExpr GhcRn
_ SyntaxExpr GhcRn
_) : [CmdLStmt GhcRn]
next) = do
#endif
    SomePattern Pattern sh Name
pat' <- LPat GhcRn -> Rewrite (SomePattern Name)
parsePat LPat GhcRn
pat
    Continuation (LHsExpr GhcRn) (Var b a)
cont1 <- Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall b a.
Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseCmd Names
names Map Name b
ctx LHsCmd GhcRn
body
    Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
cont2 <- Names
-> Map Name (Var (Index sh) b)
-> SrcSpan
-> [CmdLStmt GhcRn]
-> Rewrite
     (Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a))
forall b a.
Names
-> Map Name b
-> SrcSpan
-> [CmdLStmt GhcRn]
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseStmts Names
names (Map Name b -> Pattern sh Name -> Map Name (Var (Index sh) b)
forall b (sh :: Shape).
Map Name b -> Pattern sh Name -> Map Name (Var (Index sh) b)
combineMaps Map Name b
ctx Pattern sh Name
pat') SrcSpan
l [CmdLStmt GhcRn]
next
    Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Continuation (LHsExpr GhcRn) (Var b a)
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> Continuation (LHsExpr GhcRn) (Var b a)
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ Pattern sh String
-> Continuation (LHsExpr GhcRn) (Var b a)
-> Continuation (LHsExpr GhcRn) (Var (Index sh) (Var b a))
-> Continuation (LHsExpr GhcRn) (Var b a)
forall (sh :: Shape) term a.
Pattern sh String
-> Continuation term a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
compCont (Name -> String
nameToString (Name -> String) -> Pattern sh Name -> Pattern sh String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern sh Name
pat') Continuation (LHsExpr GhcRn) (Var b a)
cont1 ((Var (Var (Index sh) b) a -> Var (Index sh) (Var b a))
-> Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
-> Continuation (LHsExpr GhcRn) (Var (Index sh) (Var b a))
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Var (Var (Index sh) b) a -> Var (Index sh) (Var b a)
forall (p :: * -> * -> *) a b c.
Assoc p =>
p (p a b) c -> p a (p b c)
assoc Continuation (LHsExpr GhcRn) (Var (Var (Index sh) b) a)
cont2)
parseStmts Names
names Map Name b
ctx SrcSpan
_ [L SrcSpan
_ (LastStmt XLastStmt GhcRn GhcRn (LHsCmd GhcRn)
_ LHsCmd GhcRn
body Bool
_ SyntaxExpr GhcRn
_)] =
    Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall b a.
Names
-> Map Name b
-> LHsCmd GhcRn
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
parseCmd Names
names Map Name b
ctx LHsCmd GhcRn
body
parseStmts Names
_     Map Name b
_   SrcSpan
_ (L SrcSpan
l StmtLR GhcRn GhcRn (LHsCmd GhcRn)
stmt : [CmdLStmt GhcRn]
_) =
    (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ())
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
        DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Unsupported statement in proc-do for Overloaded:Categories"
            SDoc -> SDoc -> SDoc
GHC.$$ StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr StmtLR GhcRn GhcRn (LHsCmd GhcRn)
stmt
            SDoc -> SDoc -> SDoc
GHC.$$ String -> SDoc
GHC.text (StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> String
forall a. Data a => a -> String
SYB.gshow StmtLR GhcRn GhcRn (LHsCmd GhcRn)
stmt)
parseStmts Names
_     Map Name b
_   SrcSpan
l [] =
    (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a. (DynFlags -> IO ()) -> Rewrite a
Error ((DynFlags -> IO ())
 -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a)))
-> (DynFlags -> IO ())
-> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
        DynFlags -> SrcSpan -> SDoc -> IO ()
forall (m :: * -> *).
MonadIO m =>
DynFlags -> SrcSpan -> SDoc -> m ()
putError DynFlags
dflags SrcSpan
l (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
GHC.text String
"Empty do block in proc"

-------------------------------------------------------------------------------
-- Variables
-------------------------------------------------------------------------------

data Var b a
    = B b
    | F a
  deriving (Arity -> Var b a -> ShowS
[Var b a] -> ShowS
Var b a -> String
(Arity -> Var b a -> ShowS)
-> (Var b a -> String) -> ([Var b a] -> ShowS) -> Show (Var b a)
forall a.
(Arity -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall b a. (Show b, Show a) => Arity -> Var b a -> ShowS
forall b a. (Show b, Show a) => [Var b a] -> ShowS
forall b a. (Show b, Show a) => Var b a -> String
showList :: [Var b a] -> ShowS
$cshowList :: forall b a. (Show b, Show a) => [Var b a] -> ShowS
show :: Var b a -> String
$cshow :: forall b a. (Show b, Show a) => Var b a -> String
showsPrec :: Arity -> Var b a -> ShowS
$cshowsPrec :: forall b a. (Show b, Show a) => Arity -> Var b a -> ShowS
Show, a -> Var b b -> Var b a
(a -> b) -> Var b a -> Var b b
(forall a b. (a -> b) -> Var b a -> Var b b)
-> (forall a b. a -> Var b b -> Var b a) -> Functor (Var b)
forall a b. a -> Var b b -> Var b a
forall a b. (a -> b) -> Var b a -> Var b b
forall b a b. a -> Var b b -> Var b a
forall b a b. (a -> b) -> Var b a -> Var b b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Var b b -> Var b a
$c<$ :: forall b a b. a -> Var b b -> Var b a
fmap :: (a -> b) -> Var b a -> Var b b
$cfmap :: forall b a b. (a -> b) -> Var b a -> Var b b
Functor)

instance Bifunctor Var where
    bimap :: (a -> b) -> (c -> d) -> Var a c -> Var b d
bimap a -> b
f c -> d
_ (B a
b) = b -> Var b d
forall b a. b -> Var b a
B (a -> b
f a
b)
    bimap a -> b
_ c -> d
g (F c
a) = d -> Var b d
forall b a. a -> Var b a
F (c -> d
g c
a)

instance Assoc Var where
    assoc :: Var (Var a b) c -> Var a (Var b c)
assoc (B (B a
x)) = a -> Var a (Var b c)
forall b a. b -> Var b a
B a
x
    assoc (B (F b
y)) = Var b c -> Var a (Var b c)
forall b a. a -> Var b a
F (b -> Var b c
forall b a. b -> Var b a
B b
y)
    assoc (F c
z)     = Var b c -> Var a (Var b c)
forall b a. a -> Var b a
F (c -> Var b c
forall b a. a -> Var b a
F c
z)

    unassoc :: Var a (Var b c) -> Var (Var a b) c
unassoc (B a
x)     = Var a b -> Var (Var a b) c
forall b a. b -> Var b a
B (a -> Var a b
forall b a. b -> Var b a
B a
x)
    unassoc (F (B b
y)) = Var a b -> Var (Var a b) c
forall b a. b -> Var b a
B (b -> Var a b
forall b a. a -> Var b a
F b
y)
    unassoc (F (F c
z)) = c -> Var (Var a b) c
forall b a. a -> Var b a
F c
z

unvar :: (b -> c) -> (a -> c) -> Var b a -> c
unvar :: (b -> c) -> (a -> c) -> Var b a -> c
unvar b -> c
f a -> c
_ (B b
b) = b -> c
f b
b
unvar b -> c
_ a -> c
g (F a
a) = a -> c
g a
a

-------------------------------------------------------------------------------
-- A subset of Arrow notation syntax we support.
-------------------------------------------------------------------------------

-- | Proc syntax
data Proc term a where
    Proc :: Pattern sh String -> Continuation term (Var (Index sh) a) -> Proc term a

deriving instance (Show a, Show term) => Show (Proc term a)

instance Bifunctor Proc where
    bimap :: (a -> b) -> (c -> d) -> Proc a c -> Proc b d
bimap a -> b
f c -> d
g (Proc Pattern sh String
p Continuation a (Var (Index sh) c)
c) = Pattern sh String -> Continuation b (Var (Index sh) d) -> Proc b d
forall (sh :: Shape) term a.
Pattern sh String
-> Continuation term (Var (Index sh) a) -> Proc term a
Proc Pattern sh String
p ((a -> b)
-> (Var (Index sh) c -> Var (Index sh) d)
-> Continuation a (Var (Index sh) c)
-> Continuation b (Var (Index sh) d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f ((c -> d) -> Var (Index sh) c -> Var (Index sh) d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) Continuation a (Var (Index sh) c)
c)

data Continuation term a where
    Last :: Either (Expression a) (Morphism term) -> Expression a -> Continuation term a
      -- ^ term -< y
    Edge
        :: Pattern sh String
        -> Either (Expression a) (Morphism term)
        -> Expression a
        -> Continuation term (Var (Index sh) a)
        -> Continuation term a
      -- ^ x <- term -< y

    Split
        :: Expression a
        -> Pattern shA String
        -> Pattern shB String
        -> Continuation term (Var (Index shA) a)
        -> Continuation term (Var (Index shB) a)
        -> Continuation term a

deriving instance (Show a, Show term) => Show (Continuation term a)

instance Bifunctor Continuation where
    bimap :: (a -> b) -> (c -> d) -> Continuation a c -> Continuation b d
bimap a -> b
f c -> d
g (Last Either (Expression c) (Morphism a)
term Expression c
e)         = Either (Expression d) (Morphism b)
-> Expression d -> Continuation b d
forall a term.
Either (Expression a) (Morphism term)
-> Expression a -> Continuation term a
Last ((Expression c -> Expression d)
-> (Morphism a -> Morphism b)
-> Either (Expression c) (Morphism a)
-> Either (Expression d) (Morphism b)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((c -> d) -> Expression c -> Expression d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) ((a -> b) -> Morphism a -> Morphism b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Either (Expression c) (Morphism a)
term) ((c -> d) -> Expression c -> Expression d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Expression c
e)
    bimap a -> b
f c -> d
g (Edge Pattern sh String
p Either (Expression c) (Morphism a)
term Expression c
e Continuation a (Var (Index sh) c)
c)     = Pattern sh String
-> Either (Expression d) (Morphism b)
-> Expression d
-> Continuation b (Var (Index sh) d)
-> Continuation b d
forall (sh :: Shape) a term.
Pattern sh String
-> Either (Expression a) (Morphism term)
-> Expression a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
Edge Pattern sh String
p ((Expression c -> Expression d)
-> (Morphism a -> Morphism b)
-> Either (Expression c) (Morphism a)
-> Either (Expression d) (Morphism b)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((c -> d) -> Expression c -> Expression d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) ((a -> b) -> Morphism a -> Morphism b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Either (Expression c) (Morphism a)
term) ((c -> d) -> Expression c -> Expression d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Expression c
e) ((a -> b)
-> (Var (Index sh) c -> Var (Index sh) d)
-> Continuation a (Var (Index sh) c)
-> Continuation b (Var (Index sh) d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f ((c -> d) -> Var (Index sh) c -> Var (Index sh) d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) Continuation a (Var (Index sh) c)
c)
    bimap a -> b
f c -> d
g (Split Expression c
e Pattern shA String
pa Pattern shB String
pb Continuation a (Var (Index shA) c)
ca Continuation a (Var (Index shB) c)
cb) = Expression d
-> Pattern shA String
-> Pattern shB String
-> Continuation b (Var (Index shA) d)
-> Continuation b (Var (Index shB) d)
-> Continuation b d
forall a (shA :: Shape) (shB :: Shape) term.
Expression a
-> Pattern shA String
-> Pattern shB String
-> Continuation term (Var (Index shA) a)
-> Continuation term (Var (Index shB) a)
-> Continuation term a
Split ((c -> d) -> Expression c -> Expression d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Expression c
e) Pattern shA String
pa Pattern shB String
pb
        ((a -> b)
-> (Var (Index shA) c -> Var (Index shA) d)
-> Continuation a (Var (Index shA) c)
-> Continuation b (Var (Index shA) d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f ((c -> d) -> Var (Index shA) c -> Var (Index shA) d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) Continuation a (Var (Index shA) c)
ca)
        ((a -> b)
-> (Var (Index shB) c -> Var (Index shB) d)
-> Continuation a (Var (Index shB) c)
-> Continuation b (Var (Index shB) d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f ((c -> d) -> Var (Index shB) c -> Var (Index shB) d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g) Continuation a (Var (Index shB) c)
cb)

instance Functor (Continuation term) where
    fmap :: (a -> b) -> Continuation term a -> Continuation term b
fmap = (a -> b) -> Continuation term a -> Continuation term b
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second

compCont
    :: Pattern sh String
    -> Continuation term a
    -> Continuation term (Var (Index sh) a)
    -> Continuation term a
compCont :: Pattern sh String
-> Continuation term a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
compCont Pattern sh String
pat (Last Either (Expression a) (Morphism term)
term Expression a
expr) Continuation term (Var (Index sh) a)
c
    = Pattern sh String
-> Either (Expression a) (Morphism term)
-> Expression a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
forall (sh :: Shape) a term.
Pattern sh String
-> Either (Expression a) (Morphism term)
-> Expression a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
Edge Pattern sh String
pat Either (Expression a) (Morphism term)
term Expression a
expr Continuation term (Var (Index sh) a)
c
compCont Pattern sh String
pat (Edge Pattern sh String
pat' Either (Expression a) (Morphism term)
term Expression a
expr Continuation term (Var (Index sh) a)
c') Continuation term (Var (Index sh) a)
c
    = Pattern sh String
-> Either (Expression a) (Morphism term)
-> Expression a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
forall (sh :: Shape) a term.
Pattern sh String
-> Either (Expression a) (Morphism term)
-> Expression a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
Edge Pattern sh String
pat' Either (Expression a) (Morphism term)
term Expression a
expr
    (Continuation term (Var (Index sh) a) -> Continuation term a)
-> Continuation term (Var (Index sh) a) -> Continuation term a
forall a b. (a -> b) -> a -> b
$ Pattern sh String
-> Continuation term (Var (Index sh) a)
-> Continuation term (Var (Index sh) (Var (Index sh) a))
-> Continuation term (Var (Index sh) a)
forall (sh :: Shape) term a.
Pattern sh String
-> Continuation term a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
compCont Pattern sh String
pat Continuation term (Var (Index sh) a)
c' (Continuation term (Var (Index sh) a)
-> Continuation term (Var (Index sh) (Var (Index sh) a))
forall (f :: * -> *) a b c.
Functor f =>
f (Var a b) -> f (Var a (Var c b))
weaken1 Continuation term (Var (Index sh) a)
c)
compCont Pattern sh String
pat (Split Expression a
expr Pattern shA String
patA Pattern shB String
patB Continuation term (Var (Index shA) a)
contA Continuation term (Var (Index shB) a)
contB) Continuation term (Var (Index sh) a)
c
    = Expression a
-> Pattern shA String
-> Pattern shB String
-> Continuation term (Var (Index shA) a)
-> Continuation term (Var (Index shB) a)
-> Continuation term a
forall a (shA :: Shape) (shB :: Shape) term.
Expression a
-> Pattern shA String
-> Pattern shB String
-> Continuation term (Var (Index shA) a)
-> Continuation term (Var (Index shB) a)
-> Continuation term a
Split Expression a
expr Pattern shA String
patA Pattern shB String
patB
        (Pattern sh String
-> Continuation term (Var (Index shA) a)
-> Continuation term (Var (Index sh) (Var (Index shA) a))
-> Continuation term (Var (Index shA) a)
forall (sh :: Shape) term a.
Pattern sh String
-> Continuation term a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
compCont Pattern sh String
pat Continuation term (Var (Index shA) a)
contA (Continuation term (Var (Index sh) a)
-> Continuation term (Var (Index sh) (Var (Index shA) a))
forall (f :: * -> *) a b c.
Functor f =>
f (Var a b) -> f (Var a (Var c b))
weaken1 Continuation term (Var (Index sh) a)
c))
        (Pattern sh String
-> Continuation term (Var (Index shB) a)
-> Continuation term (Var (Index sh) (Var (Index shB) a))
-> Continuation term (Var (Index shB) a)
forall (sh :: Shape) term a.
Pattern sh String
-> Continuation term a
-> Continuation term (Var (Index sh) a)
-> Continuation term a
compCont Pattern sh String
pat Continuation term (Var (Index shB) a)
contB (Continuation term (Var (Index sh) a)
-> Continuation term (Var (Index sh) (Var (Index shB) a))
forall (f :: * -> *) a b c.
Functor f =>
f (Var a b) -> f (Var a (Var c b))
weaken1 Continuation term (Var (Index sh) a)
c))

weaken1 :: Functor f => f (Var a b) -> f (Var a (Var c b))
weaken1 :: f (Var a b) -> f (Var a (Var c b))
weaken1 = (Var a b -> Var a (Var c b)) -> f (Var a b) -> f (Var a (Var c b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Var a (Var c b))
-> (b -> Var a (Var c b)) -> Var a b -> Var a (Var c b)
forall b c a. (b -> c) -> (a -> c) -> Var b a -> c
unvar a -> Var a (Var c b)
forall b a. b -> Var b a
B (Var c b -> Var a (Var c b)
forall b a. a -> Var b a
F (Var c b -> Var a (Var c b))
-> (b -> Var c b) -> b -> Var a (Var c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Var c b
forall b a. a -> Var b a
F))

caseCont
    :: Expression a
    -> Pattern shA Plugins.Name
    -> Pattern shB Plugins.Name
    -> Continuation (LHsExpr GhcRn) (Var (Index shA) a)
    -> Continuation (LHsExpr GhcRn) (Var (Index shB) a)
    -> Continuation (LHsExpr GhcRn) a
caseCont :: Expression a
-> Pattern shA Name
-> Pattern shB Name
-> Continuation (LHsExpr GhcRn) (Var (Index shA) a)
-> Continuation (LHsExpr GhcRn) (Var (Index shB) a)
-> Continuation (LHsExpr GhcRn) a
caseCont Expression a
e Pattern shA Name
patA Pattern shB Name
patB =
    Expression a
-> Pattern shA String
-> Pattern shB String
-> Continuation (LHsExpr GhcRn) (Var (Index shA) a)
-> Continuation (LHsExpr GhcRn) (Var (Index shB) a)
-> Continuation (LHsExpr GhcRn) a
forall a (shA :: Shape) (shB :: Shape) term.
Expression a
-> Pattern shA String
-> Pattern shB String
-> Continuation term (Var (Index shA) a)
-> Continuation term (Var (Index shB) a)
-> Continuation term a
Split Expression a
e ((Name -> String) -> Pattern shA Name -> Pattern shA String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> String
nameToString Pattern shA Name
patA) ((Name -> String) -> Pattern shB Name -> Pattern shB String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> String
nameToString Pattern shB Name
patB)

-------------------------------------------------------------------------------
-- Patterns
-------------------------------------------------------------------------------

data Shape = One | Two Shape Shape

data Pattern :: Shape -> Type -> Type where
    PatternVar   :: a -> Pattern 'One a
    PatternWild  :: Pattern 'One a
    PatternTuple :: Pattern l a -> Pattern r a -> Pattern ('Two l r) a

deriving instance Show a => Show (Pattern sh a)
deriving instance Functor (Pattern sh)

data SomePattern :: Type -> Type where
    SomePattern :: Pattern sh a -> SomePattern a

data Index :: Shape -> Type where
    Here :: Index 'One
    InL  :: Index x -> Index ('Two x y)
    InR  :: Index y -> Index ('Two x y)

deriving instance Show (Index sh)

patternMap :: Ord a => Pattern sh a -> Map a (Index sh)
patternMap :: Pattern sh a -> Map a (Index sh)
patternMap (PatternVar a
x)     = a -> Index 'One -> Map a (Index 'One)
forall k a. k -> a -> Map k a
Map.singleton a
x Index 'One
Here
patternMap Pattern sh a
PatternWild        = Map a (Index sh)
forall k a. Map k a
Map.empty
patternMap (PatternTuple Pattern l a
l Pattern r a
r) = Map a (Index ('Two l r))
-> Map a (Index ('Two l r)) -> Map a (Index ('Two l r))
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
    ((Index l -> Index ('Two l r))
-> Map a (Index l) -> Map a (Index ('Two l r))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Index l -> Index ('Two l r)
forall (x :: Shape) (y :: Shape). Index x -> Index ('Two x y)
InL (Pattern l a -> Map a (Index l)
forall a (sh :: Shape). Ord a => Pattern sh a -> Map a (Index sh)
patternMap Pattern l a
l))
    ((Index r -> Index ('Two l r))
-> Map a (Index r) -> Map a (Index ('Two l r))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Index r -> Index ('Two l r)
forall (y :: Shape) (x :: Shape). Index y -> Index ('Two x y)
InR (Pattern r a -> Map a (Index r)
forall a (sh :: Shape). Ord a => Pattern sh a -> Map a (Index sh)
patternMap Pattern r a
r))

combineMaps
    :: Map Plugins.Name b
    -> Pattern sh Plugins.Name
    -> Map Plugins.Name (Var (Index sh) b)
combineMaps :: Map Name b -> Pattern sh Name -> Map Name (Var (Index sh) b)
combineMaps Map Name b
m Pattern sh Name
pat = Map Name (Var (Index sh) b)
-> Map Name (Var (Index sh) b) -> Map Name (Var (Index sh) b)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ((b -> Var (Index sh) b)
-> Map Name b -> Map Name (Var (Index sh) b)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map b -> Var (Index sh) b
forall b a. a -> Var b a
F Map Name b
m) ((Index sh -> Var (Index sh) b)
-> Map Name (Index sh) -> Map Name (Var (Index sh) b)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Index sh -> Var (Index sh) b
forall b a. b -> Var b a
B (Pattern sh Name -> Map Name (Index sh)
forall a (sh :: Shape). Ord a => Pattern sh a -> Map a (Index sh)
patternMap Pattern sh Name
pat))

-------------------------------------------------------------------------------
-- Expressions
-------------------------------------------------------------------------------

data Expression a
    = ExpressionVar a
    | ExpressionUnit
    | ExpressionTuple (Expression a) (Expression a)
    | ExpressionLeft (Expression a)
    | ExpressionRight (Expression a)
  deriving (Arity -> Expression a -> ShowS
[Expression a] -> ShowS
Expression a -> String
(Arity -> Expression a -> ShowS)
-> (Expression a -> String)
-> ([Expression a] -> ShowS)
-> Show (Expression a)
forall a. Show a => Arity -> Expression a -> ShowS
forall a. Show a => [Expression a] -> ShowS
forall a. Show a => Expression a -> String
forall a.
(Arity -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expression a] -> ShowS
$cshowList :: forall a. Show a => [Expression a] -> ShowS
show :: Expression a -> String
$cshow :: forall a. Show a => Expression a -> String
showsPrec :: Arity -> Expression a -> ShowS
$cshowsPrec :: forall a. Show a => Arity -> Expression a -> ShowS
Show, a -> Expression b -> Expression a
(a -> b) -> Expression a -> Expression b
(forall a b. (a -> b) -> Expression a -> Expression b)
-> (forall a b. a -> Expression b -> Expression a)
-> Functor Expression
forall a b. a -> Expression b -> Expression a
forall a b. (a -> b) -> Expression a -> Expression b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Expression b -> Expression a
$c<$ :: forall a b. a -> Expression b -> Expression a
fmap :: (a -> b) -> Expression a -> Expression b
$cfmap :: forall a b. (a -> b) -> Expression a -> Expression b
Functor)

-------------------------------------------------------------------------------
-- Skeleton of syntax we desugar arrow notation to
-------------------------------------------------------------------------------

-- | Note: morpisms don't have variables!
data Morphism term
    = MId
    | MCompose (Morphism term) (Morphism term)
    | MProduct (Morphism term) (Morphism term)
    | MTerminal
    | MProj1
    | MProj2
    | MInL
    | MInR
    | MCase (Morphism term) (Morphism term)
    | MDistr
    | MEval
    | MTerm term
  deriving (Arity -> Morphism term -> ShowS
[Morphism term] -> ShowS
Morphism term -> String
(Arity -> Morphism term -> ShowS)
-> (Morphism term -> String)
-> ([Morphism term] -> ShowS)
-> Show (Morphism term)
forall term. Show term => Arity -> Morphism term -> ShowS
forall term. Show term => [Morphism term] -> ShowS
forall term. Show term => Morphism term -> String
forall a.
(Arity -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Morphism term] -> ShowS
$cshowList :: forall term. Show term => [Morphism term] -> ShowS
show :: Morphism term -> String
$cshow :: forall term. Show term => Morphism term -> String
showsPrec :: Arity -> Morphism term -> ShowS
$cshowsPrec :: forall term. Show term => Arity -> Morphism term -> ShowS
Show, a -> Morphism b -> Morphism a
(a -> b) -> Morphism a -> Morphism b
(forall a b. (a -> b) -> Morphism a -> Morphism b)
-> (forall a b. a -> Morphism b -> Morphism a) -> Functor Morphism
forall a b. a -> Morphism b -> Morphism a
forall a b. (a -> b) -> Morphism a -> Morphism b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Morphism b -> Morphism a
$c<$ :: forall a b. a -> Morphism b -> Morphism a
fmap :: (a -> b) -> Morphism a -> Morphism b
$cfmap :: forall a b. (a -> b) -> Morphism a -> Morphism b
Functor)

instance Semigroup (Morphism term) where
    Morphism term
MTerminal <> :: Morphism term -> Morphism term -> Morphism term
<> Morphism term
_            = Morphism term
forall term. Morphism term
MTerminal
    Morphism term
MId       <> Morphism term
m            = Morphism term
m
    Morphism term
m         <> Morphism term
MId          = Morphism term
m
    Morphism term
MProj1    <> MProduct Morphism term
f Morphism term
_ = Morphism term
f
    Morphism term
MProj2    <> MProduct Morphism term
_ Morphism term
g = Morphism term
g
    MCase Morphism term
f Morphism term
_ <> Morphism term
MInL         = Morphism term
f
    MCase Morphism term
_ Morphism term
g <> Morphism term
MInR         = Morphism term
g
    Morphism term
f         <> Morphism term
g            = Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MCompose Morphism term
f Morphism term
g

instance Monoid (Morphism term) where
    mempty :: Morphism term
mempty  = Morphism term
forall term. Morphism term
MId
    mappend :: Morphism term -> Morphism term -> Morphism term
mappend = Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
(<>)

-------------------------------------------------------------------------------
-- Desugaring
-------------------------------------------------------------------------------

desugar :: (a -> Morphism term) -> Proc term a -> Morphism term
desugar :: (a -> Morphism term) -> Proc term a -> Morphism term
desugar a -> Morphism term
ctx (Proc Pattern sh String
p Continuation term (Var (Index sh) a)
k) = (Var (Index sh) a -> Morphism term)
-> Continuation term (Var (Index sh) a) -> Morphism term
forall a term.
(a -> Morphism term) -> Continuation term a -> Morphism term
desugarC ((Index sh -> Morphism term)
-> (a -> Morphism term) -> Var (Index sh) a -> Morphism term
forall b c a. (b -> c) -> (a -> c) -> Var b a -> c
unvar (Pattern sh String -> Index sh -> Morphism term
forall (sh :: Shape) name term.
Pattern sh name -> Index sh -> Morphism term
desugarP Pattern sh String
p) a -> Morphism term
ctx) Continuation term (Var (Index sh) a)
k

desugarC :: (a -> Morphism term) -> Continuation term a -> Morphism term
desugarC :: (a -> Morphism term) -> Continuation term a -> Morphism term
desugarC a -> Morphism term
ctx (Last (Right Morphism term
term) Expression a
e) = [Morphism term] -> Morphism term
forall a. Monoid a => [a] -> a
mconcat
    [ Morphism term
term
    , (a -> Morphism term) -> Expression a -> Morphism term
forall a term.
(a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx Expression a
e
    ]
desugarC a -> Morphism term
ctx (Last (Left Expression a
f) Expression a
e) = [Morphism term] -> Morphism term
forall a. Monoid a => [a] -> a
mconcat
    [ Morphism term
forall term. Morphism term
MEval
    , Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MProduct ((a -> Morphism term) -> Expression a -> Morphism term
forall a term.
(a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx Expression a
f) ((a -> Morphism term) -> Expression a -> Morphism term
forall a term.
(a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx Expression a
e)
    ]
desugarC a -> Morphism term
ctx (Edge Pattern sh String
p (Right Morphism term
term) Expression a
e Continuation term (Var (Index sh) a)
k) = [Morphism term] -> Morphism term
forall a. Monoid a => [a] -> a
mconcat
    [ (Var (Index sh) a -> Morphism term)
-> Continuation term (Var (Index sh) a) -> Morphism term
forall a term.
(a -> Morphism term) -> Continuation term a -> Morphism term
desugarC ((Index sh -> Morphism term)
-> (a -> Morphism term) -> Var (Index sh) a -> Morphism term
forall b c a. (b -> c) -> (a -> c) -> Var b a -> c
unvar (\Index sh
x -> Pattern sh String -> Index sh -> Morphism term
forall (sh :: Shape) name term.
Pattern sh name -> Index sh -> Morphism term
desugarP Pattern sh String
p Index sh
x Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj1) (\a
y -> a -> Morphism term
ctx a
y Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj2)) Continuation term (Var (Index sh) a)
k
    , Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MProduct
        (Morphism term
term Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> (a -> Morphism term) -> Expression a -> Morphism term
forall a term.
(a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx Expression a
e)
        Morphism term
forall term. Morphism term
MId
    ]
desugarC a -> Morphism term
ctx (Edge Pattern sh String
p (Left Expression a
f) Expression a
e Continuation term (Var (Index sh) a)
k) = [Morphism term] -> Morphism term
forall a. Monoid a => [a] -> a
mconcat
    [ (Var (Index sh) a -> Morphism term)
-> Continuation term (Var (Index sh) a) -> Morphism term
forall a term.
(a -> Morphism term) -> Continuation term a -> Morphism term
desugarC ((Index sh -> Morphism term)
-> (a -> Morphism term) -> Var (Index sh) a -> Morphism term
forall b c a. (b -> c) -> (a -> c) -> Var b a -> c
unvar (\Index sh
x -> Pattern sh String -> Index sh -> Morphism term
forall (sh :: Shape) name term.
Pattern sh name -> Index sh -> Morphism term
desugarP Pattern sh String
p Index sh
x Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MEval Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj1) (\a
y -> a -> Morphism term
ctx a
y Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj2)) Continuation term (Var (Index sh) a)
k
    , Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MProduct
        (Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MProduct ((a -> Morphism term) -> Expression a -> Morphism term
forall a term.
(a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx Expression a
f) ((a -> Morphism term) -> Expression a -> Morphism term
forall a term.
(a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx Expression a
e))
        Morphism term
forall term. Morphism term
MId
    ]
desugarC a -> Morphism term
ctx (Split Expression a
e Pattern shA String
pa Pattern shB String
pb Continuation term (Var (Index shA) a)
ka Continuation term (Var (Index shB) a)
kb) = [Morphism term] -> Morphism term
forall a. Monoid a => [a] -> a
mconcat
    [ Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MCase
        ((Var (Index shA) a -> Morphism term)
-> Continuation term (Var (Index shA) a) -> Morphism term
forall a term.
(a -> Morphism term) -> Continuation term a -> Morphism term
desugarC ((Index shA -> Morphism term)
-> (a -> Morphism term) -> Var (Index shA) a -> Morphism term
forall b c a. (b -> c) -> (a -> c) -> Var b a -> c
unvar (\Index shA
x -> Pattern shA String -> Index shA -> Morphism term
forall (sh :: Shape) name term.
Pattern sh name -> Index sh -> Morphism term
desugarP Pattern shA String
pa Index shA
x Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj1) (\a
y -> a -> Morphism term
ctx a
y Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj2)) Continuation term (Var (Index shA) a)
ka)
        ((Var (Index shB) a -> Morphism term)
-> Continuation term (Var (Index shB) a) -> Morphism term
forall a term.
(a -> Morphism term) -> Continuation term a -> Morphism term
desugarC ((Index shB -> Morphism term)
-> (a -> Morphism term) -> Var (Index shB) a -> Morphism term
forall b c a. (b -> c) -> (a -> c) -> Var b a -> c
unvar (\Index shB
x -> Pattern shB String -> Index shB -> Morphism term
forall (sh :: Shape) name term.
Pattern sh name -> Index sh -> Morphism term
desugarP Pattern shB String
pb Index shB
x Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj1) (\a
y -> a -> Morphism term
ctx a
y Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj2)) Continuation term (Var (Index shB) a)
kb)
    , Morphism term
forall term. Morphism term
MDistr
    , Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MProduct
        ((a -> Morphism term) -> Expression a -> Morphism term
forall a term.
(a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx Expression a
e)
        Morphism term
forall term. Morphism term
MId
    ]

desugarP :: Pattern sh name -> Index sh -> Morphism term
desugarP :: Pattern sh name -> Index sh -> Morphism term
desugarP (PatternVar name
_)     Index sh
Here    = Morphism term
forall term. Morphism term
MId
desugarP Pattern sh name
PatternWild        Index sh
Here    = Morphism term
forall term. Morphism term
MId
desugarP (PatternTuple Pattern l name
l Pattern r name
_) (InL Index x
i) = Pattern l name -> Index l -> Morphism term
forall (sh :: Shape) name term.
Pattern sh name -> Index sh -> Morphism term
desugarP Pattern l name
l Index l
Index x
i Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj1
desugarP (PatternTuple Pattern l name
_ Pattern r name
r) (InR Index y
i) = Pattern r name -> Index r -> Morphism term
forall (sh :: Shape) name term.
Pattern sh name -> Index sh -> Morphism term
desugarP Pattern r name
r Index r
Index y
i Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Morphism term
forall term. Morphism term
MProj2

desugarE :: (a -> Morphism term) -> Expression a -> Morphism term
desugarE :: (a -> Morphism term) -> Expression a -> Morphism term
desugarE a -> Morphism term
ctx = Expression a -> Morphism term
go where
    go :: Expression a -> Morphism term
go Expression a
ExpressionUnit        = Morphism term
forall term. Morphism term
MTerminal
    go (ExpressionVar a
a)     = a -> Morphism term
ctx a
a
    go (ExpressionTuple Expression a
x Expression a
y) = Morphism term -> Morphism term -> Morphism term
forall term. Morphism term -> Morphism term -> Morphism term
MProduct (Expression a -> Morphism term
go Expression a
x) (Expression a -> Morphism term
go Expression a
y)
    go (ExpressionLeft Expression a
x)    = Morphism term
forall term. Morphism term
MInL Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Expression a -> Morphism term
go Expression a
x
    go (ExpressionRight Expression a
y)   = Morphism term
forall term. Morphism term
MInR Morphism term -> Morphism term -> Morphism term
forall a. Semigroup a => a -> a -> a
<> Expression a -> Morphism term
go Expression a
y

-------------------------------------------------------------------------------
-- Generating
-------------------------------------------------------------------------------

generate :: Names -> Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
generate :: Names -> Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
generate Names {catNames :: Names -> CatNames
catNames = CatNames {Name
catEvalName :: Name
catDistrName :: Name
catFaninName :: Name
catInrName :: Name
catInlName :: Name
catFanoutName :: Name
catProj2Name :: Name
catProj1Name :: Name
catTerminalName :: Name
catComposeName :: Name
catIdentityName :: Name
catEvalName :: CatNames -> Name
catDistrName :: CatNames -> Name
catFaninName :: CatNames -> Name
catInrName :: CatNames -> Name
catInlName :: CatNames -> Name
catFanoutName :: CatNames -> Name
catProj2Name :: CatNames -> Name
catProj1Name :: CatNames -> Name
catTerminalName :: CatNames -> Name
catComposeName :: CatNames -> Name
catIdentityName :: CatNames -> Name
..}} = Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go where
    go :: Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go Morphism (LHsExpr GhcRn)
MId            = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catIdentityName
    go (MCompose Morphism (LHsExpr GhcRn)
f Morphism (LHsExpr GhcRn)
g) = SrcSpan -> LHsExpr GhcRn -> LHsExpr GhcRn
hsPar SrcSpan
noSrcSpan (LHsExpr GhcRn -> LHsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
hsOpApp SrcSpan
noSrcSpan (Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go Morphism (LHsExpr GhcRn)
f) (SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catComposeName) (Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go Morphism (LHsExpr GhcRn)
g)
    go (MTerm LHsExpr GhcRn
term)   = LHsExpr GhcRn
term
    go Morphism (LHsExpr GhcRn)
MTerminal      = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catTerminalName
    go Morphism (LHsExpr GhcRn)
MProj1         = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catProj1Name
    go Morphism (LHsExpr GhcRn)
MProj2         = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catProj2Name
    go (MProduct Morphism (LHsExpr GhcRn)
f Morphism (LHsExpr GhcRn)
g) = SrcSpan -> LHsExpr GhcRn -> LHsExpr GhcRn
hsPar SrcSpan
noSrcSpan (LHsExpr GhcRn -> LHsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LHsExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
hsApps SrcSpan
noSrcSpan (SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catFanoutName) [Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go Morphism (LHsExpr GhcRn)
f, Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go Morphism (LHsExpr GhcRn)
g]
    go Morphism (LHsExpr GhcRn)
MInL           = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catInlName
    go Morphism (LHsExpr GhcRn)
MInR           = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catInrName
    go Morphism (LHsExpr GhcRn)
MDistr         = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catDistrName
    go Morphism (LHsExpr GhcRn)
MEval          = SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catEvalName
    go (MCase Morphism (LHsExpr GhcRn)
f Morphism (LHsExpr GhcRn)
g)    = SrcSpan -> LHsExpr GhcRn -> LHsExpr GhcRn
hsPar SrcSpan
noSrcSpan (LHsExpr GhcRn -> LHsExpr GhcRn) -> LHsExpr GhcRn -> LHsExpr GhcRn
forall a b. (a -> b) -> a -> b
$ SrcSpan -> LHsExpr GhcRn -> [LHsExpr GhcRn] -> LHsExpr GhcRn
hsApps SrcSpan
noSrcSpan (SrcSpan -> Name -> LHsExpr GhcRn
hsVar SrcSpan
noSrcSpan Name
catFaninName) [Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go Morphism (LHsExpr GhcRn)
f, Morphism (LHsExpr GhcRn) -> LHsExpr GhcRn
go Morphism (LHsExpr GhcRn)
g]