-- * Type 'Reader'
-- | An intermediate interpreter exposing an environment.
-newtype Reader r repr a = Reader { unReader :: r -> repr a }
+newtype Reader r sem a = Reader { unReader :: r -> sem a }
-type instance Derived (Reader r repr) = repr
-instance LiftDerived (Reader r repr) where
+type instance Derived (Reader r sem) = sem
+instance LiftDerived (Reader r sem) where
liftDerived = Reader . const
-instance LiftDerived1 (Reader r repr) where
+instance LiftDerived1 (Reader r sem) where
liftDerived1 f a = Reader (f . unReader a)
-instance LiftDerived2 (Reader r repr) where
+instance LiftDerived2 (Reader r sem) where
liftDerived2 f a b = Reader (\r -> f (unReader a r) (unReader b r))
-instance LiftDerived3 (Reader r repr) where
+instance LiftDerived3 (Reader r sem) where
liftDerived3 f a b c = Reader (\r -> f (unReader a r) (unReader b r) (unReader c r))
-instance LiftDerived4 (Reader r repr) where
+instance LiftDerived4 (Reader r sem) where
liftDerived4 f a b c d = Reader (\r -> f (unReader a r) (unReader b r) (unReader c r) (unReader d r))
-instance Abstractable repr => Abstractable (Reader r repr) where
+instance Abstractable sem => Abstractable (Reader r sem) where
lam f = Reader (\r -> lam ((`unReader` r) . f . liftDerived))
lam1 f = Reader (\r -> lam1 ((`unReader` r) . f . liftDerived))
-instance Functionable repr => Functionable (Reader r repr)
-instance Anythingable repr => Anythingable (Reader r repr)
-instance Constantable c repr => Constantable c (Reader r repr)
-instance Eitherable repr => Eitherable (Reader r repr)
-instance Equalable repr => Equalable (Reader r repr)
-instance IfThenElseable repr => IfThenElseable (Reader r repr)
--- Using 'Inferable' with a specific @a@ and keeping @repr@ polymorphic
+instance Functionable sem => Functionable (Reader r sem)
+instance Anythingable sem => Anythingable (Reader r sem)
+instance Constantable c sem => Constantable c (Reader r sem)
+instance Eitherable sem => Eitherable (Reader r sem)
+instance Equalable sem => Equalable (Reader r sem)
+instance IfThenElseable sem => IfThenElseable (Reader r sem)
+-- Using 'Inferable' with a specific @a@ and keeping @sem@ polymorphic
-- is more usual; hence commenting this instance that would overlap.
---instance Inferable a repr => Inferable a (Reader r repr)
-instance Listable repr => Listable (Reader r repr)
-instance Maybeable repr => Maybeable (Reader r repr)
-instance IsoFunctor repr => IsoFunctor (Reader r repr)
-instance (ProductFunctor repr, IsoFunctor repr) => ProductFunctor (Reader r repr)
-instance (SumFunctor repr, IsoFunctor repr) => SumFunctor (Reader r repr)
-instance AlternativeFunctor repr => AlternativeFunctor (Reader r repr)
-instance Dicurryable repr => Dicurryable (Reader r repr)
-instance Emptyable repr => Emptyable (Reader r repr)
-instance Semigroupable repr => Semigroupable (Reader r repr)
-instance Optionable repr => Optionable (Reader r repr)
-instance Repeatable repr => Repeatable (Reader r repr)
--- instance Permutable repr => Permutable (Reader r repr)
-instance Routable repr => Routable (Reader r repr)
-instance Voidable repr => Voidable (Reader r repr)
-instance Substractable repr => Substractable (Reader r repr)
+--instance Inferable a sem => Inferable a (Reader r sem)
+instance Listable sem => Listable (Reader r sem)
+instance Maybeable sem => Maybeable (Reader r sem)
+instance IsoFunctor sem => IsoFunctor (Reader r sem)
+instance (ProductFunctor sem, IsoFunctor sem) => ProductFunctor (Reader r sem)
+instance (SumFunctor sem, IsoFunctor sem) => SumFunctor (Reader r sem)
+instance AlternativeFunctor sem => AlternativeFunctor (Reader r sem)
+instance Dicurryable sem => Dicurryable (Reader r sem)
+instance Emptyable sem => Emptyable (Reader r sem)
+instance Semigroupable sem => Semigroupable (Reader r sem)
+instance Optionable sem => Optionable (Reader r sem)
+instance Repeatable sem => Repeatable (Reader r sem)
+-- instance Permutable sem => Permutable (Reader r sem)
+instance Routable sem => Routable (Reader r sem)
+instance Voidable sem => Voidable (Reader r sem)
+instance Substractable sem => Substractable (Reader r sem)
-- * Class 'Referenceable'
-- | This class is not for end-users like usual symantic operators,
-- though it will have to be defined on end-users' interpreters.
-class Referenceable letName repr where
+class Referenceable letName sem where
-- | @('ref' isRec letName)@ is a reference to @(letName)@.
-- It is introduced by 'observeSharing'.
-- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
-- ie. appears within its 'define'.
--
-- TODO: index 'letName' with 'a' to enable dependent-map
- ref :: Bool -> letName -> repr a
+ ref :: Bool -> letName -> sem a
ref isRec name = liftDerived (ref isRec name)
default ref ::
- FromDerived (Referenceable letName) repr =>
- Bool -> letName -> repr a
+ FromDerived (Referenceable letName) sem =>
+ Bool -> letName -> sem a
-- * Class 'Definable'
-- | This class is not for end-users like usual symantic operators.
-- There should be not need to use it outside this module,
-- because used 'define's are gathered in 'Letsable'.
-class Definable letName repr where
+class Definable letName sem where
-- | @('define' letName sub)@ let-binds @(letName)@ to be equal to @(sub)@.
-- This is a temporary node either replaced
-- by 'ref' and an entry in 'lets''s 'LetBindings',
-- or removed when no 'ref'erence is made to it.
- define :: letName -> repr a -> repr a
+ define :: letName -> sem a -> sem a
define name = liftDerived1 (define name)
default define ::
- FromDerived1 (Definable letName) repr =>
- letName -> repr a -> repr a
+ FromDerived1 (Definable letName) sem =>
+ letName -> sem a -> sem a
-- * Class 'MakeLetName'
class MakeLetName letName where
-}
-- * Type 'SharingObserver'
-newtype SharingObserver letName repr a = SharingObserver { unSharingObserver ::
+newtype SharingObserver letName sem a = SharingObserver { unSharingObserver ::
MT.ReaderT (HashSet SharingName)
(MT.State (SharingObserverState letName))
- (SharingFinalizer letName repr a) }
+ (SharingFinalizer letName sem a) }
-- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
-- least once and/or recursively, in order to replace them
Eq letName =>
Hashable letName =>
Show letName =>
- SharingObserver letName repr a ->
- WithSharing letName repr a
+ SharingObserver letName sem a ->
+ WithSharing letName sem a
observeSharing (SharingObserver m) =
let (fs, st) = MT.runReaderT m mempty `MT.runState`
SharingObserverState
unFinalizeSharing fs
-- ** Type 'WithSharing'
-type WithSharing letName repr a =
- (repr a, HM.HashMap letName (SomeLet repr))
+type WithSharing letName sem a =
+ (sem a, HM.HashMap letName (SomeLet sem))
{-
-- * Type 'WithSharing'
-data WithSharing letName repr a = WithSharing
- { lets :: HM.HashMap letName (SomeLet repr)
- , body :: repr a
+data WithSharing letName sem a = WithSharing
+ { lets :: HM.HashMap letName (SomeLet sem)
+ , body :: sem a
}
mapWithSharing ::
- (forall v. repr v -> repr v) ->
- WithSharing letName repr a ->
- WithSharing letName repr a
+ (forall v. sem v -> sem v) ->
+ WithSharing letName sem a ->
+ WithSharing letName sem a
mapWithSharing f ws = WithSharing
- { lets = (\(SomeLet repr) -> SomeLet (f repr)) <$> lets ws
+ { lets = (\(SomeLet sem) -> SomeLet (f sem)) <$> lets ws
, body = f (body ws)
}
-}
Eq letName =>
Hashable letName =>
Show letName =>
- Referenceable letName repr =>
+ Referenceable letName sem =>
MakeLetName letName =>
- SharingObserver letName repr a ->
- SharingObserver letName repr a
+ SharingObserver letName sem a ->
+ SharingObserver letName sem a
observeSharingNode (SharingObserver m) = SharingObserver $ do
let nodeName = makeSharingName m
st <- MT.lift MT.get
then MT.local (HS.insert nodeName) (define letName <$> m)
else return $ ref False letName
-type instance Derived (SharingObserver letName repr) = SharingFinalizer letName repr
+type instance Derived (SharingObserver letName sem) = SharingFinalizer letName sem
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived (SharingObserver letName repr) where
+ ) => LiftDerived (SharingObserver letName sem) where
liftDerived = observeSharingNode . SharingObserver . return
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived1 (SharingObserver letName repr) where
+ ) => LiftDerived1 (SharingObserver letName sem) where
liftDerived1 f a = observeSharingNode $ SharingObserver $
f <$> unSharingObserver a
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived2 (SharingObserver letName repr) where
+ ) => LiftDerived2 (SharingObserver letName sem) where
liftDerived2 f a b = observeSharingNode $ SharingObserver $
f <$> unSharingObserver a
<*> unSharingObserver b
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived3 (SharingObserver letName repr) where
+ ) => LiftDerived3 (SharingObserver letName sem) where
liftDerived3 f a b c = observeSharingNode $ SharingObserver $
f <$> unSharingObserver a
<*> unSharingObserver b
<*> unSharingObserver c
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
- ) => LiftDerived4 (SharingObserver letName repr) where
+ ) => LiftDerived4 (SharingObserver letName sem) where
liftDerived4 f a b c d = observeSharingNode $ SharingObserver $
f <$> unSharingObserver a
<*> unSharingObserver b
<*> unSharingObserver c
<*> unSharingObserver d
-instance Referenceable letName (SharingObserver letName repr) where
+instance Referenceable letName (SharingObserver letName sem) where
ref = error "[BUG]: observeSharing MUST NOT be applied twice"
-instance Definable letName (SharingObserver letName repr) where
+instance Definable letName (SharingObserver letName sem) where
define = error "[BUG]: observeSharing MUST NOT be applied twice"
-instance Letsable letName (SharingObserver letName repr) where
+instance Letsable letName (SharingObserver letName sem) where
lets = error "[BUG]: observeSharing MUST NOT be applied twice"
-- * Type 'SharingFinalizer'
-- | Remove 'define' when non-recursive or unused
-- or replace it by 'ref', moving 'define's to the top.
-newtype SharingFinalizer letName repr a = SharingFinalizer { unFinalizeSharing ::
+newtype SharingFinalizer letName sem a = SharingFinalizer { unFinalizeSharing ::
MT.ReaderT (HS.HashSet letName)
- (MT.Writer (LetBindings letName repr))
- (repr a) }
+ (MT.Writer (LetBindings letName sem))
+ (sem a) }
-type instance Derived (SharingFinalizer _letName repr) = repr
+type instance Derived (SharingFinalizer _letName sem) = sem
instance (Eq letName, Hashable letName) =>
- LiftDerived (SharingFinalizer letName repr) where
+ LiftDerived (SharingFinalizer letName sem) where
liftDerived = SharingFinalizer . pure
instance (Eq letName, Hashable letName) =>
- LiftDerived1 (SharingFinalizer letName repr) where
+ LiftDerived1 (SharingFinalizer letName sem) where
liftDerived1 f a = SharingFinalizer $ f <$> unFinalizeSharing a
instance (Eq letName, Hashable letName) =>
- LiftDerived2 (SharingFinalizer letName repr) where
+ LiftDerived2 (SharingFinalizer letName sem) where
liftDerived2 f a b = SharingFinalizer $
f <$> unFinalizeSharing a
<*> unFinalizeSharing b
instance (Eq letName, Hashable letName) =>
- LiftDerived3 (SharingFinalizer letName repr) where
+ LiftDerived3 (SharingFinalizer letName sem) where
liftDerived3 f a b c = SharingFinalizer $
f <$> unFinalizeSharing a
<*> unFinalizeSharing b
<*> unFinalizeSharing c
instance (Eq letName, Hashable letName) =>
- LiftDerived4 (SharingFinalizer letName repr) where
+ LiftDerived4 (SharingFinalizer letName sem) where
liftDerived4 f a b c d = SharingFinalizer $
f <$> unFinalizeSharing a
<*> unFinalizeSharing b
<*> unFinalizeSharing c
<*> unFinalizeSharing d
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, Eq letName
, Hashable letName
, Show letName
- ) => Referenceable letName (SharingFinalizer letName repr) where
+ ) => Referenceable letName (SharingFinalizer letName sem) where
ref isRec = liftDerived . ref isRec
instance
- ( Referenceable letName repr
+ ( Referenceable letName sem
, Eq letName
, Hashable letName
, Show letName
- ) => Definable letName (SharingFinalizer letName repr) where
+ ) => Definable letName (SharingFinalizer letName sem) where
define name body = SharingFinalizer $ do
refs <- MT.ask
- let (repr, defs) =
+ let (sem, defs) =
MT.runWriter $ MT.runReaderT (unFinalizeSharing body) refs
if name `HS.member` refs
then do
-- to put it in scope even when some 'ref' to it exists outside of 'body'
-- (which can happen when a body-expression is shared),
-- and replace it by a 'ref'.
- MT.lift $ MT.tell $ HM.insert name (SomeLet repr) defs
+ MT.lift $ MT.tell $ HM.insert name (SomeLet sem) defs
return $ ref False name
else
-- Remove this unreferenced 'define' node.
unFinalizeSharing body
-- * Class 'Letsable'
-class Letsable letName repr where
+class Letsable letName sem where
-- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
- lets :: LetBindings letName repr -> repr a -> repr a
+ lets :: LetBindings letName sem -> sem a -> sem a
lets defs = liftDerived1 (lets ((\(SomeLet val) -> SomeLet (derive val)) <$> defs))
default lets ::
- Derivable repr =>
- FromDerived1 (Letsable letName) repr =>
- LetBindings letName repr -> repr a -> repr a
+ Derivable sem =>
+ FromDerived1 (Letsable letName) sem =>
+ LetBindings letName sem -> sem a -> sem a
-- ** Type 'SomeLet'
-data SomeLet repr = forall a. SomeLet (repr a)
+data SomeLet sem = forall a. SomeLet (sem a)
-- ** Type 'LetBindings'
-type LetBindings letName repr = HM.HashMap letName (SomeLet repr)
+type LetBindings letName sem = HM.HashMap letName (SomeLet sem)
{-
-- | Not used but can be written nonetheless.
instance
- ( Letsable letName repr
+ ( Letsable letName sem
, Eq letName
, Hashable letName
, Show letName
- ) => Letsable letName (SharingFinalizer letName repr) where
+ ) => Letsable letName (SharingFinalizer letName sem) where
lets defs x = SharingFinalizer $ do
ds <- traverse (\(SomeLet v) -> do
r <- unFinalizeSharing v
type Semantic = Type -> Type
-- * Class 'Abstractable'
-class Abstractable repr where
+class Abstractable sem where
-- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
- lam :: (repr a -> repr b) -> repr (a->b)
+ lam :: (sem a -> sem b) -> sem (a->b)
-- | Like 'lam' but whose argument must be used only once,
-- hence safe to beta-reduce (inline) without duplicating work.
- lam1 :: (repr a -> repr b) -> repr (a->b)
- var :: repr a -> repr a
+ lam1 :: (sem a -> sem b) -> sem (a->b)
+ var :: sem a -> sem a
-- | Application, aka. unabstract.
- (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
+ (.@) :: sem (a->b) -> sem a -> sem b; infixl 9 .@
lam f = liftDerived (lam (derive Fun.. f Fun.. liftDerived))
lam1 f = liftDerived (lam1 (derive Fun.. f Fun.. liftDerived))
var = liftDerived1 var
(.@) = liftDerived2 (.@)
default lam ::
- FromDerived Abstractable repr => Derivable repr =>
- (repr a -> repr b) -> repr (a->b)
+ FromDerived Abstractable sem => Derivable sem =>
+ (sem a -> sem b) -> sem (a->b)
default lam1 ::
- FromDerived Abstractable repr => Derivable repr =>
- (repr a -> repr b) -> repr (a->b)
+ FromDerived Abstractable sem => Derivable sem =>
+ (sem a -> sem b) -> sem (a->b)
default var ::
- FromDerived1 Abstractable repr =>
- repr a -> repr a
+ FromDerived1 Abstractable sem =>
+ sem a -> sem a
default (.@) ::
- FromDerived2 Abstractable repr =>
- repr (a->b) -> repr a -> repr b
+ FromDerived2 Abstractable sem =>
+ sem (a->b) -> sem a -> sem b
-- ** Class 'Functionable'
-class Functionable repr where
- const :: repr (a -> b -> a)
- flip :: repr ((a -> b -> c) -> b -> a -> c)
- id :: repr (a->a)
- (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
- ($) :: repr ((a->b) -> a -> b); infixr 0 $
+class Functionable sem where
+ const :: sem (a -> b -> a)
+ flip :: sem ((a -> b -> c) -> b -> a -> c)
+ id :: sem (a->a)
+ (.) :: sem ((b->c) -> (a->b) -> a -> c); infixr 9 .
+ ($) :: sem ((a->b) -> a -> b); infixr 0 $
const = liftDerived const
flip = liftDerived flip
id = liftDerived id
(.) = liftDerived (.)
($) = liftDerived ($)
default const ::
- FromDerived Functionable repr =>
- repr (a -> b -> a)
+ FromDerived Functionable sem =>
+ sem (a -> b -> a)
default flip ::
- FromDerived Functionable repr =>
- repr ((a -> b -> c) -> b -> a -> c)
+ FromDerived Functionable sem =>
+ sem ((a -> b -> c) -> b -> a -> c)
default id ::
- FromDerived Functionable repr =>
- repr (a->a)
+ FromDerived Functionable sem =>
+ sem (a->a)
default (.) ::
- FromDerived Functionable repr =>
- repr ((b->c) -> (a->b) -> a -> c)
+ FromDerived Functionable sem =>
+ sem ((b->c) -> (a->b) -> a -> c)
default ($) ::
- FromDerived Functionable repr =>
- repr ((a->b) -> a -> b)
+ FromDerived Functionable sem =>
+ sem ((a->b) -> a -> b)
-- * Class 'Anythingable'
-class Anythingable repr where
- anything :: repr a -> repr a
+class Anythingable sem where
+ anything :: sem a -> sem a
anything = Fun.id
-- * Class 'Bottomable'
-class Bottomable repr where
- bottom :: repr a
+class Bottomable sem where
+ bottom :: sem a
-- * Class 'Constantable'
-class Constantable c repr where
- constant :: c -> repr c
+class Constantable c sem where
+ constant :: c -> sem c
constant = liftDerived Fun.. constant
default constant ::
- FromDerived (Constantable c) repr =>
- c -> repr c
+ FromDerived (Constantable c) sem =>
+ c -> sem c
-- * Class 'Eitherable'
-class Eitherable repr where
- left :: repr (l -> Either l r)
- right :: repr (r -> Either l r)
+class Eitherable sem where
+ left :: sem (l -> Either l r)
+ right :: sem (r -> Either l r)
left = liftDerived left
right = liftDerived right
default left ::
- FromDerived Eitherable repr =>
- repr (l -> Either l r)
+ FromDerived Eitherable sem =>
+ sem (l -> Either l r)
default right ::
- FromDerived Eitherable repr =>
- repr (r -> Either l r)
+ FromDerived Eitherable sem =>
+ sem (r -> Either l r)
-- * Class 'Equalable'
-class Equalable repr where
- equal :: Eq a => repr (a -> a -> Bool)
+class Equalable sem where
+ equal :: Eq a => sem (a -> a -> Bool)
equal = liftDerived equal
default equal ::
- FromDerived Equalable repr =>
- Eq a => repr (a -> a -> Bool)
+ FromDerived Equalable sem =>
+ Eq a => sem (a -> a -> Bool)
infix 4 `equal`, ==
(==) ::
- Abstractable repr => Equalable repr => Eq a =>
- repr a -> repr a -> repr Bool
+ Abstractable sem => Equalable sem => Eq a =>
+ sem a -> sem a -> sem Bool
(==) x y = equal .@ x .@ y
-- * Class 'IfThenElseable'
-class IfThenElseable repr where
- ifThenElse :: repr Bool -> repr a -> repr a -> repr a
+class IfThenElseable sem where
+ ifThenElse :: sem Bool -> sem a -> sem a -> sem a
ifThenElse = liftDerived3 ifThenElse
default ifThenElse ::
- FromDerived3 IfThenElseable repr =>
- repr Bool -> repr a -> repr a -> repr a
+ FromDerived3 IfThenElseable sem =>
+ sem Bool -> sem a -> sem a -> sem a
-- * Class 'Inferable'
-class Inferable a repr where
- infer :: repr a
- default infer :: FromDerived (Inferable a) repr => repr a
+class Inferable a sem where
+ infer :: sem a
+ default infer :: FromDerived (Inferable a) sem => sem a
infer = liftDerived infer
-unit :: Inferable () repr => repr ()
+unit :: Inferable () sem => sem ()
unit = infer
-bool :: Inferable Bool repr => repr Bool
+bool :: Inferable Bool sem => sem Bool
bool = infer
-char :: Inferable Char repr => repr Char
+char :: Inferable Char sem => sem Char
char = infer
-int :: Inferable Int repr => repr Int
+int :: Inferable Int sem => sem Int
int = infer
-natural :: Inferable Natural repr => repr Natural
+natural :: Inferable Natural sem => sem Natural
natural = infer
-string :: Inferable String repr => repr String
+string :: Inferable String sem => sem String
string = infer
-- * Class 'Listable'
-class Listable repr where
- cons :: repr (a -> [a] -> [a])
- nil :: repr [a]
+class Listable sem where
+ cons :: sem (a -> [a] -> [a])
+ nil :: sem [a]
cons = liftDerived cons
nil = liftDerived nil
default cons ::
- FromDerived Listable repr =>
- repr (a -> [a] -> [a])
+ FromDerived Listable sem =>
+ sem (a -> [a] -> [a])
default nil ::
- FromDerived Listable repr =>
- repr [a]
+ FromDerived Listable sem =>
+ sem [a]
-- * Class 'Maybeable'
-class Maybeable repr where
- nothing :: repr (Maybe a)
- just :: repr (a -> Maybe a)
+class Maybeable sem where
+ nothing :: sem (Maybe a)
+ just :: sem (a -> Maybe a)
nothing = liftDerived nothing
just = liftDerived just
default nothing ::
- FromDerived Maybeable repr =>
- repr (Maybe a)
+ FromDerived Maybeable sem =>
+ sem (Maybe a)
default just ::
- FromDerived Maybeable repr =>
- repr (a -> Maybe a)
+ FromDerived Maybeable sem =>
+ sem (a -> Maybe a)
-- * Class 'IsoFunctor'
-class IsoFunctor repr where
- (<%>) :: Iso a b -> repr a -> repr b; infixl 4 <%>
+class IsoFunctor sem where
+ (<%>) :: Iso a b -> sem a -> sem b; infixl 4 <%>
(<%>) iso = liftDerived1 (iso <%>)
default (<%>) ::
- FromDerived1 IsoFunctor repr =>
- Iso a b -> repr a -> repr b
+ FromDerived1 IsoFunctor sem =>
+ Iso a b -> sem a -> sem b
-- ** Type 'Iso'
data Iso a b = Iso { a2b :: a->b, b2a :: b->a }
-- | Beware that this is an @infixr@,
-- not @infixl@ like 'Control.Applicative.<*>';
-- this is to follow what is expected by 'ADT'.
-class ProductFunctor repr where
- (<.>) :: repr a -> repr b -> repr (a, b); infixr 4 <.>
+class ProductFunctor sem where
+ (<.>) :: sem a -> sem b -> sem (a, b); infixr 4 <.>
(<.>) = liftDerived2 (<.>)
default (<.>) ::
- FromDerived2 ProductFunctor repr =>
- repr a -> repr b -> repr (a, b)
- (<.) :: repr a -> repr () -> repr a; infixr 4 <.
+ FromDerived2 ProductFunctor sem =>
+ sem a -> sem b -> sem (a, b)
+ (<.) :: sem a -> sem () -> sem a; infixr 4 <.
ra <. rb = Iso Tuple.fst (, ()) <%> (ra <.> rb)
- default (<.) :: IsoFunctor repr => repr a -> repr () -> repr a
- (.>) :: repr () -> repr a -> repr a; infixr 4 .>
+ default (<.) :: IsoFunctor sem => sem a -> sem () -> sem a
+ (.>) :: sem () -> sem a -> sem a; infixr 4 .>
ra .> rb = Iso Tuple.snd (() ,) <%> (ra <.> rb)
- default (.>) :: IsoFunctor repr => repr () -> repr a -> repr a
+ default (.>) :: IsoFunctor sem => sem () -> sem a -> sem a
-- * Class 'SumFunctor'
-- | Beware that this is an @infixr@,
-- not @infixl@ like 'Control.Applicative.<|>';
-- this is to follow what is expected by 'ADT'.
-class SumFunctor repr where
- (<+>) :: repr a -> repr b -> repr (Either a b); infixr 3 <+>
+class SumFunctor sem where
+ (<+>) :: sem a -> sem b -> sem (Either a b); infixr 3 <+>
(<+>) = liftDerived2 (<+>)
default (<+>) ::
- FromDerived2 SumFunctor repr =>
- repr a -> repr b -> repr (Either a b)
+ FromDerived2 SumFunctor sem =>
+ sem a -> sem b -> sem (Either a b)
-- * Class 'AlternativeFunctor'
-- | Beware that this is an @infixr@,
-- not @infixl@ like 'Control.Applicative.<|>';
-- this is to follow what is expected by 'ADT'.
-class AlternativeFunctor repr where
- (<|>) :: repr a -> repr a -> repr a; infixr 3 <|>
+class AlternativeFunctor sem where
+ (<|>) :: sem a -> sem a -> sem a; infixr 3 <|>
(<|>) = liftDerived2 (<|>)
default (<|>) ::
- FromDerived2 AlternativeFunctor repr =>
- repr a -> repr a -> repr a
+ FromDerived2 AlternativeFunctor sem =>
+ sem a -> sem a -> sem a
-- * Class 'Dicurryable'
-class Dicurryable repr where
+class Dicurryable sem where
dicurry ::
CurryN args =>
proxy args ->
(args-..->a) -> -- construction
(a->Tuples args) -> -- destruction
- repr (Tuples args) ->
- repr a
+ sem (Tuples args) ->
+ sem a
dicurry args constr destr = liftDerived1 (dicurry args constr destr)
default dicurry ::
- FromDerived1 Dicurryable repr =>
+ FromDerived1 Dicurryable sem =>
CurryN args =>
proxy args ->
(args-..->a) ->
(a->Tuples args) ->
- repr (Tuples args) ->
- repr a
+ sem (Tuples args) ->
+ sem a
construct ::
- forall args a repr.
- Dicurryable repr =>
+ forall args a sem.
+ Dicurryable sem =>
Generic a =>
EoTOfRep a =>
CurryN args =>
Tuples args ~ EoT (ADT a) =>
(args ~ Args (args-..->a)) =>
(args-..->a) ->
- repr (Tuples args) ->
- repr a
+ sem (Tuples args) ->
+ sem a
construct f = dicurry (Proxy::Proxy args) f eotOfadt
adt ::
- forall adt repr.
- IsoFunctor repr =>
+ forall adt sem.
+ IsoFunctor sem =>
Generic adt =>
RepOfEoT adt =>
EoTOfRep adt =>
- repr (EoT (ADT adt)) ->
- repr adt
+ sem (EoT (ADT adt)) ->
+ sem adt
adt = (<%>) (Iso adtOfeot eotOfadt)
-- * Class 'IfSemantic'
-- * Class 'Monoidable'
class
- ( Emptyable repr
- , Semigroupable repr
- ) => Monoidable repr
+ ( Emptyable sem
+ , Semigroupable sem
+ ) => Monoidable sem
instance
- ( Emptyable repr
- , Semigroupable repr
- ) => Monoidable repr
+ ( Emptyable sem
+ , Semigroupable sem
+ ) => Monoidable sem
-- ** Class 'Emptyable'
-class Emptyable repr where
- empty :: repr a
+class Emptyable sem where
+ empty :: sem a
empty = liftDerived empty
default empty ::
- FromDerived Emptyable repr =>
- repr a
+ FromDerived Emptyable sem =>
+ sem a
-- ** Class 'Semigroupable'
-class Semigroupable repr where
- concat :: Semigroup a => repr (a -> a -> a)
+class Semigroupable sem where
+ concat :: Semigroup a => sem (a -> a -> a)
concat = liftDerived concat
default concat ::
- FromDerived Semigroupable repr =>
+ FromDerived Semigroupable sem =>
Semigroup a =>
- repr (a -> a -> a)
+ sem (a -> a -> a)
infixr 6 `concat`, <>
(<>) ::
- Abstractable repr => Semigroupable repr => Semigroup a =>
- repr a -> repr a -> repr a
+ Abstractable sem => Semigroupable sem => Semigroup a =>
+ sem a -> sem a -> sem a
(<>) x y = concat .@ x .@ y
-- ** Class 'Optionable'
-class Optionable repr where
- optional :: repr a -> repr (Maybe a)
+class Optionable sem where
+ optional :: sem a -> sem (Maybe a)
optional = liftDerived1 optional
default optional ::
- FromDerived1 Optionable repr =>
- repr a -> repr (Maybe a)
+ FromDerived1 Optionable sem =>
+ sem a -> sem (Maybe a)
-- * Class 'Repeatable'
-class Repeatable repr where
- many0 :: repr a -> repr [a]
- many1 :: repr a -> repr [a]
+class Repeatable sem where
+ many0 :: sem a -> sem [a]
+ many1 :: sem a -> sem [a]
many0 = liftDerived1 many0
many1 = liftDerived1 many1
default many0 ::
- FromDerived1 Repeatable repr =>
- repr a -> repr [a]
+ FromDerived1 Repeatable sem =>
+ sem a -> sem [a]
default many1 ::
- FromDerived1 Repeatable repr =>
- repr a -> repr [a]
+ FromDerived1 Repeatable sem =>
+ sem a -> sem [a]
-- | Alias to 'many0'.
-many :: Repeatable repr => repr a -> repr [a]
+many :: Repeatable sem => sem a -> sem [a]
many = many0
-- | Alias to 'many1'.
-some :: Repeatable repr => repr a -> repr [a]
+some :: Repeatable sem => sem a -> sem [a]
some = many1
-- * Class 'Permutable'
-class Permutable repr where
- -- Use @TypeFamilyDependencies@ to help type-inference infer @(repr)@.
- type Permutation (repr:: Semantic) = (r :: Semantic) | r -> repr
- type Permutation repr = Permutation (Derived repr)
- permutable :: Permutation repr a -> repr a
- perm :: repr a -> Permutation repr a
- noPerm :: Permutation repr ()
- permWithDefault :: a -> repr a -> Permutation repr a
+class Permutable sem where
+ -- Use @TypeFamilyDependencies@ to help type-inference infer @(sem)@.
+ type Permutation (sem:: Semantic) = (r :: Semantic) | r -> sem
+ type Permutation sem = Permutation (Derived sem)
+ permutable :: Permutation sem a -> sem a
+ perm :: sem a -> Permutation sem a
+ noPerm :: Permutation sem ()
+ permWithDefault :: a -> sem a -> Permutation sem a
optionalPerm ::
- Eitherable repr => IsoFunctor repr => Permutable repr =>
- repr a -> Permutation repr (Maybe a)
+ Eitherable sem => IsoFunctor sem => Permutable sem =>
+ sem a -> Permutation sem (Maybe a)
optionalPerm = permWithDefault Nothing Fun.. (<%>) (Iso Just fromJust)
(<&>) ::
- Permutable repr =>
- ProductFunctor (Permutation repr) =>
- repr a ->
- Permutation repr b ->
- Permutation repr (a, b)
+ Permutable sem =>
+ ProductFunctor (Permutation sem) =>
+ sem a ->
+ Permutation sem b ->
+ Permutation sem (a, b)
x <&> y = perm x <.> y
infixr 4 <&>
{-# INLINE (<&>) #-}
(<?&>) ::
- Eitherable repr =>
- IsoFunctor repr =>
- Permutable repr =>
- ProductFunctor (Permutation repr) =>
- repr a ->
- Permutation repr b ->
- Permutation repr (Maybe a, b)
+ Eitherable sem =>
+ IsoFunctor sem =>
+ Permutable sem =>
+ ProductFunctor (Permutation sem) =>
+ sem a ->
+ Permutation sem b ->
+ Permutation sem (Maybe a, b)
x <?&> y = optionalPerm x <.> y
infixr 4 <?&>
{-# INLINE (<?&>) #-}
(<*&>) ::
- Eitherable repr =>
- Repeatable repr =>
- IsoFunctor repr =>
- Permutable repr =>
- ProductFunctor (Permutation repr) =>
- repr a ->
- Permutation repr b ->
- Permutation repr ([a],b)
+ Eitherable sem =>
+ Repeatable sem =>
+ IsoFunctor sem =>
+ Permutable sem =>
+ ProductFunctor (Permutation sem) =>
+ sem a ->
+ Permutation sem b ->
+ Permutation sem ([a],b)
x <*&> y = permWithDefault [] (many1 x) <.> y
infixr 4 <*&>
{-# INLINE (<*&>) #-}
(<+&>) ::
- Eitherable repr =>
- Repeatable repr =>
- IsoFunctor repr =>
- Permutable repr =>
- ProductFunctor (Permutation repr) =>
- repr a ->
- Permutation repr b ->
- Permutation repr ([a], b)
+ Eitherable sem =>
+ Repeatable sem =>
+ IsoFunctor sem =>
+ Permutable sem =>
+ ProductFunctor (Permutation sem) =>
+ sem a ->
+ Permutation sem b ->
+ Permutation sem ([a], b)
x <+&> y = perm (many1 x) <.> y
infixr 4 <+&>
{-# INLINE (<+&>) #-}
-- * Class 'Routable'
-class Routable repr where
- (<!>) :: repr a -> repr b -> repr (a, b); infixr 4 <!>
+class Routable sem where
+ (<!>) :: sem a -> sem b -> sem (a, b); infixr 4 <!>
(<!>) = liftDerived2 (<!>)
default (<!>) ::
- FromDerived2 Routable repr =>
- repr a -> repr b -> repr (a, b)
+ FromDerived2 Routable sem =>
+ sem a -> sem b -> sem (a, b)
-- | Like @(,)@ but @infixr@.
-- Mostly useful for clarity when using 'Routable'.
infixr 4 :!:
-- * Class 'Voidable'
-class Voidable repr where
- -- | Useful to supply @(a)@ to a @(repr)@ consuming @(a)@,
+class Voidable sem where
+ -- | Useful to supply @(a)@ to a @(sem)@ consuming @(a)@,
-- for example in the format of a printing interpreter.
- void :: a -> repr a -> repr ()
+ void :: a -> sem a -> sem ()
void = liftDerived1 Fun.. void
default void ::
- FromDerived1 Voidable repr =>
- a -> repr a -> repr ()
+ FromDerived1 Voidable sem =>
+ a -> sem a -> sem ()
-- * Class 'Substractable'
-class Substractable repr where
- (<->) :: repr a -> repr b -> repr a; infixr 3 <->
+class Substractable sem where
+ (<->) :: sem a -> sem b -> sem a; infixr 3 <->
(<->) = liftDerived2 (<->)
default (<->) ::
- FromDerived2 Substractable repr =>
- repr a -> repr b -> repr a
+ FromDerived2 Substractable sem =>
+ sem a -> sem b -> sem a
import Symantic.Derive
-- * Type 'SomeData'
-data SomeData repr a =
+data SomeData sem a =
forall able.
- ( Derivable (Data able repr)
+ ( Derivable (Data able sem)
, Typeable able
- ) => SomeData (Data able repr a)
+ ) => SomeData (Data able sem a)
-type instance Derived (SomeData repr) = repr
-instance Derivable (SomeData repr) where
+type instance Derived (SomeData sem) = sem
+instance Derivable (SomeData sem) where
derive (SomeData x) = derive x
-- ** Type 'Data'
data family Data
(able :: ReprKind -> Constraint)
:: ReprKind -> ReprKind
-type instance Derived (Data able repr) = repr
+type instance Derived (Data able sem) = sem
-- | Convenient utility to pattern-match a 'SomeData'.
-pattern Data :: Typeable able => Data able repr a -> SomeData repr a
+pattern Data :: Typeable able => Data able sem a -> SomeData sem a
pattern Data x <- (unSomeData -> Maybe.Just x)
--- | @(unSomeData c :: 'Maybe' ('Data' able repr a))@
+-- | @(unSomeData c :: 'Maybe' ('Data' able sem a))@
-- extract the data-constructor from the given 'SomeData'
--- iif. it belongs to the @('Data' able repr a)@ data-instance.
+-- iif. it belongs to the @('Data' able sem a)@ data-instance.
unSomeData ::
- forall able repr a.
+ forall able sem a.
Typeable able =>
- SomeData repr a -> Maybe (Data able repr a)
-unSomeData (SomeData (c::Data c repr a)) =
+ SomeData sem a -> Maybe (Data able sem a)
+unSomeData (SomeData (c::Data c sem a)) =
case typeRep @able `eqTypeRep` typeRep @c of
Maybe.Just HRefl -> Maybe.Just c
Maybe.Nothing -> Maybe.Nothing
-- Abstractable
-data instance Data Abstractable repr a where
- (:@) :: SomeData repr (a->b) -> SomeData repr a -> Data Abstractable repr b
- Lam :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)
- Lam1 :: (SomeData repr a -> SomeData repr b) -> Data Abstractable repr (a->b)
- Var :: repr a -> Data Abstractable repr a
+data instance Data Abstractable sem a where
+ (:@) :: SomeData sem (a->b) -> SomeData sem a -> Data Abstractable sem b
+ Lam :: (SomeData sem a -> SomeData sem b) -> Data Abstractable sem (a->b)
+ Lam1 :: (SomeData sem a -> SomeData sem b) -> Data Abstractable sem (a->b)
+ Var :: sem a -> Data Abstractable sem a
-- FIXME: add constructors
instance
- ( Abstractable repr
- ) => Derivable (Data Abstractable repr) where
+ ( Abstractable sem
+ ) => Derivable (Data Abstractable sem) where
derive = \case
f :@ x -> derive f .@ derive x
Lam f -> lam (\x -> derive (f (SomeData (Var x))))
Lam1 f -> lam1 (\x -> derive (f (SomeData (Var x))))
Var x -> var x
instance
- ( Abstractable repr
- ) => Abstractable (SomeData repr) where
+ ( Abstractable sem
+ ) => Abstractable (SomeData sem) where
f .@ x = SomeData (f :@ x)
lam f = SomeData (Lam f)
lam1 f = SomeData (Lam1 f)
-- Functionable
instance
- ( Abstractable repr
- ) => Functionable (SomeData repr) where
+ ( Abstractable sem
+ ) => Functionable (SomeData sem) where
($) = lam1 (\f -> lam1 (\x -> f .@ x))
(.) = lam1 (\f -> lam1 (\g -> lam1 (\x -> f .@ (g .@ x))))
const = lam1 (\x -> lam1 (\_y -> x))
id = lam1 (\x -> x)
-- Anythingable
-data instance Data Anythingable repr a where
- Anything :: repr a -> Data Anythingable repr a
+data instance Data Anythingable sem a where
+ Anything :: sem a -> Data Anythingable sem a
instance
- ( Anythingable repr
- ) => Derivable (Data Anythingable repr) where
+ ( Anythingable sem
+ ) => Derivable (Data Anythingable sem) where
derive = \case
Anything x -> anything x
-instance Anythingable (SomeData repr)
-instance Anythingable (Data Anythingable repr)
+instance Anythingable (SomeData sem)
+instance Anythingable (Data Anythingable sem)
-- Bottomable
-data instance Data Bottomable repr a where
- Bottom :: Data Bottomable repr a
-instance Bottomable repr => Derivable (Data Bottomable repr) where
+data instance Data Bottomable sem a where
+ Bottom :: Data Bottomable sem a
+instance Bottomable sem => Derivable (Data Bottomable sem) where
derive Bottom{} = bottom
-- Constantable
-data instance Data (Constantable c) repr a where
- Constant :: {-Typeable c =>-} c -> Data (Constantable c) repr c
-instance Constantable c repr => Derivable (Data (Constantable c) repr) where
+data instance Data (Constantable c) sem a where
+ Constant :: {-Typeable c =>-} c -> Data (Constantable c) sem c
+instance Constantable c sem => Derivable (Data (Constantable c) sem) where
derive = \case
Constant x -> constant x
instance
- ( Constantable c repr
+ ( Constantable c sem
, Typeable c
- ) => Constantable c (SomeData repr) where
+ ) => Constantable c (SomeData sem) where
constant c = SomeData (Constant c)
-instance {-Typeable c =>-} Constantable c (Data (Constantable c) repr) where
+instance {-Typeable c =>-} Constantable c (Data (Constantable c) sem) where
constant = Constant
-- Eitherable
-data instance Data Eitherable repr a where
- Left :: Data Eitherable repr (l -> Either l r)
- Right :: Data Eitherable repr (r -> Either l r)
-instance Eitherable repr => Derivable (Data Eitherable repr) where
+data instance Data Eitherable sem a where
+ Left :: Data Eitherable sem (l -> Either l r)
+ Right :: Data Eitherable sem (r -> Either l r)
+instance Eitherable sem => Derivable (Data Eitherable sem) where
derive = \case
Left -> left
Right -> right
instance
- ( Eitherable repr
- ) => Eitherable (SomeData repr) where
+ ( Eitherable sem
+ ) => Eitherable (SomeData sem) where
left = SomeData Left
right = SomeData Right
-instance Eitherable (Data Eitherable repr) where
+instance Eitherable (Data Eitherable sem) where
left = Left
right = Right
-- Equalable
-data instance Data Equalable repr a where
- Equal :: Eq.Eq a => Data Equalable repr (a -> a -> Bool)
-instance Equalable repr => Derivable (Data Equalable repr) where
+data instance Data Equalable sem a where
+ Equal :: Eq.Eq a => Data Equalable sem (a -> a -> Bool)
+instance Equalable sem => Derivable (Data Equalable sem) where
derive = \case
Equal -> equal
instance
- ( Equalable repr
- ) => Equalable (SomeData repr) where
+ ( Equalable sem
+ ) => Equalable (SomeData sem) where
equal = SomeData Equal
-instance Equalable (Data Equalable repr) where
+instance Equalable (Data Equalable sem) where
equal = Equal
-- Emptyable
-data instance Data Emptyable repr a where
- Empty :: Data Emptyable repr a
-instance Emptyable repr => Derivable (Data Emptyable repr) where
+data instance Data Emptyable sem a where
+ Empty :: Data Emptyable sem a
+instance Emptyable sem => Derivable (Data Emptyable sem) where
derive = \case
Empty -> empty
instance
- ( Emptyable repr
- ) => Emptyable (SomeData repr) where
+ ( Emptyable sem
+ ) => Emptyable (SomeData sem) where
empty = SomeData Empty
-instance Emptyable (Data Emptyable repr) where
+instance Emptyable (Data Emptyable sem) where
empty = Empty
-- Semigroupable
-data instance Data Semigroupable repr a where
- Concat :: Semigroup a => Data Semigroupable repr (a -> a -> a)
+data instance Data Semigroupable sem a where
+ Concat :: Semigroup a => Data Semigroupable sem (a -> a -> a)
infixr 4 `Concat`
-instance Semigroupable repr => Derivable (Data Semigroupable repr) where
+instance Semigroupable sem => Derivable (Data Semigroupable sem) where
derive = \case
Concat -> concat
instance
- ( Semigroupable repr
- ) => Semigroupable (SomeData repr) where
+ ( Semigroupable sem
+ ) => Semigroupable (SomeData sem) where
concat = SomeData Concat
-instance Semigroupable (Data Semigroupable repr) where
+instance Semigroupable (Data Semigroupable sem) where
concat = Concat
-- IfThenElseable
-data instance Data IfThenElseable repr a where
+data instance Data IfThenElseable sem a where
IfThenElse ::
- SomeData repr Bool ->
- SomeData repr a ->
- SomeData repr a ->
- Data IfThenElseable repr a
-instance IfThenElseable repr => Derivable (Data IfThenElseable repr) where
+ SomeData sem Bool ->
+ SomeData sem a ->
+ SomeData sem a ->
+ Data IfThenElseable sem a
+instance IfThenElseable sem => Derivable (Data IfThenElseable sem) where
derive = \case
IfThenElse test ok ko -> ifThenElse (derive test) (derive ok) (derive ko)
instance
- ( IfThenElseable repr
- ) => IfThenElseable (SomeData repr) where
+ ( IfThenElseable sem
+ ) => IfThenElseable (SomeData sem) where
ifThenElse test ok ko = SomeData (IfThenElse test ok ko)
-instance IfThenElseable repr => IfThenElseable (Data IfThenElseable repr) where
+instance IfThenElseable sem => IfThenElseable (Data IfThenElseable sem) where
ifThenElse test ok ko = IfThenElse (SomeData test) (SomeData ok) (SomeData ko)
-- Listable
-data instance Data Listable repr a where
- Cons :: Data Listable repr (a -> [a] -> [a])
- Nil :: Data Listable repr [a]
+data instance Data Listable sem a where
+ Cons :: Data Listable sem (a -> [a] -> [a])
+ Nil :: Data Listable sem [a]
infixr 4 `Cons`
-instance Listable repr => Derivable (Data Listable repr) where
+instance Listable sem => Derivable (Data Listable sem) where
derive = \case
Cons -> cons
Nil -> nil
instance
- ( Listable repr
- ) => Listable (SomeData repr) where
+ ( Listable sem
+ ) => Listable (SomeData sem) where
cons = SomeData Cons
nil = SomeData Nil
-instance Listable (Data Listable repr) where
+instance Listable (Data Listable sem) where
cons = Cons
nil = Nil
-- Maybeable
-data instance Data Maybeable repr a where
- Nothing :: Data Maybeable repr (Maybe a)
- Just :: Data Maybeable repr (a -> Maybe a)
-instance Maybeable repr => Derivable (Data Maybeable repr) where
+data instance Data Maybeable sem a where
+ Nothing :: Data Maybeable sem (Maybe a)
+ Just :: Data Maybeable sem (a -> Maybe a)
+instance Maybeable sem => Derivable (Data Maybeable sem) where
derive = \case
Nothing -> nothing
Just -> just
instance
- ( Maybeable repr
- ) => Maybeable (SomeData repr) where
+ ( Maybeable sem
+ ) => Maybeable (SomeData sem) where
nothing = SomeData Nothing
just = SomeData Just
-instance Maybeable (Data Maybeable repr) where
+instance Maybeable (Data Maybeable sem) where
nothing = Nothing
just = Just
import Data.Kind (Type)
-- * Type family 'Derived'
--- | The representation that @(repr)@ derives to.
-type family Derived (repr :: Type -> Type) :: Type -> Type
+-- | The next 'Semantic' that @(sem)@ derives to.
+type family Derived (sem :: Semantic) :: Semantic
-- * Class 'Derivable'
-- | Derive an interpreter to another interpreter
-- but also when going back from an initial encoding to a final one.
--
-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.
-class Derivable repr where
- derive :: repr a -> Derived repr a
+class Derivable sem where
+ derive :: sem a -> Derived sem a
-- * Class 'LiftDerived'
-- | Lift the 'Derived' interpreter of an interpreter, to that interpreter.
-- where 'liftDerived' can already apply the right semantic.
--
-- Note that 'derive' and 'liftDerived' are not necessarily reciprocical functions.
-class LiftDerived repr where
- liftDerived :: Derived repr a -> repr a
+class LiftDerived sem where
+ liftDerived :: Derived sem a -> sem a
-- * Class 'LiftDerived1'
-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with a single argument.
-class LiftDerived1 repr where
+class LiftDerived1 sem where
liftDerived1 ::
- (Derived repr a -> Derived repr b) ->
- repr a -> repr b
+ (Derived sem a -> Derived sem b) ->
+ sem a -> sem b
liftDerived1 f = liftDerived . f . derive
default liftDerived1 ::
- LiftDerived repr => Derivable repr =>
- (Derived repr a -> Derived repr b) ->
- repr a -> repr b
+ LiftDerived sem => Derivable sem =>
+ (Derived sem a -> Derived sem b) ->
+ sem a -> sem b
-- * Class 'LiftDerived2'
-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with two arguments.
-- Note that the default instance relies upon 'LiftDerived', not 'LiftDerived1'.
-class LiftDerived2 repr where
+class LiftDerived2 sem where
liftDerived2 ::
- (Derived repr a -> Derived repr b -> Derived repr c) ->
- repr a -> repr b -> repr c
+ (Derived sem a -> Derived sem b -> Derived sem c) ->
+ sem a -> sem b -> sem c
liftDerived2 f a b = liftDerived (f (derive a) (derive b))
default liftDerived2 ::
- LiftDerived repr => Derivable repr =>
- (Derived repr a -> Derived repr b -> Derived repr c) ->
- repr a -> repr b -> repr c
+ LiftDerived sem => Derivable sem =>
+ (Derived sem a -> Derived sem b -> Derived sem c) ->
+ sem a -> sem b -> sem c
-- * Class 'LiftDerived3'
-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.
-- Note that the default instance relies upon 'LiftDerived', not 'LiftDerived2'.
-class LiftDerived3 repr where
+class LiftDerived3 sem where
liftDerived3 ::
- (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
- repr a -> repr b -> repr c -> repr d
+ (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d) ->
+ sem a -> sem b -> sem c -> sem d
liftDerived3 f a b c = liftDerived (f (derive a) (derive b) (derive c))
default liftDerived3 ::
- LiftDerived repr => Derivable repr =>
- (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d) ->
- repr a -> repr b -> repr c -> repr d
+ LiftDerived sem => Derivable sem =>
+ (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d) ->
+ sem a -> sem b -> sem c -> sem d
-- * Class 'LiftDerived4'
-- | Convenient wrapper of 'derive' and 'liftDerived' for functions with three arguments.
-- Note that the default instance relies upon 'LiftDerived', not 'LiftDerived3'.
-class LiftDerived4 repr where
+class LiftDerived4 sem where
liftDerived4 ::
- (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d -> Derived repr e) ->
- repr a -> repr b -> repr c -> repr d -> repr e
+ (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d -> Derived sem e) ->
+ sem a -> sem b -> sem c -> sem d -> sem e
liftDerived4 f a b c d = liftDerived (f (derive a) (derive b) (derive c) (derive d))
default liftDerived4 ::
- LiftDerived repr => Derivable repr =>
- (Derived repr a -> Derived repr b -> Derived repr c -> Derived repr d -> Derived repr e) ->
- repr a -> repr b -> repr c -> repr d -> repr e
+ LiftDerived sem => Derivable sem =>
+ (Derived sem a -> Derived sem b -> Derived sem c -> Derived sem d -> Derived sem e) ->
+ sem a -> sem b -> sem c -> sem d -> sem e
-- * Type synonyms @FromDerived*@
--- | Convenient type synonym for using 'liftDerived' on symantic class @(sym)@.
-type FromDerived sym repr = ( LiftDerived repr, sym (Derived repr) )
-type FromDerived1 sym repr = ( LiftDerived1 repr, sym (Derived repr) )
-type FromDerived2 sym repr = ( LiftDerived2 repr, sym (Derived repr) )
-type FromDerived3 sym repr = ( LiftDerived3 repr, sym (Derived repr) )
-type FromDerived4 sym repr = ( LiftDerived4 repr, sym (Derived repr) )
+-- | Convenient type synonym for using 'liftDerived' on 'Syntax' @(syn)@.
+type FromDerived syn sem = ( LiftDerived sem, syn (Derived sem) )
+type FromDerived1 syn sem = ( LiftDerived1 sem, syn (Derived sem) )
+type FromDerived2 syn sem = ( LiftDerived2 sem, syn (Derived sem) )
+type FromDerived3 syn sem = ( LiftDerived3 sem, syn (Derived sem) )
+type FromDerived4 syn sem = ( LiftDerived4 sem, syn (Derived sem) )
--
-- DOC: Demonstrating Lambda Calculus Reduction, Peter Sestoft, 2001,
-- https://www.itu.dk/people/sestoft/papers/sestoft-lamreduce.pdf
-normalOrderReduction :: forall repr a.
- Abstractable repr =>
- IfThenElseable repr =>
- SomeData repr a -> SomeData repr a
+normalOrderReduction :: forall sem a.
+ Abstractable sem =>
+ IfThenElseable sem =>
+ SomeData sem a -> SomeData sem a
normalOrderReduction = nor
where
-- | normal-order reduction
- nor :: SomeData repr b -> SomeData repr b
+ nor :: SomeData sem b -> SomeData sem b
nor = \case
Data (Lam f) -> lam (nor Fun.. f)
Data (Lam1 f) -> lam1 (nor Fun.. f)
x' -> nor x' .@ nor y
Data (IfThenElse test ok ko) ->
case nor test of
- Data (Constant b :: Data (Constantable Bool) repr Bool) ->
+ Data (Constant b :: Data (Constantable Bool) sem Bool) ->
if b then nor ok else nor ko
t -> ifThenElse (nor t) (nor ok) (nor ko)
x -> x
-- | weak-head normal-form
- whnf :: SomeData repr b -> SomeData repr b
+ whnf :: SomeData sem b -> SomeData sem b
whnf = \case
Data (x :@ y) -> case whnf x of
Data (Lam1 f) -> whnf (f y)
sourcephile / git / haskell / symantic-base.git / commitdiff