454 lines
12 KiB
Haskell
454 lines
12 KiB
Haskell
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
module Gyehoek.CPS.Syntax
|
|
( Val(..)
|
|
, Kappa(..)
|
|
, Lambda(..)
|
|
, Exp(..)
|
|
, Kexp(..)
|
|
, ExpF(..)
|
|
, Name(..)
|
|
, Prim(..)
|
|
, Program(..)
|
|
, HoistedProgram(..)
|
|
, Lit(..)
|
|
, Imm(..)
|
|
, Obj(..)
|
|
, Hob(..)
|
|
, Label(..)
|
|
, Reg(..)
|
|
, pattern Halt
|
|
, pattern Halt1
|
|
, _MkKappa
|
|
, _ExpPrim
|
|
, _ExpLetRec
|
|
, _ExpApply
|
|
, _AbsLambda'
|
|
, binders
|
|
, body
|
|
, op
|
|
, args
|
|
, cont
|
|
, cps
|
|
, pattern AbsLambda'
|
|
, pattern AbsKappa'
|
|
, Abs(..)
|
|
, Free(..)
|
|
, pattern ValLabel
|
|
, pattern ObjLabel
|
|
, absBody
|
|
, pattern MkAbs
|
|
, _MkAbs
|
|
)
|
|
where
|
|
|
|
import Gyehoek.Scheme.Syntax (Name (..), Prim(..), primDatumIso, Lit(..))
|
|
import Gyehoek.Sexp qualified as S
|
|
import Control.Category
|
|
import Prelude hiding ((.), id)
|
|
import qualified Data.HashSet as HS
|
|
import Data.Monoid (Endo)
|
|
import Data.Functor.Foldable.TH
|
|
import Data.Data.Lens (uniplate)
|
|
import Gyehoek.Prelude hiding (op)
|
|
import Gyehoek.Sexp (Datum)
|
|
import Gyehoek.Sexp (G, (:-)(..))
|
|
import qualified Data.InvertibleGrammar.Base as IG
|
|
import Gyehoek.GenSym (Gen)
|
|
import Data.String (IsString)
|
|
import Control.Applicative
|
|
import qualified Data.HashMap.Strict as H
|
|
import GHC.Records (HasField (..))
|
|
|
|
-- Data types
|
|
|
|
data Val
|
|
= ValImm Imm
|
|
| ValVar Name
|
|
deriving (Show, Generic, Data, Eq)
|
|
|
|
pattern ValLabel :: Label -> Val
|
|
pattern ValLabel x = ValImm (ImmLabel x)
|
|
|
|
newtype Label = MkLabel { inner :: Name }
|
|
deriving stock (Generic, Data)
|
|
deriving newtype (Show, Eq, Gen, IsString, Hashable)
|
|
deriving anyclass (NFData, Wrapped)
|
|
|
|
newtype Reg = MkReg { inner :: Name }
|
|
deriving stock (Generic, Data)
|
|
deriving newtype (Show, Eq, Gen, IsString, Hashable)
|
|
deriving anyclass (NFData, Wrapped)
|
|
|
|
data Imm
|
|
= ImmInt Int
|
|
| ImmBool Bool
|
|
| ImmLabel Label
|
|
| ImmUndefined
|
|
deriving stock (Show, Generic, Data, Eq)
|
|
deriving anyclass (NFData)
|
|
|
|
data Obj
|
|
= ObjImm Imm
|
|
| ObjHob Hob
|
|
deriving stock (Show, Generic, Data, Eq)
|
|
deriving anyclass (NFData)
|
|
|
|
pattern ObjLabel l = ObjImm (ImmLabel l)
|
|
|
|
-- | a heap object.
|
|
data Hob
|
|
= HobClosure { label :: Label, env :: List Obj }
|
|
-- should a continuation have a label, or an Obj?
|
|
| HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
|
|
| HobPair Obj Obj
|
|
deriving stock (Show, Generic, Data, Eq)
|
|
deriving anyclass (NFData)
|
|
|
|
data Kappa = MkKappa { binders :: List Name, body :: Exp }
|
|
deriving (Show, Generic, Data, Eq)
|
|
|
|
data Lambda = MkLambda { binders :: List Name, ktail :: Name, body :: Exp }
|
|
deriving (Show, Generic, Data, Eq)
|
|
|
|
data Abs
|
|
= AbsKappa Kappa
|
|
| AbsLambda Lambda
|
|
deriving (Show, Generic, Data, Eq)
|
|
|
|
pattern AbsKappa' :: List Name -> Exp -> Abs
|
|
pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
|
|
|
|
pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
|
|
pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
|
|
|
|
{-# COMPLETE AbsKappa', AbsLambda' #-}
|
|
|
|
_MkAbs :: Iso' Abs (List Name, Maybe Name, Exp)
|
|
_MkAbs = iso
|
|
(\case
|
|
AbsKappa' xs e -> (xs,Nothing,e)
|
|
AbsLambda' xs ktail e -> (xs,Just ktail,e))
|
|
(\(xs,ktail,e) -> case ktail of
|
|
Just k -> AbsLambda' xs k e
|
|
Nothing -> AbsKappa' xs e)
|
|
|
|
pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
|
|
pattern MkAbs xs ktail body <- (view _Abs' -> (xs,ktail,body))
|
|
where MkAbs xs ktail body = review _Abs' (xs,ktail,body)
|
|
|
|
{-# COMPLETE MkAbs #-}
|
|
|
|
data Exp
|
|
= ExpPrim (Prim Val) Kexp
|
|
| ExpLetRec { binders :: List (Name, Abs), body :: Exp }
|
|
| ExpContinue Val (List Val)
|
|
| ExpIf Val Name Name
|
|
| ExpApply
|
|
{ op :: Val
|
|
, args :: List Val
|
|
, cont :: Kexp
|
|
}
|
|
deriving (Show, Generic, Data, Eq)
|
|
|
|
data Kexp
|
|
= KexpVar Name
|
|
| KexpKappa Kappa
|
|
deriving (Show, Generic, Data, Eq)
|
|
|
|
pattern Halt :: List Val -> Exp
|
|
pattern Halt xs = ExpContinue (ValLabel "halt") xs
|
|
|
|
pattern Halt1 :: Val -> Exp
|
|
pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
|
|
|
|
data Def = DefConstant Name Exp
|
|
deriving (Show, Generic, Data)
|
|
|
|
data Program = MkProgram
|
|
{ body :: Lambda
|
|
}
|
|
deriving (Show, Generic, Data)
|
|
|
|
data HoistedProgram = MkHoistedProgram
|
|
{ bindings :: HashMap Label Abs
|
|
, body :: Lambda
|
|
}
|
|
deriving stock (Show, Generic, Data)
|
|
|
|
type instance Index HoistedProgram = Label
|
|
type instance IxValue HoistedProgram = Abs
|
|
|
|
instance Ixed HoistedProgram where ix j = #bindings . ix j
|
|
|
|
instance At HoistedProgram where at j = #bindings . at j
|
|
|
|
instance Each HoistedProgram HoistedProgram Abs Abs where
|
|
each = #bindings . each
|
|
|
|
makePrisms ''Kappa
|
|
makePrisms ''Exp
|
|
makeFieldsId ''Exp
|
|
makeFieldsId ''Kappa
|
|
makeFieldsId ''Lambda
|
|
makeBaseFunctor ''Exp
|
|
|
|
instance HasBinders Abs (List Name) where
|
|
binders k (AbsKappa kap) = AbsKappa <$> binders k kap
|
|
binders k (AbsLambda lam) = AbsLambda <$> binders k lam
|
|
|
|
instance HasBody Abs Exp where
|
|
body k (AbsKappa kap) = AbsKappa <$> body k kap
|
|
body k (AbsLambda lam) = AbsLambda <$> body k lam
|
|
|
|
_AbsLambda' :: Prism' Abs (List Name, Name, Exp)
|
|
_AbsLambda' = prism'
|
|
(\(bs,ktail,e) -> AbsLambda' bs ktail e)
|
|
(\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
|
|
_ -> Nothing)
|
|
|
|
instance Plated Exp where plate = uniplate
|
|
|
|
absBody :: Lens' Abs Exp
|
|
absBody = lens
|
|
(\case
|
|
AbsLambda lam -> lam.body
|
|
AbsKappa kap -> kap.body)
|
|
(\cases
|
|
(AbsLambda lam) b -> AbsLambda $ lam & #body .~ b
|
|
(AbsKappa kap) b -> AbsKappa $ kap & #body .~ b)
|
|
|
|
|
|
-- DatumIso instances
|
|
|
|
instance S.DatumIso Val where
|
|
datumIso = S.match
|
|
$ S.With (\imm -> imm . S.datumIso)
|
|
$ S.With (\var -> var . S.datumIso)
|
|
$ S.End
|
|
|
|
instance S.DatumIso Obj where
|
|
datumIso = S.match
|
|
$ S.With (\imm -> imm . S.datumIso)
|
|
$ S.With (\hob -> hob . S.datumIso)
|
|
$ S.End
|
|
|
|
instance S.DatumIso Imm where
|
|
datumIso = S.match
|
|
$ S.With (. S.int)
|
|
$ S.With (. S.datumIso)
|
|
$ S.With (. S.datumIso)
|
|
$ S.With (. S.unreadable (const "#<undefined>"))
|
|
$ S.End
|
|
|
|
instance S.DatumIso Label where
|
|
datumIso = S.with \g -> S.coproduct
|
|
[ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
|
|
(S.expected "label")
|
|
(prefixed @Name "$")
|
|
, S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
|
|
]
|
|
>>> g
|
|
|
|
instance S.DatumIso Reg where
|
|
datumIso = S.with \g ->
|
|
S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
|
|
(S.expected "register")
|
|
(prefixed @Name "%")
|
|
>>> g
|
|
|
|
instance S.DatumIso Hob where
|
|
datumIso = S.match
|
|
$ S.With (. closure)
|
|
$ S.With (. cont)
|
|
$ S.With (. conspair)
|
|
$ S.End
|
|
where
|
|
conspair = S.dottedList (S.el S.datumIso) S.datumIso
|
|
-- closures can be printed, but not parsed.
|
|
closure :: G (Datum :- t) (List Obj :- Label :- t)
|
|
closure = IG.Flip $ IG.PartialIso
|
|
(\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
|
|
(const . Left $ mempty)
|
|
cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
|
|
cont = IG.Flip $ IG.PartialIso
|
|
(\(_ :- l :- t) ->
|
|
let x = S.encodeOrShow' @Text S.datumIso l
|
|
in S.Unreadable [i|\#<continuation #{x}>|] :- t)
|
|
(const . Left $ mempty)
|
|
|
|
instance S.DatumIso Lambda where
|
|
datumIso = S.with (lam >>>)
|
|
where
|
|
lam :: forall t. G (Datum :- t) (Exp :- Name :- List Name :- t)
|
|
lam = S.lambdaLike
|
|
S.lambdaKeyword
|
|
binders
|
|
(S.el $ S.datumIso @Exp)
|
|
binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
|
|
binders =
|
|
S.list (S.rest $ S.datumIso @Name)
|
|
>>> S.flipped S.snoced
|
|
>>> S.swap
|
|
|
|
instance S.DatumIso Kappa where
|
|
datumIso = S.with \g ->
|
|
S.lambdaLike S.kappaKeyword
|
|
(S.datumIso @(List Name))
|
|
(S.el $ S.datumIso @Exp)
|
|
>>> g
|
|
|
|
instance S.DatumIso Abs where
|
|
datumIso = S.match
|
|
$ S.With (\lambda -> lambda . S.datumIso)
|
|
$ S.With (\kappa -> kappa . S.datumIso)
|
|
$ S.End
|
|
|
|
instance S.DatumIso Exp where
|
|
datumIso = S.match
|
|
$ S.With (. prim)
|
|
$ S.With (. letrec)
|
|
$ S.With (. continue)
|
|
$ S.With (. if_)
|
|
$ S.With (. app)
|
|
$ S.End
|
|
where
|
|
continue = S.list $
|
|
S.el (S.decorate S.SynBuiltin >>> S.sym "continue")
|
|
>>> S.el (S.decorate S.SynProcedure >>> S.datumIso)
|
|
>>> S.rest S.datumIso
|
|
letrec = S.letLike "letrec" S.datumIso S.datumIso S.datumIso
|
|
if_ = S.ifLike "if"
|
|
S.datumIso S.datumIso S.datumIso
|
|
app :: forall t.
|
|
G (Datum :- t) (Kexp :- List Val :- Val :- t)
|
|
app = S.list $
|
|
S.flipped (S.PartialIso
|
|
(\(S.MkListContext ctx :- t) ->
|
|
case ctx of
|
|
f:kexp:xs -> S.MkListContext (f : snoc xs kexp) :- t
|
|
_ -> error "unreachable")
|
|
(\(S.MkListContext ctx :- t) ->
|
|
case unsnoc ctx of
|
|
Just (f:xs,kexp) -> Right $ S.MkListContext (f:kexp:xs) :- t
|
|
_ -> Left $ S.expected "continuation arg"))
|
|
>>> S.el (S.datumIso @Val)
|
|
>>> S.el (S.datumIso @Kexp)
|
|
>>> S.rest (S.datumIso @Val)
|
|
>>> S.onTail S.swap
|
|
prim = S.list $
|
|
S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
|
|
>>> S.el (primDatumIso id (S.datumIso @Val))
|
|
>>> S.el S.datumIso
|
|
|
|
instance S.DatumIso Kexp where
|
|
datumIso = S.match
|
|
$ S.With (S.datumIso @Name >>>)
|
|
$ S.With (S.datumIso @Kappa >>>)
|
|
$ S.End
|
|
|
|
instance S.DatumIso Program where
|
|
datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
|
|
|
|
-- the printed representation is pretty dishonest in its current
|
|
-- state. consider the following hoisted program:
|
|
--
|
|
-- (letrec ((k (κ () (continue start-ktail 123))))
|
|
-- (λ (start-ktail)
|
|
-- (continue k)))
|
|
--
|
|
-- here, `start-ktail` is bound in `k`, but the printed representation
|
|
-- fails to reflect that.
|
|
instance S.DatumIso HoistedProgram where
|
|
datumIso = S.with \prog ->
|
|
S.letLike "letrec"
|
|
(S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
|
|
>>> S.onTail (S.iso H.fromList H.toList)
|
|
>>> prog
|
|
|
|
|
|
-- quasiquoters
|
|
|
|
class Data a => CPS a where
|
|
toCPS :: HasCallStack => Datum -> a
|
|
|
|
instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso
|
|
instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
|
|
instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
|
|
instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
|
|
instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
|
|
instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
|
|
instance CPS HoistedProgram where toCPS = S.fromDatumUnsafe S.datumIso
|
|
|
|
cps :: S.QuasiQuoter
|
|
cps = S.makeSx' [| toCPS |]
|
|
|
|
|
|
|
|
deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
|
|
deleteFrom = flip $ foldr HS.delete
|
|
|
|
insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
|
|
insertFrom = flip $ foldr HS.insert
|
|
|
|
toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a
|
|
toHashSetOf l = foldrOf l HS.insert mempty
|
|
|
|
class Free a where
|
|
free :: a -> HashSet Name
|
|
free = freeWithBound mempty
|
|
|
|
freeWithBound :: HashSet Name -> a -> HashSet Name
|
|
freeWithBound bound = HS.fromList . freeWithBound' bound
|
|
|
|
-- | Free variables given in the same left-to-right order they
|
|
-- appear.
|
|
free' :: a -> List Name
|
|
free' = freeWithBound' mempty
|
|
|
|
freeWithBound' :: HashSet Name -> a -> List Name
|
|
|
|
instance Free Abs where
|
|
freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
|
|
freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
|
|
|
|
mif :: Alternative f => (a -> Bool) -> a -> f a
|
|
mif p a
|
|
| p a = pure a
|
|
| otherwise = empty
|
|
|
|
instance Free Kexp where
|
|
freeWithBound' bound = \case
|
|
KexpVar x -> mif (`notElem` bound) x
|
|
KexpKappa kap -> freeWithBound' bound kap
|
|
|
|
instance Free Exp where
|
|
freeWithBound' bound = \case
|
|
ExpPrim p k ->
|
|
(p ^.. folded . #ValVar . filtered (`notElem` bound))
|
|
++ freeWithBound' bound k
|
|
ExpLetRec bs m ->
|
|
foldMapOf (each . _2) (freeWithBound' bound') bs
|
|
<> freeWithBound' bound' m
|
|
where bound' = bound & insertFrom (bs ^.. each . _1)
|
|
ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
|
|
ExpIf c t f ->
|
|
(c ^.. #ValVar . filtered (`notElem` bound))
|
|
<> mif (`notElem` bound) t <> mif (`notElem` bound) f
|
|
ExpApply f xs k ->
|
|
(f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
|
|
<> freeWithBound' bound k
|
|
|
|
instance Free Kappa where
|
|
freeWithBound' bound (MkKappa xs m) =
|
|
freeWithBound' (bound & insertFrom xs) m
|
|
|
|
instance Free Lambda where
|
|
freeWithBound' bound (MkLambda xs k m) =
|
|
freeWithBound' (bound & insertFrom (k:xs)) m
|