symantic/Language/Symantic/Typing/Module.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE PolyKinds #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 module Language.Symantic.Typing.Module where
   8
   9 import Data.Functor (Functor(..))
  10 import Data.Maybe (fromMaybe)
  11 import Data.String (IsString(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.Text (Text)
  14 import Data.Typeable
  15 import Data.Map.Strict (Map)
  16 import qualified Data.Char as C
  17 import qualified Data.List as L
  18 import qualified Data.Kind as K
  19 import qualified Data.Text as T
  20 import qualified Data.Map.Strict as Map
  21
  22 import Language.Symantic.Grammar.Fixity
  23
  24 -- * Type 'NsT'
  25 data NsT
  26  =   NsTerm
  27  |   NsType
  28
  29 -- * Type 'Name'
  30 type Name = Text
  31
  32 -- * Type 'NameTy'
  33 -- | 'Name' of a 'Type'.
  34 newtype NameTy = NameTy Text
  35  deriving (Eq, Ord, Show)
  36 instance IsString NameTy where
  37         fromString = NameTy . fromString
  38
  39 -- ** Type 'NameConst'
  40 -- | 'Name' of a 'Const'.
  41 type NameConst = NameTy
  42
  43 -- ** Type 'NameFam'
  44 -- | 'Name' of a 'Fam'.
  45 type NameFam = NameTy
  46
  47 -- ** Class 'NameOf'
  48 class NameOf a where
  49         nameOf :: a -> Name
  50
  51 -- ** Class 'NameTyOf'
  52 -- | Return the 'NameTy' of something.
  53 class NameTyOf (c::kc) where
  54         nameTyOf :: proxy c -> Mod NameTy
  55         default nameTyOf :: Typeable c => proxy c -> Mod NameTy
  56         nameTyOf c = path (tyConModule repr) `Mod` fromString (tyConName repr)
  57                 where
  58                 repr = typeRepTyCon (typeRep c)
  59                 path = fmap fromString . L.lines . fmap (\case '.' -> '\n'; x -> x)
  60
  61         isNameTyOp :: proxy c -> Bool
  62         default isNameTyOp :: Typeable c => proxy c -> Bool
  63         isNameTyOp c = let _m `Mod` NameTy n = nameTyOf c in isOp n
  64                 where
  65                 isOp = T.all $ \case
  66                          '_'  -> False
  67                          '\'' -> False
  68                          x -> case C.generalCategory x of
  69                                  C.NonSpacingMark       -> True
  70                                  C.SpacingCombiningMark -> True
  71                                  C.EnclosingMark        -> True
  72                                  C.ConnectorPunctuation -> True
  73                                  C.DashPunctuation      -> True
  74                                  C.OpenPunctuation      -> True
  75                                  C.ClosePunctuation     -> True
  76                                  C.InitialQuote         -> True
  77                                  C.FinalQuote           -> True
  78                                  C.OtherPunctuation     -> True
  79                                  C.MathSymbol           -> True
  80                                  C.CurrencySymbol       -> True
  81                                  C.ModifierSymbol       -> True
  82                                  C.OtherSymbol          -> True
  83
  84                                  C.UppercaseLetter      -> False
  85                                  C.LowercaseLetter      -> False
  86                                  C.TitlecaseLetter      -> False
  87                                  C.ModifierLetter       -> False
  88                                  C.OtherLetter          -> False
  89                                  C.DecimalNumber        -> False
  90                                  C.LetterNumber         -> False
  91                                  C.OtherNumber          -> False
  92                                  C.Space                -> False
  93                                  C.LineSeparator        -> False
  94                                  C.ParagraphSeparator   -> False
  95                                  C.Control              -> False
  96                                  C.Format               -> False
  97                                  C.Surrogate            -> False
  98                                  C.PrivateUse           -> False
  99                                  C.NotAssigned          -> False
 100
 101 -- * Type 'Mod'
 102 -- | 'PathMod' of something.
 103 data Mod a = Mod PathMod a
 104  deriving (Eq, Functor, Ord, Show)
 105
 106 -- ** Type 'PathMod'
 107 -- | Path to a 'Module'.
 108 type PathMod = [NameMod]
 109
 110 -- ** Type 'NameMod'
 111 -- | 'Name' of 'Module'.
 112 newtype NameMod = NameMod Name
 113  deriving (Eq, Ord, Show)
 114 instance IsString NameMod where
 115         fromString = NameMod . fromString
 116
 117 -- * Type 'Imports'
 118 -- | Map 'PathMod's of 'Name's.
 119 newtype Imports name = Imports (Map PathMod (MapFixity (Map name PathMod)))
 120  deriving (Eq, Show)
 121
 122 instance Ord name => Semigroup (Imports name) where
 123         Imports x <> Imports y = Imports $ Map.unionWith (<>) x y
 124 instance Ord name => Monoid (Imports name) where
 125         mempty  = Imports mempty
 126         mappend = (<>)
 127
 128 lookupImports :: Ord name => Fixy p i q a -> Mod name -> Imports name -> Maybe PathMod
 129 lookupImports f (m `Mod` n) (Imports is) =
 130         Map.lookup m is >>=
 131         Map.lookup n . getByFixity f
 132
 133 revlookupImports :: Ord name => Fixy p i q a -> Mod name -> Imports name -> Maybe PathMod
 134 revlookupImports f (m `Mod` n) (Imports is) =
 135         (fst . fst <$>) $ Map.minViewWithKey $
 136         Map.filter (\i ->
 137                 case Map.lookup n $ getByFixity f i of
 138                  Just m' | m' == m -> True
 139                  _ -> False
 140          ) is
 141
 142 -- ** Class 'ImportTypes'
 143 class ImportTypes ts where
 144         importTypes :: PathMod -> Imports NameTy
 145
 146 instance ImportTypes '[] where
 147         importTypes _p = mempty
 148 instance (NameTyOf t, FixityOf t, ImportTypes ts) => ImportTypes (Proxy t ': ts) where
 149         importTypes p = Imports (Map.singleton p byFixy) <> importTypes @ts p
 150                 where
 151                 t = Proxy @t
 152                 f = Fixity2 infixN5 `fromMaybe` fixityOf t
 153                 m `Mod` n = nameTyOf t
 154                 byFixy :: MapFixity (Map NameTy PathMod)
 155                 byFixy = case f of
 156                         Fixity1 Prefix{}  -> ByFixity{byPrefix  = Map.singleton n m, byInfix =mempty, byPostfix=mempty}
 157                         Fixity2{}         -> ByFixity{byInfix   = Map.singleton n m, byPrefix=mempty, byPostfix=mempty}
 158                         Fixity1 Postfix{} -> ByFixity{byPostfix = Map.singleton n m, byPrefix=mempty, byInfix  =mempty}
 159
 160 -- * Type 'Fixy'
 161 data Fixy p i q a where
 162  FixyPrefix  :: Fixy p i q p
 163  FixyInfix   :: Fixy p i q i
 164  FixyPostfix :: Fixy p i q q
 165 deriving instance Eq   (Fixy p i q a)
 166 deriving instance Show (Fixy p i q a)
 167
 168 fixyOfFixity :: Fixity -> Fixy a a a a
 169 fixyOfFixity (Fixity1 Prefix{})  = FixyPrefix
 170 fixyOfFixity (Fixity2 Infix{})   = FixyInfix
 171 fixyOfFixity (Fixity1 Postfix{}) = FixyPostfix
 172
 173 -- ** Class 'FixityOf'
 174 -- | Return the 'Fixity' of something.
 175 class FixityOf (c::kc) where
 176         fixityOf :: proxy c -> Maybe Fixity
 177         fixityOf _c = Nothing
 178 instance FixityOf (c::K.Type)
 179 instance FixityOf (c::K.Constraint)
 180
 181 -- ** Type 'FixyA'
 182 -- | Like 'Fixy', but when all choices have the same type.
 183 newtype FixyA = FixyA (forall (a:: *). Fixy a a a a)
 184 deriving instance Eq   FixyA
 185 deriving instance Show FixyA
 186
 187 -- ** Type 'WithFixity'
 188 data WithFixity a
 189  =   WithFixity a Fixity
 190  deriving (Eq, Functor, Show)
 191 instance IsString a => IsString (WithFixity a) where
 192         fromString a = WithFixity (fromString a) (Fixity2 infixN5)
 193
 194 withInfix :: a -> Infix -> WithFixity a
 195 withInfix a inf = a `WithFixity` Fixity2 inf
 196 withInfixR :: a -> Precedence -> WithFixity a
 197 withInfixR a p = a `WithFixity` Fixity2 (infixR p)
 198 withInfixL :: a -> Precedence -> WithFixity a
 199 withInfixL a p = a `WithFixity` Fixity2 (infixL p)
 200 withInfixN :: a -> Precedence -> WithFixity a
 201 withInfixN a p = a `WithFixity` Fixity2 (infixN p)
 202 withInfixB :: a -> (Side, Precedence) -> WithFixity a
 203 withInfixB a (lr, p) = a `WithFixity` Fixity2 (infixB lr p)
 204 withPrefix :: a -> Precedence -> WithFixity a
 205 withPrefix a p = a `WithFixity` Fixity1 (Prefix p)
 206 withPostfix :: a -> Precedence -> WithFixity a
 207 withPostfix a p = a `WithFixity` Fixity1 (Postfix p)
 208
 209 -- ** Type 'ByFixity'
 210 -- | Fixity namespace.
 211 data ByFixity p i q
 212  =   ByFixity
 213  {   byPrefix  :: p
 214  ,   byInfix   :: i
 215  ,   byPostfix :: q
 216  } deriving (Eq, Show)
 217 instance (Semigroup p, Semigroup i, Semigroup q) => Semigroup (ByFixity p i q) where
 218         ByFixity px ix qx <> ByFixity py iy qy =
 219                 ByFixity (px <> py) (ix <> iy) (qx <> qy)
 220 instance (Monoid p, Monoid i, Monoid q) => Monoid (ByFixity p i q) where
 221         mempty = ByFixity mempty mempty mempty
 222         ByFixity px ix qx `mappend` ByFixity py iy qy =
 223                 ByFixity (px `mappend` py) (ix `mappend` iy) (qx `mappend` qy)
 224
 225 getByFixity :: Fixy p i q a -> MapFixity b -> b
 226 getByFixity FixyPrefix  = byPrefix
 227 getByFixity FixyInfix   = byInfix
 228 getByFixity FixyPostfix = byPostfix
 229
 230 selectByFixity :: Fixy p i q a -> ByFixity p i q -> a
 231 selectByFixity FixyPrefix  = byPrefix
 232 selectByFixity FixyInfix   = byInfix
 233 selectByFixity FixyPostfix = byPostfix
 234
 235 -- *** Type 'MapFixity'
 236 -- | Like 'ByFixity', but with the same type parameter.
 237 type MapFixity a = ByFixity a a a
 238
 239 mapMapFixity :: (a -> b) -> MapFixity a -> MapFixity b
 240 mapMapFixity f (ByFixity p i q) = ByFixity (f p) (f i) (f q)