{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Clash.Core.Term
( Term (..)
, TmName
, LetBinding
, Pat (..)
, Alt
, TickInfo (..), NameMod (..)
, PrimInfo (..)
, WorkInfo (..)
, CoreContext (..), Context, isLambdaBodyCtx, isTickCtx
, collectArgs, collectArgsTicks, collectTicks, primArg
, partitionTicks
)
where
import Control.DeepSeq
import Data.Binary (Binary)
import Data.Either (lefts, rights)
import Data.Hashable (Hashable)
import Data.List (partition)
import Data.Text (Text)
import GHC.Generics
import SrcLoc (SrcSpan)
import Clash.Core.DataCon (DataCon)
import Clash.Core.Literal (Literal)
import Clash.Core.Name (Name (..))
import {-# SOURCE #-} Clash.Core.Subst ()
import {-# SOURCE #-} Clash.Core.Type (Type)
import Clash.Core.Var (Id, TyVar)
data Term
= Var !Id
| Data !DataCon
| Literal !Literal
| Prim !Text !PrimInfo
| Lam !Id Term
| TyLam !TyVar Term
| App !Term !Term
| TyApp !Term !Type
| Letrec [LetBinding] Term
| Case !Term !Type [Alt]
| Cast !Term !Type !Type
| Tick !TickInfo !Term
deriving (Show,Generic,NFData,Hashable,Binary)
data TickInfo
= SrcSpan !SrcSpan
| NameMod !NameMod !Type
deriving (Eq,Show,Generic,NFData,Hashable,Binary)
data NameMod
= PrefixName
| SuffixName
| SetName
deriving (Eq,Show,Generic,NFData,Hashable,Binary)
data PrimInfo
= PrimInfo
{ primType :: !Type
, primWorkInfo :: !WorkInfo
}
deriving (Show,Generic,NFData,Hashable,Binary)
data WorkInfo
= WorkConstant
| WorkNever
| WorkVariable
| WorkAlways
deriving (Show,Generic,NFData,Hashable,Binary)
type TmName = Name Term
type LetBinding = (Id, Term)
data Pat
= DataPat !DataCon [TyVar] [Id]
| LitPat !Literal
| DefaultPat
deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)
type Alt = (Pat,Term)
data CoreContext
= AppFun
| AppArg (Maybe (Text, Int, Int))
| TyAppC
| LetBinding Id [Id]
| LetBody [Id]
| LamBody Id
| TyLamBody TyVar
| CaseAlt Pat
| CaseScrut
| CastBody
| TickC TickInfo
deriving (Show, Generic, NFData, Hashable, Binary)
type Context = [CoreContext]
instance Eq CoreContext where
c == c' = case (c, c') of
(AppFun, AppFun) -> True
(AppArg _, AppArg _) -> True
(TyAppC, TyAppC) -> True
(LetBinding i is, LetBinding i' is') -> i == i' && is == is'
(LetBody is, LetBody is') -> is == is'
(LamBody i, LamBody i') -> i == i'
(TyLamBody tv, TyLamBody tv') -> tv == tv'
(CaseAlt p, CaseAlt p') -> p == p'
(CaseScrut, CaseScrut) -> True
(CastBody, CastBody) -> True
(TickC sp, TickC sp') -> sp == sp'
(_, _) -> False
isLambdaBodyCtx :: CoreContext -> Bool
isLambdaBodyCtx (LamBody _) = True
isLambdaBodyCtx _ = False
isTickCtx :: CoreContext -> Bool
isTickCtx (TickC _) = True
isTickCtx _ = False
collectArgs :: Term
-> (Term, [Either Term Type])
collectArgs = go []
where
go args (App e1 e2) = go (Left e2:args) e1
go args (TyApp e t) = go (Right t:args) e
go args (Tick _ e) = go args e
go args e = (e, args)
collectTicks
:: Term
-> (Term, [TickInfo])
collectTicks = go []
where
go ticks (Tick s e) = go (s:ticks) e
go ticks e = (e,ticks)
collectArgsTicks
:: Term
-> (Term, [Either Term Type], [TickInfo])
collectArgsTicks = go [] []
where
go args ticks (App e1 e2) = go (Left e2:args) ticks e1
go args ticks (TyApp e t) = go (Right t:args) ticks e
go args ticks (Tick s e) = go args (s:ticks) e
go args ticks e = (e, args, ticks)
primArg
:: Term
-> Maybe (Text, Int, Int)
primArg (collectArgs -> t) =
case t of
(Prim nm _, args) ->
Just (nm, length (rights args), length (lefts args))
_ ->
Nothing
partitionTicks
:: [TickInfo]
-> ([TickInfo], [TickInfo])
partitionTicks = partition (\case {SrcSpan {} -> True; _ -> False})