{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module IR.DesugarPattern (
  desugarPattern,
) where

import Common.Compiler as Compiler (
  Error (PatternError),
  MonadError (throwError),
  Pass,
  fromString,
 )
import qualified IR.IR as I
import qualified IR.MangleNames as I

import Common.Pretty (Pretty (..))
import Control.Monad (forM)
import Control.Monad.State.Lazy (
  MonadState,
  StateT (..),
  gets,
  modify,
 )
import Data.Bifunctor (Bifunctor (..))
import Data.Foldable (foldrM)
import qualified Data.Map as M
import qualified Data.Set as S


type Equation = ([I.Alt I.Type], I.Expr I.Type)


data CInfo = CInfo
  { CInfo -> DConId
cName :: I.DConId
  , CInfo -> TConId
cType :: I.TConId
  , CInfo -> [Type]
argsType :: [I.Type]
  }
  deriving (CInfo -> CInfo -> Bool
(CInfo -> CInfo -> Bool) -> (CInfo -> CInfo -> Bool) -> Eq CInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CInfo -> CInfo -> Bool
$c/= :: CInfo -> CInfo -> Bool
== :: CInfo -> CInfo -> Bool
$c== :: CInfo -> CInfo -> Bool
Eq, Int -> CInfo -> ShowS
[CInfo] -> ShowS
CInfo -> String
(Int -> CInfo -> ShowS)
-> (CInfo -> String) -> ([CInfo] -> ShowS) -> Show CInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CInfo] -> ShowS
$cshowList :: [CInfo] -> ShowS
show :: CInfo -> String
$cshow :: CInfo -> String
showsPrec :: Int -> CInfo -> ShowS
$cshowsPrec :: Int -> CInfo -> ShowS
Show)


data TInfo = TInfo
  { TInfo -> TConId
tName :: I.TConId
  , TInfo -> Set DConId
tCSet :: S.Set I.DConId
  }
  deriving (TInfo -> TInfo -> Bool
(TInfo -> TInfo -> Bool) -> (TInfo -> TInfo -> Bool) -> Eq TInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TInfo -> TInfo -> Bool
$c/= :: TInfo -> TInfo -> Bool
== :: TInfo -> TInfo -> Bool
$c== :: TInfo -> TInfo -> Bool
Eq, Int -> TInfo -> ShowS
[TInfo] -> ShowS
TInfo -> String
(Int -> TInfo -> ShowS)
-> (TInfo -> String) -> ([TInfo] -> ShowS) -> Show TInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TInfo] -> ShowS
$cshowList :: [TInfo] -> ShowS
show :: TInfo -> String
$cshow :: TInfo -> String
showsPrec :: Int -> TInfo -> ShowS
$cshowsPrec :: Int -> TInfo -> ShowS
Show)


data DesugarCtx = DesugarCtx
  { DesugarCtx -> Map TConId TInfo
typeMap :: M.Map I.TConId TInfo
  , DesugarCtx -> Map DConId CInfo
consMap :: M.Map I.DConId CInfo
  , DesugarCtx -> SymTable Type
symTable :: I.SymTable I.Type
  }


newtype DesugarFn a = DesugarFn (StateT DesugarCtx Compiler.Pass a)
  deriving (a -> DesugarFn b -> DesugarFn a
(a -> b) -> DesugarFn a -> DesugarFn b
(forall a b. (a -> b) -> DesugarFn a -> DesugarFn b)
-> (forall a b. a -> DesugarFn b -> DesugarFn a)
-> Functor DesugarFn
forall a b. a -> DesugarFn b -> DesugarFn a
forall a b. (a -> b) -> DesugarFn a -> DesugarFn b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DesugarFn b -> DesugarFn a
$c<$ :: forall a b. a -> DesugarFn b -> DesugarFn a
fmap :: (a -> b) -> DesugarFn a -> DesugarFn b
$cfmap :: forall a b. (a -> b) -> DesugarFn a -> DesugarFn b
Functor) via (StateT DesugarCtx Compiler.Pass)
  deriving (Functor DesugarFn
a -> DesugarFn a
Functor DesugarFn
-> (forall a. a -> DesugarFn a)
-> (forall a b. DesugarFn (a -> b) -> DesugarFn a -> DesugarFn b)
-> (forall a b c.
    (a -> b -> c) -> DesugarFn a -> DesugarFn b -> DesugarFn c)
-> (forall a b. DesugarFn a -> DesugarFn b -> DesugarFn b)
-> (forall a b. DesugarFn a -> DesugarFn b -> DesugarFn a)
-> Applicative DesugarFn
DesugarFn a -> DesugarFn b -> DesugarFn b
DesugarFn a -> DesugarFn b -> DesugarFn a
DesugarFn (a -> b) -> DesugarFn a -> DesugarFn b
(a -> b -> c) -> DesugarFn a -> DesugarFn b -> DesugarFn c
forall a. a -> DesugarFn a
forall a b. DesugarFn a -> DesugarFn b -> DesugarFn a
forall a b. DesugarFn a -> DesugarFn b -> DesugarFn b
forall a b. DesugarFn (a -> b) -> DesugarFn a -> DesugarFn b
forall a b c.
(a -> b -> c) -> DesugarFn a -> DesugarFn b -> DesugarFn c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: DesugarFn a -> DesugarFn b -> DesugarFn a
$c<* :: forall a b. DesugarFn a -> DesugarFn b -> DesugarFn a
*> :: DesugarFn a -> DesugarFn b -> DesugarFn b
$c*> :: forall a b. DesugarFn a -> DesugarFn b -> DesugarFn b
liftA2 :: (a -> b -> c) -> DesugarFn a -> DesugarFn b -> DesugarFn c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DesugarFn a -> DesugarFn b -> DesugarFn c
<*> :: DesugarFn (a -> b) -> DesugarFn a -> DesugarFn b
$c<*> :: forall a b. DesugarFn (a -> b) -> DesugarFn a -> DesugarFn b
pure :: a -> DesugarFn a
$cpure :: forall a. a -> DesugarFn a
$cp1Applicative :: Functor DesugarFn
Applicative) via (StateT DesugarCtx Compiler.Pass)
  deriving (Applicative DesugarFn
a -> DesugarFn a
Applicative DesugarFn
-> (forall a b. DesugarFn a -> (a -> DesugarFn b) -> DesugarFn b)
-> (forall a b. DesugarFn a -> DesugarFn b -> DesugarFn b)
-> (forall a. a -> DesugarFn a)
-> Monad DesugarFn
DesugarFn a -> (a -> DesugarFn b) -> DesugarFn b
DesugarFn a -> DesugarFn b -> DesugarFn b
forall a. a -> DesugarFn a
forall a b. DesugarFn a -> DesugarFn b -> DesugarFn b
forall a b. DesugarFn a -> (a -> DesugarFn b) -> DesugarFn b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> DesugarFn a
$creturn :: forall a. a -> DesugarFn a
>> :: DesugarFn a -> DesugarFn b -> DesugarFn b
$c>> :: forall a b. DesugarFn a -> DesugarFn b -> DesugarFn b
>>= :: DesugarFn a -> (a -> DesugarFn b) -> DesugarFn b
$c>>= :: forall a b. DesugarFn a -> (a -> DesugarFn b) -> DesugarFn b
$cp1Monad :: Applicative DesugarFn
Monad) via (StateT DesugarCtx Compiler.Pass)
  deriving (Monad DesugarFn
Monad DesugarFn
-> (forall a. String -> DesugarFn a) -> MonadFail DesugarFn
String -> DesugarFn a
forall a. String -> DesugarFn a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> DesugarFn a
$cfail :: forall a. String -> DesugarFn a
$cp1MonadFail :: Monad DesugarFn
MonadFail) via (StateT DesugarCtx Compiler.Pass)
  deriving (MonadError Error) via (StateT DesugarCtx Compiler.Pass)
  deriving (MonadState DesugarCtx) via (StateT DesugarCtx Compiler.Pass)


