symantic-lib/Language/Symantic/Lib/MonoFoldable.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'MonoFoldable'.
   4 module Language.Symantic.Lib.MonoFoldable where
   5
   6 import Data.MonoTraversable (MonoFoldable)
   7 import qualified Data.MonoTraversable as MT
   8
   9 import Language.Symantic
  10 import Language.Symantic.Lib.Bool (tyBool)
  11 import Language.Symantic.Lib.Function ()
  12 import Language.Symantic.Lib.Int (tyInt)
  13 import Language.Symantic.Lib.List (tyList)
  14 import Language.Symantic.Lib.MonoFunctor (famElement, o0, e1)
  15 import Language.Symantic.Lib.Monoid (tyMonoid)
  16
  17 -- * Class 'Sym_MonoFoldable'
  18 type instance Sym MonoFoldable = Sym_MonoFoldable
  19 class Sym_MonoFoldable term where
  20         ofoldMap :: (MonoFoldable o, Monoid m) => term (MT.Element o -> m) -> term o -> term m
  21         ofoldr   :: MonoFoldable o => term (MT.Element o -> b -> b) -> term b -> term o -> term b
  22         ofoldl'  :: MonoFoldable o => term (b -> MT.Element o -> b) -> term b -> term o -> term b
  23         olength  :: MonoFoldable o => term o -> term Int
  24         onull    :: MonoFoldable o => term o -> term Bool
  25         oall     :: MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool
  26         oany     :: MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool
  27         otoList  :: MonoFoldable o => term o -> term [MT.Element o]
  28         default ofoldMap :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => Monoid m => term (MT.Element o -> m) -> term o -> term m
  29         default ofoldr   :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => term (MT.Element o -> b -> b) -> term b -> term o -> term b
  30         default ofoldl'  :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => term (b -> MT.Element o -> b) -> term b -> term o -> term b
  31         default olength  :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => term o -> term Int
  32         default onull    :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => term o -> term Bool
  33         default oall     :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool
  34         default oany     :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => term (MT.Element o -> Bool) -> term o -> term Bool
  35         default otoList  :: Sym_MonoFoldable (UnT term) => Trans term => MonoFoldable o => term o -> term [MT.Element o]
  36         ofoldMap = trans2 ofoldMap
  37         ofoldr   = trans3 ofoldr
  38         ofoldl'  = trans3 ofoldl'
  39         olength  = trans1 olength
  40         onull    = trans1 onull
  41         oall     = trans2 oall
  42         oany     = trans2 oany
  43         otoList  = trans1 otoList
  44
  45 -- Interpreting
  46 instance Sym_MonoFoldable Eval where
  47         ofoldMap = eval2 MT.ofoldMap
  48         ofoldr   = eval3 MT.ofoldr
  49         ofoldl'  = eval3 MT.ofoldl'
  50         olength  = eval1 MT.olength
  51         onull    = eval1 MT.onull
  52         oall     = eval2 MT.oall
  53         oany     = eval2 MT.oany
  54         otoList  = eval1 MT.otoList
  55 instance Sym_MonoFoldable View where
  56         ofoldMap = view2 "ofoldMap"
  57         ofoldr   = view3 "ofoldr"
  58         ofoldl'  = view3 "ofoldl'"
  59         olength  = view1 "olength"
  60         onull    = view1 "onull"
  61         oall     = view2 "oall"
  62         oany     = view2 "oany"
  63         otoList  = view1 "otoList"
  64 instance (Sym_MonoFoldable r1, Sym_MonoFoldable r2) => Sym_MonoFoldable (Dup r1 r2) where
  65         ofoldMap = dup2 @Sym_MonoFoldable ofoldMap
  66         ofoldr   = dup3 @Sym_MonoFoldable ofoldr
  67         ofoldl'  = dup3 @Sym_MonoFoldable ofoldl'
  68         olength  = dup1 @Sym_MonoFoldable olength
  69         onull    = dup1 @Sym_MonoFoldable onull
  70         oall     = dup2 @Sym_MonoFoldable oall
  71         oany     = dup2 @Sym_MonoFoldable oany
  72         otoList  = dup1 @Sym_MonoFoldable otoList
  73
  74 -- Transforming
  75 instance (Sym_MonoFoldable term, Sym_Lambda term) => Sym_MonoFoldable (BetaT term)
  76
  77 -- Typing
  78 instance NameTyOf MonoFoldable where
  79         nameTyOf _c = ["MonoFoldable"] `Mod` "MonoFoldable"
  80 instance FixityOf MonoFoldable
  81 instance ClassInstancesFor MonoFoldable
  82 instance TypeInstancesFor MonoFoldable
  83
  84 -- Compiling
  85 instance Gram_Term_AtomsFor src ss g MonoFoldable
  86 instance (Source src, SymInj ss MonoFoldable) => ModuleFor src ss MonoFoldable where
  87         moduleFor = ["MonoFoldable"] `moduleWhere`
  88          [ "ofoldMap" := teMonoFoldable_ofoldMap
  89          , "otoList"  := teMonoFoldable_otoList
  90          , "ofoldr"   := teMonoFoldable_ofoldr
  91          , "ofoldl'"  := teMonoFoldable_ofoldl'
  92          , "olength"  := teMonoFoldable_olength
  93          , "onull"    := teMonoFoldable_onull
  94          , "oall"     := teMonoFoldable_oall
  95          , "oany"     := teMonoFoldable_oany
  96          ]
  97
  98 -- ** 'Type's
  99 tyMonoFoldable :: Source src => Type src vs a -> Type src vs (MonoFoldable a)
 100 tyMonoFoldable a = tyConstLen @(K MonoFoldable) @MonoFoldable (lenVars a) `tyApp` a
 101
 102 -- ** 'Term's
 103 teMonoFoldable_ofoldMap :: TermDef MonoFoldable '[Proxy o, Proxy e, Proxy m] (MonoFoldable o # Monoid m # e #~ MT.Element o #> ((e -> m) -> o -> m))
 104 teMonoFoldable_ofoldMap = Term (tyMonoFoldable o0 # tyMonoid m # e1 #~ famElement o0) ((e1 ~> m) ~> o0 ~> m) $ teSym @MonoFoldable $ lam2 ofoldMap
 105         where
 106         m :: Source src => LenInj vs => KindInj (K m) => Type src (Proxy a ': Proxy b ': Proxy m ': vs) m
 107         m = tyVar "m" $ VarS $ VarS varZ
 108
 109 teMonoFoldable_otoList :: TermDef MonoFoldable '[Proxy o, Proxy e] (MonoFoldable o # e #~ MT.Element o #> (o -> [MT.Element o]))
 110 teMonoFoldable_otoList = Term (tyMonoFoldable o0 # e1 #~ famElement o0) (o0 ~> tyList (famElement o0)) $ teSym @MonoFoldable $ lam1 otoList
 111
 112 teMonoFoldable_ofoldr :: TermDef MonoFoldable '[Proxy o, Proxy e, Proxy a] (MonoFoldable o # e #~ MT.Element o #> ((e -> a -> a) -> a -> o -> a))
 113 teMonoFoldable_ofoldr = Term (tyMonoFoldable o0 # e1 #~ famElement o0) ((e1 ~> a ~> a) ~> a ~> o0 ~> a) $ teSym @MonoFoldable $ lam1 $ \f -> lam $ lam . ofoldr f
 114         where
 115         a :: Source src => LenInj vs => KindInj (K a) => Type src (Proxy _a ': Proxy b ': Proxy a ': vs) a
 116         a = tyVar "a" $ VarS $ VarS varZ
 117
 118 teMonoFoldable_ofoldl' :: TermDef MonoFoldable '[Proxy o, Proxy e, Proxy a] (MonoFoldable o # e #~ MT.Element o #> ((a -> e -> a) -> a -> o -> a))
 119 teMonoFoldable_ofoldl' = Term (tyMonoFoldable o0 # e1 #~ famElement o0) ((a ~> e1 ~> a) ~> a ~> o0 ~> a) $ teSym @MonoFoldable $ lam1 $ \f -> lam $ lam . ofoldl' f
 120         where
 121         a :: Source src => LenInj vs => KindInj (K a) => Type src (Proxy _a ': Proxy b ': Proxy a ': vs) a
 122         a = tyVar "a" $ VarS $ VarS varZ
 123
 124 teMonoFoldable_olength :: TermDef MonoFoldable '[Proxy o, Proxy e] (MonoFoldable o # e #~ MT.Element o #> (o -> Int))
 125 teMonoFoldable_olength = Term (tyMonoFoldable o0 # e1 #~ famElement o0) (o0 ~> tyInt) $ teSym @MonoFoldable $ lam1 olength
 126
 127 teMonoFoldable_onull :: TermDef MonoFoldable '[Proxy o] (MonoFoldable o #> (o -> Bool))
 128 teMonoFoldable_onull = Term (tyMonoFoldable o0) (o0 ~> tyBool) $ teSym @MonoFoldable $ lam1 onull
 129
 130 teMonoFoldable_oall :: TermDef MonoFoldable '[Proxy o, Proxy e] (MonoFoldable o # e #~ MT.Element o #> ((e -> Bool) -> o -> Bool))
 131 teMonoFoldable_oall = Term (tyMonoFoldable o0 # e1 #~ famElement o0) ((e1 ~> tyBool) ~> o0 ~> tyBool) $ teSym @MonoFoldable $ lam2 oall
 132
 133 teMonoFoldable_oany :: TermDef MonoFoldable '[Proxy o, Proxy e] (MonoFoldable o # e #~ MT.Element o #> ((e -> Bool) -> o -> Bool))
 134 teMonoFoldable_oany = Term (tyMonoFoldable o0 # e1 #~ famElement o0) ((e1 ~> tyBool) ~> o0 ~> tyBool) $ teSym @MonoFoldable $ lam2 oany