unDesugarFn :: DesugarFn a -> StateT DesugarCtx Compiler.Pass a
unDesugarFn :: DesugarFn a -> StateT DesugarCtx Pass a
unDesugarFn (DesugarFn StateT DesugarCtx Pass a
a) = StateT DesugarCtx Pass a
a


freshVar :: I.Type -> DesugarFn I.VarId
freshVar :: Type -> DesugarFn VarId
freshVar Type
t = do
  SymTable Type
syms <- (DesugarCtx -> SymTable Type) -> DesugarFn (SymTable Type)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets DesugarCtx -> SymTable Type
symTable
  let origin :: VarId
origin = VarId
"__anonymous_pattern"
      name :: VarId
name = SymTable Type -> VarId -> VarId
forall t. Map VarId t -> VarId -> VarId
I.pickId SymTable Type
syms VarId
origin
      syms' :: SymTable Type
syms' = VarId -> SymInfo Type -> SymTable Type -> SymTable Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VarId
name SymInfo :: forall t. VarId -> t -> SymInfo t
I.SymInfo{symOrigin :: VarId
I.symOrigin = VarId
origin, symType :: Type
I.symType = Type
t} SymTable Type
syms
  (DesugarCtx -> DesugarCtx) -> DesugarFn ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DesugarCtx -> DesugarCtx) -> DesugarFn ())
-> (DesugarCtx -> DesugarCtx) -> DesugarFn ()
forall a b. (a -> b) -> a -> b
$ \DesugarCtx
ctx -> DesugarCtx
ctx{symTable :: SymTable Type
symTable = SymTable Type
syms'}
  VarId -> DesugarFn VarId
forall (m :: * -> *) a. Monad m => a -> m a
return VarId
name


-- TODO: this should be a pattern synonym
unreachableExpr :: I.Type -> I.Expr I.Type
unreachableExpr :: Type -> Expr Type
unreachableExpr = ExceptType -> Type -> Expr Type
forall t. ExceptType -> t -> Expr t
I.Exception (ExceptType -> Type -> Expr Type)
-> ExceptType -> Type -> Expr Type
forall a b. (a -> b) -> a -> b
$ Literal -> ExceptType
I.ExceptDefault (Literal -> ExceptType) -> Literal -> ExceptType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
I.LitIntegral Integer
0


desugarPattern :: I.Program I.Type -> Compiler.Pass (I.Program I.Type)
desugarPattern :: Program Type -> Pass (Program Type)
desugarPattern p :: Program Type
p@I.Program{programDefs :: forall t. Program t -> [(Binder t, Expr t)]
I.programDefs = [(Binder Type, Expr Type)]
defs, typeDefs :: forall t. Program t -> [(TConId, TypeDef)]
I.typeDefs = [(TConId, TypeDef)]
tds, symTable :: forall t. Program t -> Map VarId (SymInfo t)
I.symTable = SymTable Type
syms} = do
  ([(Binder Type, Expr Type)]
defs', DesugarCtx -> SymTable Type
symTable -> SymTable Type
syms') <- StateT DesugarCtx Pass [(Binder Type, Expr Type)]
-> DesugarCtx -> Pass ([(Binder Type, Expr Type)], DesugarCtx)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (DesugarFn [(Binder Type, Expr Type)]
-> StateT DesugarCtx Pass [(Binder Type, Expr Type)]
forall a. DesugarFn a -> StateT DesugarCtx Pass a
unDesugarFn (DesugarFn [(Binder Type, Expr Type)]
 -> StateT DesugarCtx Pass [(Binder Type, Expr Type)])
-> DesugarFn [(Binder Type, Expr Type)]
-> StateT DesugarCtx Pass [(Binder Type, Expr Type)]
forall a b. (a -> b) -> a -> b
$ ((Binder Type, Expr Type) -> DesugarFn (Binder Type, Expr Type))
-> [(Binder Type, Expr Type)]
-> DesugarFn [(Binder Type, Expr Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Binder Type, Expr Type) -> DesugarFn (Binder Type, Expr Type)
forall t. (t, Expr Type) -> DesugarFn (t, Expr Type)
desugarExprsDefs [(Binder Type, Expr Type)]
defs) DesugarCtx
initCtx
  Program Type -> Pass (Program Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Program Type -> Pass (Program Type))
-> Program Type -> Pass (Program Type)
forall a b. (a -> b) -> a -> b
$ Program Type
p{programDefs :: [(Binder Type, Expr Type)]
I.programDefs = [(Binder Type, Expr Type)]
defs', symTable :: SymTable Type
I.symTable = SymTable Type
syms'}
 where
  desugarExprsDefs :: (t, Expr Type) -> DesugarFn (t, Expr Type)
desugarExprsDefs (t
vs, Expr Type
es) = (t
vs,) (Expr Type -> (t, Expr Type))
-> DesugarFn (Expr Type) -> DesugarFn (t, Expr Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> DesugarFn (Expr Type)
desugarExpr Expr Type
es
  initCtx :: DesugarCtx
initCtx = DesugarCtx :: Map TConId TInfo -> Map DConId CInfo -> SymTable Type -> DesugarCtx
DesugarCtx{typeMap :: Map TConId TInfo
typeMap = [(TConId, TypeDef)] -> Map TConId TInfo
buildTypeMap [(TConId, TypeDef)]
tds, consMap :: Map DConId CInfo
consMap = [(TConId, TypeDef)] -> Map DConId CInfo
buildConsMap [(TConId, TypeDef)]
tds, symTable :: SymTable Type
symTable = SymTable Type
syms}


desugarExpr :: I.Expr I.Type -> DesugarFn (I.Expr I.Type)
desugarExpr :: Expr Type -> DesugarFn (Expr Type)
desugarExpr (I.App Expr Type
e1 Expr Type
e2 Type
t) = Expr Type -> Expr Type -> Type -> Expr Type
forall t. Expr t -> Expr t -> t -> Expr t
I.App (Expr Type -> Expr Type -> Type -> Expr Type)
-> DesugarFn (Expr Type)
-> DesugarFn (Expr Type -> Type -> Expr Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> DesugarFn (Expr Type)
desugarExpr Expr Type
e1 DesugarFn (Expr Type -> Type -> Expr Type)
-> DesugarFn (Expr Type) -> DesugarFn (Type -> Expr Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Type -> DesugarFn (Expr Type)
desugarExpr Expr Type
e2 DesugarFn (Type -> Expr Type)
-> DesugarFn Type -> DesugarFn (Expr Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> DesugarFn Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
desugarExpr (I.Let ([(Binder Type, Expr Type)] -> ([Binder Type], [Expr Type])
forall a b. [(a, b)] -> ([a], [b])
unzip -> ([Binder Type]
bs, [Expr Type]
es)) Expr Type
e Type
t) =
  [(Binder Type, Expr Type)] -> Expr Type -> Type -> Expr Type
forall t. [(Binder t, Expr t)] -> Expr t -> t -> Expr t
I.Let ([(Binder Type, Expr Type)] -> Expr Type -> Type -> Expr Type)
-> DesugarFn [(Binder Type, Expr Type)]
-> DesugarFn (Expr Type -> Type -> Expr Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Binder Type] -> [Expr Type] -> [(Binder Type, Expr Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Binder Type]
bs ([Expr Type] -> [(Binder Type, Expr Type)])
-> DesugarFn [Expr Type] -> DesugarFn [(Binder Type, Expr Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Type -> DesugarFn (Expr Type))
-> [Expr Type] -> DesugarFn [Expr Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Type -> DesugarFn (Expr Type)
desugarExpr [Expr Type]
es) DesugarFn (Expr Type -> Type -> Expr Type)
-> DesugarFn (Expr Type) -> DesugarFn (Type -> Expr Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr Type -> DesugarFn (Expr Type)
desugarExpr Expr Type
e DesugarFn (Type -> Expr Type)
-> DesugarFn Type -> DesugarFn (Expr Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> DesugarFn Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
desugarExpr (I.Lambda Binder Type
b Expr Type
e Type
t) = Binder Type -> Expr Type -> Type -> Expr Type
forall t. Binder t -> Expr t -> t -> Expr t
I.Lambda Binder Type
b (Expr Type -> Type -> Expr Type)
-> DesugarFn (Expr Type) -> DesugarFn (Type -> Expr Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> DesugarFn (Expr Type)
desugarExpr Expr Type
e DesugarFn (Type -> Expr Type)
-> DesugarFn Type -> DesugarFn (Expr Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> DesugarFn Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
desugarExpr (I.Prim Primitive
p [Expr Type]
es Type
t) = Primitive -> [Expr Type] -> Type -> Expr Type
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
p ([Expr Type] -> Type -> Expr Type)
-> DesugarFn [Expr Type] -> DesugarFn (Type -> Expr Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Type -> DesugarFn (Expr Type))
-> [Expr Type] -> DesugarFn [Expr Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Type -> DesugarFn (Expr Type)
desugarExpr [Expr Type]
es DesugarFn (Type -> Expr Type)
-> DesugarFn Type -> DesugarFn (Expr Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> DesugarFn Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
desugarExpr (I.Match Expr Type
e [(Alt Type, Expr Type)]
arms Type
t) = do
  [([Alt Type], Expr Type)]
eqns <- [(Alt Type, Expr Type)]
-> ((Alt Type, Expr Type) -> DesugarFn ([Alt Type], Expr Type))
-> DesugarFn [([Alt Type], Expr Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Alt Type, Expr Type)]
arms (((Alt Type, Expr Type) -> DesugarFn ([Alt Type], Expr Type))
 -> DesugarFn [([Alt Type], Expr Type)])
-> ((Alt Type, Expr Type) -> DesugarFn ([Alt Type], Expr Type))
-> DesugarFn [([Alt Type], Expr Type)]
forall a b. (a -> b) -> a -> b
$ \(Alt Type
a, Expr Type
body) -> do
    -- Generate an 'Equation' for each arm
    Expr Type
body' <- Expr Type -> DesugarFn (Expr Type)
desugarExpr Expr Type
body
    ([Alt Type], Expr Type) -> DesugarFn ([Alt Type], Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Alt Type
a], Expr Type
body')
  case Expr Type
e of
    I.Var VarId
_ Type
_ -> [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatch [Expr Type
e] [([Alt Type], Expr Type)]
eqns (Type -> Expr Type
unreachableExpr Type
t) -- TODO: add let alias
    Expr Type
_ -> do
      -- Bind scrutinee to a variable before threading it through desugarMatch
      let et :: Type
et = Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
e
      VarId
var <- Type -> DesugarFn VarId
freshVar Type
et
      [(Binder Type, Expr Type)] -> Expr Type -> Type -> Expr Type
forall t. [(Binder t, Expr t)] -> Expr t -> t -> Expr t
I.Let [(VarId -> Type -> Binder Type
forall t. VarId -> t -> Binder t
I.BindVar VarId
var Type
et, Expr Type
e)]
        (Expr Type -> Type -> Expr Type)
-> DesugarFn (Expr Type) -> DesugarFn (Type -> Expr Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatch [VarId -> Type -> Expr Type
forall t. VarId -> t -> Expr t
I.Var VarId
var Type
et] [([Alt Type], Expr Type)]
eqns (Type -> Expr Type
unreachableExpr Type
t)
        DesugarFn (Type -> Expr Type)
-> DesugarFn Type -> DesugarFn (Expr Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> DesugarFn Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
et
desugarExpr Expr Type
e = Expr Type -> DesugarFn (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Type
e


desugarMatch ::
  [I.Expr I.Type] ->
  [Equation] ->
  I.Expr I.Type -> -- Default expression the 'I.Match' should return
  DesugarFn (I.Expr I.Type)
desugarMatch :: [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatch [] [] Expr Type
def = Expr Type -> DesugarFn (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Type
def
desugarMatch [] (([], Expr Type
e) : [([Alt Type], Expr Type)]
_) Expr Type
_ = Expr Type -> DesugarFn (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Type
e
desugarMatch [] [([Alt Type], Expr Type)]
_ Expr Type
_ = String -> DesugarFn (Expr Type)
forall a. HasCallStack => String -> a
error String
"can't happen 1"
desugarMatch [Expr Type]
us [([Alt Type], Expr Type)]
eqs Expr Type
def = ([([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type))
-> Expr Type
-> [[([Alt Type], Expr Type)]]
-> DesugarFn (Expr Type)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchGen Expr Type
def ([[([Alt Type], Expr Type)]] -> DesugarFn (Expr Type))
-> [[([Alt Type], Expr Type)]] -> DesugarFn (Expr Type)
forall a b. (a -> b) -> a -> b
$ [([Alt Type], Expr Type)] -> [[([Alt Type], Expr Type)]]
partitionEqs [([Alt Type], Expr Type)]
eqs
 where
  desugarMatchGen :: [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchGen qs :: [([Alt Type], Expr Type)]
qs@(([Alt Type], Expr Type)
q : [([Alt Type], Expr Type)]
_)
    | ([Alt Type], Expr Type) -> Bool
forall t b. ([Alt t], b) -> Bool
isVarEq ([Alt Type], Expr Type)
q = [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchVar [Expr Type]
us [([Alt Type], Expr Type)]
qs
    | ([Alt Type], Expr Type) -> Bool
forall t b. ([Alt t], b) -> Bool
isConsEq ([Alt Type], Expr Type)
q = [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchCons [Expr Type]
us [([Alt Type], Expr Type)]
qs
    | ([Alt Type], Expr Type) -> Bool
forall t b. ([Alt t], b) -> Bool
isLitEq ([Alt Type], Expr Type)
q = [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchLit [Expr Type]
us [([Alt Type], Expr Type)]
qs
    | ([Alt Type], Expr Type) -> Bool
forall t b. ([Alt t], b) -> Bool
isWildEq ([Alt Type], Expr Type)
q = [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchWild [Expr Type]
us [([Alt Type], Expr Type)]
qs
  desugarMatchGen [([Alt Type], Expr Type)]
_ = String -> Expr Type -> DesugarFn (Expr Type)
forall a. HasCallStack => String -> a
error String
"can't happen 2"

  partitionEqs :: [Equation] -> [[Equation]]
  partitionEqs :: [([Alt Type], Expr Type)] -> [[([Alt Type], Expr Type)]]
partitionEqs [] = []
  partitionEqs [([Alt Type], Expr Type)
x] = [[([Alt Type], Expr Type)
x]]
  partitionEqs (([Alt Type], Expr Type)
x : ([Alt Type], Expr Type)
x' : [([Alt Type], Expr Type)]
xs)
    | ([Alt Type], Expr Type) -> ([Alt Type], Expr Type) -> Bool
forall t b t b. ([Alt t], b) -> ([Alt t], b) -> Bool
sameGroup ([Alt Type], Expr Type)
x ([Alt Type], Expr Type)
x' = ([Alt Type], Expr Type)
-> [[([Alt Type], Expr Type)]] -> [[([Alt Type], Expr Type)]]
forall a. a -> [[a]] -> [[a]]
tack ([Alt Type], Expr Type)
x ([([Alt Type], Expr Type)] -> [[([Alt Type], Expr Type)]]
partitionEqs (([Alt Type], Expr Type)
x' ([Alt Type], Expr Type)
-> [([Alt Type], Expr Type)] -> [([Alt Type], Expr Type)]
forall a. a -> [a] -> [a]
: [([Alt Type], Expr Type)]
xs))
    | Bool
otherwise = [([Alt Type], Expr Type)
x] [([Alt Type], Expr Type)]
-> [[([Alt Type], Expr Type)]] -> [[([Alt Type], Expr Type)]]
forall a. a -> [a] -> [a]
: [([Alt Type], Expr Type)] -> [[([Alt Type], Expr Type)]]
partitionEqs (([Alt Type], Expr Type)
x' ([Alt Type], Expr Type)
-> [([Alt Type], Expr Type)] -> [([Alt Type], Expr Type)]
forall a. a -> [a] -> [a]
: [([Alt Type], Expr Type)]
xs)

  tack :: a -> [[a]] -> [[a]]
tack a
y [[a]]
yss = (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [[a]] -> [a]
forall a. [a] -> a
head [[a]]
yss) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
forall a. [a] -> [a]
tail [[a]]
yss

  sameGroup :: ([Alt t], b) -> ([Alt t], b) -> Bool
sameGroup (I.AltLit{} : [Alt t]
_, b
_) (I.AltLit{} : [Alt t]
_, b
_) = Bool
True
  sameGroup (I.AltBinder{} : [Alt t]
_, b
_) (I.AltBinder{} : [Alt t]
_, b
_) = Bool
True
  sameGroup (I.AltData{} : [Alt t]
_, b
_) (I.AltData{} : [Alt t]
_, b
_) = Bool
True
  sameGroup ([Alt t], b)
_ ([Alt t], b)
_ = Bool
False

  isWildEq :: ([Alt t], b) -> Bool
isWildEq (I.AltBinder I.BindAnon{} : [Alt t]
_, b
_) = Bool
True
  isWildEq ([Alt t], b)
_ = Bool
False
  isVarEq :: ([Alt t], b) -> Bool
isVarEq (I.AltBinder I.BindVar{} : [Alt t]
_, b
_) = Bool
True
  isVarEq ([Alt t], b)
_ = Bool
False
  isConsEq :: ([Alt t], b) -> Bool
isConsEq (I.AltData{} : [Alt t]
_, b
_) = Bool
True
  isConsEq ([Alt t], b)
_ = Bool
False
  isLitEq :: ([Alt t], b) -> Bool
isLitEq (I.AltLit{} : [Alt t]
_, b
_) = Bool
True
  isLitEq ([Alt t], b)
_ = Bool
False


desugarMatchVar :: [I.Expr I.Type] -> [Equation] -> I.Expr I.Type -> DesugarFn (I.Expr I.Type)
desugarMatchVar :: [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchVar (Expr Type
u : [Expr Type]
us) [([Alt Type], Expr Type)]
qs Expr Type
def =
  -- Create a let-bound alias for 'u' named 'v' in each equation
  let qs' :: [([Alt Type], Expr Type)]
qs' = [([Alt Type]
ps, [(Binder Type, Expr Type)] -> Expr Type -> Type -> Expr Type
forall t. [(Binder t, Expr t)] -> Expr t -> t -> Expr t
I.Let [(Binder Type
v, Expr Type
u)] Expr Type
e (Type -> Expr Type) -> Type -> Expr Type
forall a b. (a -> b) -> a -> b
$ Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
e) | (I.AltBinder Binder Type
v : [Alt Type]
ps, Expr Type
e) <- [([Alt Type], Expr Type)]
qs]
   in [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatch [Expr Type]
us [([Alt Type], Expr Type)]
qs' Expr Type
def
desugarMatchVar [] [([Alt Type], Expr Type)]
_ Expr Type
_ = String -> DesugarFn (Expr Type)
forall a. HasCallStack => String -> a
error String
"can't happen 3"


desugarMatchWild :: [I.Expr I.Type] -> [Equation] -> I.Expr I.Type -> DesugarFn (I.Expr I.Type)
desugarMatchWild :: [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchWild (Expr Type
_ : [Expr Type]
us) [([Alt Type], Expr Type)]
qs Expr Type
def =
  -- Discard first 'I.Alt' from each equation
  let qs' :: [([Alt Type], Expr Type)]
qs' = [([Alt Type]
ps, Expr Type
e) | (Alt Type
_ : [Alt Type]
ps, Expr Type
e) <- [([Alt Type], Expr Type)]
qs]
   in [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatch [Expr Type]
us [([Alt Type], Expr Type)]
qs' Expr Type
def
desugarMatchWild [] [([Alt Type], Expr Type)]
_ Expr Type
_ = String -> DesugarFn (Expr Type)
forall a. HasCallStack => String -> a
error String
"can't happen 4"


desugarMatchCons :: [I.Expr I.Type] -> [Equation] -> I.Expr I.Type -> DesugarFn (I.Expr I.Type)
desugarMatchCons :: [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchCons (Expr Type
u : [Expr Type]
us) qs :: [([Alt Type], Expr Type)]
qs@(([Alt Type], Expr Type)
q : [([Alt Type], Expr Type)]
_) Expr Type
def = do
  Set DConId
cs <- DConId -> DesugarFn (Set DConId)
getConstructors (DConId -> DesugarFn (Set DConId))
-> DConId -> DesugarFn (Set DConId)
forall a b. (a -> b) -> a -> b
$ ([Alt Type], Expr Type) -> DConId
forall t b. ([Alt t], b) -> DConId
getCon ([Alt Type], Expr Type)
q
  [(Alt Type, Expr Type)]
arms <- [DesugarFn (Alt Type, Expr Type)]
-> DesugarFn [(Alt Type, Expr Type)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [DConId
-> Type
-> [([Alt Type], Expr Type)]
-> DesugarFn (Alt Type, Expr Type)
desugarArm DConId
dcon (([Alt Type], Expr Type) -> Type
forall p b. ([Alt p], b) -> p
getTyp ([Alt Type], Expr Type)
q) (DConId -> [([Alt Type], Expr Type)]
sameConsAs DConId
dcon) | DConId
dcon <- Set DConId -> [DConId]
forall a. Set a -> [a]
S.toList Set DConId
cs]
  Expr Type -> DesugarFn (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Type -> DesugarFn (Expr Type))
-> Expr Type -> DesugarFn (Expr Type)
forall a b. (a -> b) -> a -> b
$ Expr Type -> [(Alt Type, Expr Type)] -> Type -> Expr Type
forall t. Expr t -> [(Alt t, Expr t)] -> t -> Expr t
I.Match Expr Type
u [(Alt Type, Expr Type)]
arms (Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
def)
 where
  getCon :: ([Alt t], b) -> DConId
getCon ((I.AltData DConId
dcon [Alt t]
_ t
_) : [Alt t]
_, b
_) = DConId
dcon
  getCon ([Alt t], b)
_ = String -> DConId
forall a. HasCallStack => String -> a
error String
"can't happen 5"
  getTyp :: ([Alt p], b) -> p
getTyp ((I.AltData DConId
_ [Alt p]
_ p
t) : [Alt p]
_, b
_) = p
t
  getTyp ([Alt p], b)
_ = String -> p
forall a. HasCallStack => String -> a
error String
"no no no 555"

  sameConsAs :: DConId -> [([Alt Type], Expr Type)]
sameConsAs DConId
c = (([Alt Type], Expr Type) -> Bool)
-> [([Alt Type], Expr Type)] -> [([Alt Type], Expr Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((DConId -> DConId -> Bool
forall a. Eq a => a -> a -> Bool
== DConId
c) (DConId -> Bool)
-> (([Alt Type], Expr Type) -> DConId)
-> ([Alt Type], Expr Type)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Alt Type], Expr Type) -> DConId
forall t b. ([Alt t], b) -> DConId
getCon) [([Alt Type], Expr Type)]
qs

  desugarArm :: I.DConId -> I.Type -> [Equation] -> DesugarFn (I.Alt I.Type, I.Expr I.Type)
  desugarArm :: DConId
-> Type
-> [([Alt Type], Expr Type)]
-> DesugarFn (Alt Type, Expr Type)
desugarArm DConId
dcon Type
dconTyp [([Alt Type], Expr Type)]
qs' = do
    [Type]
argsTyps <- CInfo -> [Type]
argsType (CInfo -> [Type]) -> DesugarFn CInfo -> DesugarFn [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DConId -> DesugarFn CInfo
getCInfo DConId
dcon

    ([(Alt Type, Expr Type)] -> ([Alt Type], [Expr Type])
forall a b. [(a, b)] -> ([a], [b])
unzip -> ([Alt Type]
bs', [Expr Type]
us')) <- [Type]
-> (Type -> DesugarFn (Alt Type, Expr Type))
-> DesugarFn [(Alt Type, Expr Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Type]
argsTyps ((Type -> DesugarFn (Alt Type, Expr Type))
 -> DesugarFn [(Alt Type, Expr Type)])
-> (Type -> DesugarFn (Alt Type, Expr Type))
-> DesugarFn [(Alt Type, Expr Type)]
forall a b. (a -> b) -> a -> b
$ \Type
argTyp -> do
      VarId
name <- Type -> DesugarFn VarId
freshVar Type
argTyp
      (Alt Type, Expr Type) -> DesugarFn (Alt Type, Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Type -> Alt Type
forall t. Binder t -> Alt t
I.AltBinder (Binder Type -> Alt Type) -> Binder Type -> Alt Type
forall a b. (a -> b) -> a -> b
$ VarId -> Type -> Binder Type
forall t. VarId -> t -> Binder t
I.BindVar VarId
name Type
argTyp, VarId -> Type -> Expr Type
forall t. VarId -> t -> Expr t
I.Var VarId
name Type
argTyp)

    Expr Type
body <-
      if [([Alt Type], Expr Type)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Alt Type], Expr Type)]
qs'
        then do
          -- We're done desugaring this equation, just use default body
          Expr Type -> DesugarFn (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Type
def
        else do
          -- Recursively generate body from remaining equations
          let qs'' :: [([Alt Type], Expr Type)]
qs'' = [([Alt Type]
as' [Alt Type] -> [Alt Type] -> [Alt Type]
forall a. [a] -> [a] -> [a]
++ [Alt Type]
as, Expr Type
e) | ((I.AltData DConId
_ [Alt Type]
as' Type
_) : [Alt Type]
as, Expr Type
e) <- [([Alt Type], Expr Type)]
qs']
          [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatch ([Expr Type]
us' [Expr Type] -> [Expr Type] -> [Expr Type]
forall a. [a] -> [a] -> [a]
++ [Expr Type]
us) [([Alt Type], Expr Type)]
qs'' Expr Type
def

    (Alt Type, Expr Type) -> DesugarFn (Alt Type, Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (DConId -> [Alt Type] -> Type -> Alt Type
forall t. DConId -> [Alt t] -> t -> Alt t
I.AltData DConId
dcon [Alt Type]
bs' Type
dconTyp, Expr Type
body)
desugarMatchCons [Expr Type]
_ [([Alt Type], Expr Type)]
_ Expr Type
_ = String -> DesugarFn (Expr Type)
forall a. HasCallStack => String -> a
error String
"can't happen 7"


desugarMatchLit :: [I.Expr I.Type] -> [Equation] -> I.Expr I.Type -> DesugarFn (I.Expr I.Type)
desugarMatchLit :: [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatchLit (Expr Type
u : [Expr Type]
us) [([Alt Type], Expr Type)]
qs Expr Type
def = do
  [(Alt Type, Expr Type)]
arms <- [DesugarFn (Alt Type, Expr Type)]
-> DesugarFn [(Alt Type, Expr Type)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [(Alt Type
a,) (Expr Type -> (Alt Type, Expr Type))
-> DesugarFn (Expr Type) -> DesugarFn (Alt Type, Expr Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr Type]
-> [([Alt Type], Expr Type)] -> Expr Type -> DesugarFn (Expr Type)
desugarMatch [Expr Type]
us [([Alt Type]
as, Expr Type
e)] Expr Type
def | (Alt Type
a : [Alt Type]
as, Expr Type
e) <- [([Alt Type], Expr Type)]
qs]
  let defAlt :: Alt Type
defAlt = Binder Type -> Alt Type
forall t. Binder t -> Alt t
I.AltBinder (Binder Type -> Alt Type) -> Binder Type -> Alt Type
forall a b. (a -> b) -> a -> b
$ Type -> Binder Type
forall t. t -> Binder t
I.BindAnon (Type -> Binder Type) -> Type -> Binder Type
forall a b. (a -> b) -> a -> b
$ Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
u
  Expr Type -> DesugarFn (Expr Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Type -> DesugarFn (Expr Type))
-> Expr Type -> DesugarFn (Expr Type)
forall a b. (a -> b) -> a -> b
$ Expr Type -> [(Alt Type, Expr Type)] -> Type -> Expr Type
forall t. Expr t -> [(Alt t, Expr t)] -> t -> Expr t
I.Match Expr Type
u ([(Alt Type, Expr Type)]
arms [(Alt Type, Expr Type)]
-> [(Alt Type, Expr Type)] -> [(Alt Type, Expr Type)]
forall a. [a] -> [a] -> [a]
++ [(Alt Type
defAlt, Expr Type
def)]) (Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
def)
--                            ^^^^^^^^^^^
-- WARN: we assume that PatLit is never exhaustive, so we add a default case
desugarMatchLit [Expr Type]
_ [([Alt Type], Expr Type)]
_ Expr Type
_ = String -> DesugarFn (Expr Type)
forall a. HasCallStack => String -> a
error String
"can't happen 8"


getConstructors :: I.DConId -> DesugarFn (S.Set I.DConId)
getConstructors :: DConId -> DesugarFn (Set DConId)
getConstructors DConId
dcon = do
  CInfo
c <- DConId -> DesugarFn CInfo
getCInfo DConId
dcon
  TInfo
t <- TConId -> DesugarFn TInfo
getTInfo (CInfo -> TConId
cType CInfo
c)
  Set DConId -> DesugarFn (Set DConId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set DConId -> DesugarFn (Set DConId))
-> Set DConId -> DesugarFn (Set DConId)
forall a b. (a -> b) -> a -> b
$ TInfo -> Set DConId
tCSet TInfo
t


getCInfo :: I.DConId -> DesugarFn CInfo
getCInfo :: DConId -> DesugarFn CInfo
getCInfo DConId
dcon = (DesugarCtx -> Maybe CInfo) -> DesugarFn (Maybe CInfo)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (DConId -> Map DConId CInfo -> Maybe CInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DConId
dcon (Map DConId CInfo -> Maybe CInfo)
-> (DesugarCtx -> Map DConId CInfo) -> DesugarCtx -> Maybe CInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DesugarCtx -> Map DConId CInfo
consMap) DesugarFn (Maybe CInfo)
-> (Maybe CInfo -> DesugarFn CInfo) -> DesugarFn CInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DesugarFn CInfo
-> (CInfo -> DesugarFn CInfo) -> Maybe CInfo -> DesugarFn CInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DConId -> DesugarFn CInfo
forall i a. Pretty i => i -> DesugarFn a
desugarError DConId
dcon) CInfo -> DesugarFn CInfo
forall (m :: * -> *) a. Monad m => a -> m a
return


getTInfo :: I.TConId -> DesugarFn TInfo
getTInfo :: TConId -> DesugarFn TInfo
getTInfo TConId
tcon = (DesugarCtx -> Maybe TInfo) -> DesugarFn (Maybe TInfo)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (TConId -> Map TConId TInfo -> Maybe TInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TConId
tcon (Map TConId TInfo -> Maybe TInfo)
-> (DesugarCtx -> Map TConId TInfo) -> DesugarCtx -> Maybe TInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DesugarCtx -> Map TConId TInfo
typeMap) DesugarFn (Maybe TInfo)
-> (Maybe TInfo -> DesugarFn TInfo) -> DesugarFn TInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DesugarFn TInfo
-> (TInfo -> DesugarFn TInfo) -> Maybe TInfo -> DesugarFn TInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TConId -> DesugarFn TInfo
forall i a. Pretty i => i -> DesugarFn a
desugarError TConId
tcon) TInfo -> DesugarFn TInfo
forall (m :: * -> *) a. Monad m => a -> m a
return


desugarError :: Pretty i => i -> DesugarFn a
desugarError :: i -> DesugarFn a
desugarError i
i = Error -> DesugarFn a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> DesugarFn a) -> Error -> DesugarFn a
forall a b. (a -> b) -> a -> b
$ ErrorMsg -> Error
PatternError (ErrorMsg -> Error) -> ErrorMsg -> Error
forall a b. (a -> b) -> a -> b
$ ErrorMsg
"Unknown identifier: " ErrorMsg -> ErrorMsg -> ErrorMsg
forall a. Semigroup a => a -> a -> a
<> String -> ErrorMsg
forall a. IsString a => String -> a
fromString (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ i -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty i
i)


buildTypeMap :: [(I.TConId, I.TypeDef)] -> M.Map I.TConId TInfo
buildTypeMap :: [(TConId, TypeDef)] -> Map TConId TInfo
buildTypeMap = ((TConId, TypeDef) -> Map TConId TInfo -> Map TConId TInfo)
-> Map TConId TInfo -> [(TConId, TypeDef)] -> Map TConId TInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TConId, TypeDef) -> Map TConId TInfo -> Map TConId TInfo
build Map TConId TInfo
forall k a. Map k a
M.empty
 where
  build :: (TConId, TypeDef) -> Map TConId TInfo -> Map TConId TInfo
build (TConId
tcon, ((DConId, TypeVariant) -> DConId)
-> [(DConId, TypeVariant)] -> [DConId]
forall a b. (a -> b) -> [a] -> [b]
map (DConId, TypeVariant) -> DConId
forall a b. (a, b) -> a
fst ([(DConId, TypeVariant)] -> [DConId])
-> (TypeDef -> [(DConId, TypeVariant)]) -> TypeDef -> [DConId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDef -> [(DConId, TypeVariant)]
I.variants -> [DConId]
dcons) =
    TConId -> TInfo -> Map TConId TInfo -> Map TConId TInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert TConId
tcon (TInfo :: TConId -> Set DConId -> TInfo
TInfo{tName :: TConId
tName = TConId
tcon, tCSet :: Set DConId
tCSet = [DConId] -> Set DConId
forall a. Ord a => [a] -> Set a
S.fromList [DConId]
dcons})


buildConsMap :: [(I.TConId, I.TypeDef)] -> M.Map I.DConId CInfo
buildConsMap :: [(TConId, TypeDef)] -> Map DConId CInfo
buildConsMap = ((TConId, TypeDef) -> Map DConId CInfo -> Map DConId CInfo)
-> Map DConId CInfo -> [(TConId, TypeDef)] -> Map DConId CInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((TConId, [(DConId, TypeVariant)])
-> Map DConId CInfo -> Map DConId CInfo
forall (t :: * -> *).
Foldable t =>
(TConId, t (DConId, TypeVariant))
-> Map DConId CInfo -> Map DConId CInfo
build ((TConId, [(DConId, TypeVariant)])
 -> Map DConId CInfo -> Map DConId CInfo)
-> ((TConId, TypeDef) -> (TConId, [(DConId, TypeVariant)]))
-> (TConId, TypeDef)
-> Map DConId CInfo
-> Map DConId CInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDef -> [(DConId, TypeVariant)])
-> (TConId, TypeDef) -> (TConId, [(DConId, TypeVariant)])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second TypeDef -> [(DConId, TypeVariant)]
I.variants) Map DConId CInfo
forall k a. Map k a
M.empty
 where
  variantTypes :: TypeVariant -> [Type]
variantTypes (I.VariantUnnamed [Type]
typs) = [Type]
typs
  variantTypes TypeVariant
_ = String -> [Type]
forall a. HasCallStack => String -> a
error String
"VariantNamed aren't supported (yet?)"
  build :: (TConId, t (DConId, TypeVariant))
-> Map DConId CInfo -> Map DConId CInfo
build (TConId
tcon, t (DConId, TypeVariant)
variants) Map DConId CInfo
m = ((DConId, TypeVariant) -> Map DConId CInfo -> Map DConId CInfo)
-> Map DConId CInfo -> t (DConId, TypeVariant) -> Map DConId CInfo
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TConId
-> (DConId, TypeVariant) -> Map DConId CInfo -> Map DConId CInfo
build' TConId
tcon) Map DConId CInfo
m t (DConId, TypeVariant)
variants
  build' :: TConId
-> (DConId, TypeVariant) -> Map DConId CInfo -> Map DConId CInfo
build' TConId
tcon (DConId
dcon, TypeVariant
typs) =
    DConId -> CInfo -> Map DConId CInfo -> Map DConId CInfo
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert DConId
dcon (CInfo -> Map DConId CInfo -> Map DConId CInfo)
-> CInfo -> Map DConId CInfo -> Map DConId CInfo
forall a b. (a -> b) -> a -> b
$
      CInfo :: DConId -> TConId -> [Type] -> CInfo
CInfo
        { cName :: DConId
cName = DConId
dcon
        , cType :: TConId
cType = TConId
tcon
        , argsType :: [Type]
argsType = TypeVariant -> [Type]
variantTypes TypeVariant
typs
        }