symantic/Language/Symantic/Compiling/Module.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE ExistentialQuantification #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE PolyKinds #-}
   7 {-# LANGUAGE UndecidableInstances #-}
   8 module Language.Symantic.Compiling.Module where
   9
  10 import Data.Bool (not)
  11 import Data.Map.Strict (Map)
  12 import Data.Maybe (fromMaybe)
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Set (Set)
  15 import Data.String (IsString(..))
  16 import Prelude hiding (mod, not, any)
  17 import qualified Data.Map.Strict as Map
  18
  19 import Language.Symantic.Grammar
  20 import Language.Symantic.Typing
  21 import Language.Symantic.Compiling.Term
  22
  23 -- * Class 'ModuleFor'
  24 class ModuleFor src ss s where
  25         moduleFor :: (PathMod, Module src ss)
  26         moduleFor = ([], moduleEmpty)
  27
  28 importModules :: PathMod -> Modules src ss -> Imports NameTe
  29 importModules as (Modules mods) =
  30         Imports $ Map.singleton as $
  31         Map.foldrWithKey
  32          (\pm (ByFixity mp mi mq) acc ->
  33                 acc <> ByFixity
  34                  { byPrefix  = pm <$ mp
  35                  , byInfix   = pm <$ mi
  36                  , byPostfix = pm <$ mq
  37                  }
  38          ) mempty mods
  39
  40 -- * Type 'Modules'
  41 newtype Modules src ss
  42  =   Modules
  43  {   modules :: Map PathMod (Module src ss)
  44  } deriving (Eq, Show)
  45
  46 unionModules :: Modules src ss -> Modules src ss -> Either Error_Module (Modules src ss)
  47 unionModules mx@(Modules x) my@(Modules y) =
  48         case check x y of
  49          Just err -> Left err
  50          Nothing  -> Right $ unionModulesUnchecked mx my
  51         where
  52         check ::
  53          Map PathMod (Module src ss) ->
  54          Map PathMod (Module src ss) ->
  55          Maybe Error_Module
  56         check x' y' =
  57                 case Map.intersectionWith (,) x' y' of
  58                  xy | null xy -> Nothing
  59                  xy ->
  60                         let errs =
  61                                 Map.filter (not . null) $
  62                                 (<$> xy) $ \(a, b) ->
  63                                         inter a b byPrefix <>
  64                                         inter a b byInfix <>
  65                                         inter a b byPostfix in
  66                         case errs of
  67                          e | null e -> Nothing
  68                          e -> Just $ Error_Module_colliding_Term e
  69                 where
  70                 inter a b f = Map.keysSet $ Map.intersection (f a) (f b)
  71
  72 unionModulesUnchecked :: Modules src ss -> Modules src ss -> Modules src ss
  73 unionModulesUnchecked (Modules x) (Modules y) =
  74         Modules $ Map.unionWith (<>) x y
  75
  76 -- ** Type 'Error_Module'
  77 data Error_Module
  78  =   Error_Module_colliding_Term (Map PathMod (Set NameTe))
  79  |   Error_Module_ambiguous (Mod NameTe) (Map PathMod NameTe)
  80  |   Error_Module_missing PathMod
  81  |   Error_Module_missing_Term (Mod NameTe) -- FixyA
  82  deriving (Eq, Show)
  83
  84 -- ** Type 'Module'
  85 type Module src ss = ByFixity (ModuleFixy src ss Unifix)
  86                               (ModuleFixy src ss Infix)
  87                               (ModuleFixy src ss Unifix)
  88
  89 moduleEmpty :: Module src ss
  90 moduleEmpty = ByFixity
  91  { byPrefix  = mempty
  92  , byInfix   = mempty
  93  , byPostfix = mempty
  94  }
  95
  96 moduleWhere :: forall src ss. Source src => PathMod -> [DefTerm src ss] -> (PathMod, Module src ss)
  97 moduleWhere mod lst =
  98         (mod,) ByFixity
  99          { byInfix = mk $ \(n `WithFixity` fixy := t) ->
 100                 case fixy of
 101                  Fixity2 inf -> [(n, Tokenizer inf $ Token_Term . setSource (TermAVT t))]
 102                  _ -> []
 103          , byPrefix = mk $ \(n `WithFixity` fixy := t) ->
 104                 case fixy of
 105                  Fixity1 pre@Prefix{} -> [(n, Tokenizer pre $ Token_Term . setSource (TermAVT t))]
 106                  _ -> []
 107          , byPostfix = mk $ \(n `WithFixity` fixy := t) ->
 108                 case fixy of
 109                  Fixity1 post@Postfix{} -> [(n, Tokenizer post $ Token_Term . setSource (TermAVT t))]
 110                  _ -> []
 111          }
 112         where
 113         mk ::
 114          (DefTerm src ss -> [(NameTe, Tokenizer src ss fixy)]) ->
 115          Map NameTe (Tokenizer src ss fixy)
 116         mk = Map.fromList . (`foldMap` lst)
 117
 118 -- *** Type 'ModuleFixy'
 119 type ModuleFixy src ss fixy = Map NameTe (Tokenizer src ss fixy)
 120
 121 -- ** Type 'Tokenizer'
 122 data Tokenizer src ss fixy
 123  =   Tokenizer
 124  {   token_fixity :: fixy
 125  ,   token_term   :: src -> Token_Term src ss
 126  }
 127 instance (Source src, Eq fixy) => Eq (Tokenizer src ss fixy) where
 128         Tokenizer fx x == Tokenizer fy y = fx == fy && (x noSource) == (y noSource)
 129 instance Source src => Show (Tokenizer src ss fixy) where
 130         show (Tokenizer _fx x) = show (x noSource)
 131
 132 -- ** Type 'AST_Term'
 133 -- | /Abstract Syntax Tree/ of 'Token_Term'.
 134 type AST_Term src ss = BinTree (Token_Term src ss)
 135
 136 -- ** Type 'Token_Term'
 137 data Token_Term src ss
 138  =   Token_Term      (TermAVT src ss)
 139  |   Token_TermVT    (TermVT src ss '[])
 140  |   Token_Term_Abst src NameTe (AST_Type src) (AST_Term src ss)
 141  |   Token_Term_Var  src NameTe
 142  |   Token_Term_Let  src NameTe (AST_Term src ss) (AST_Term src ss)
 143  |   Token_Term_App  src
 144  -- deriving (Eq, Show)
 145 instance Source src => Eq (Token_Term src ss) where
 146         Token_Term   x == Token_Term   y = x == y
 147         Token_TermVT x == Token_TermVT y = x == y
 148         Token_Term_Abst _ nx ax rx == Token_Term_Abst _ ny ay ry = nx == ny && ax == ay && rx == ry
 149         Token_Term_Var _ x == Token_Term_Var _ y = x == y
 150         Token_Term_Let _ nx ax rx == Token_Term_Let _ ny ay ry = nx == ny && ax == ay && rx == ry
 151         Token_Term_App _ == Token_Term_App _ = True
 152         _ == _ = False
 153 instance Source src => Show (Token_Term src ss) where
 154         showsPrec p (Token_Term   x) =
 155                 showParen (p >= 10) $
 156                 showString "Token_Term" .
 157                 showChar ' ' . showsPrec 10 x
 158         showsPrec p (Token_TermVT x) =
 159                 showParen (p >= 10) $
 160                 showString "Token_TermVT" .
 161                 showChar ' ' . showsPrec 10 x
 162         showsPrec p (Token_Term_Abst _ n a r) =
 163                 showParen (p >= 10) $
 164                 showString "Token_Term_Abst" .
 165                 showChar ' ' . showsPrec 10 n .
 166                 showChar ' ' . showsPrec 10 a .
 167                 showChar ' ' . showsPrec 10 r
 168         showsPrec p (Token_Term_Var _ x) =
 169                 showParen (p >= 10) $
 170                 showString "Token_Term_Var" .
 171                 showChar ' ' . showsPrec 10 x
 172         showsPrec p (Token_Term_Let _ n a r) =
 173                 showParen (p >= 10) $
 174                 showString "Token_Term_Let" .
 175                 showChar ' ' . showsPrec 10 n .
 176                 showChar ' ' . showsPrec 10 a .
 177                 showChar ' ' . showsPrec 10 r
 178         showsPrec _p (Token_Term_App _) = showString "Token_Term_App"
 179
 180 -- ** Type 'NameTe'
 181 newtype NameTe = NameTe Name
 182  deriving (Eq, Ord, Show)
 183 instance IsString NameTe where
 184         fromString = NameTe . fromString
 185 instance NameOf NameTe where
 186         nameOf (NameTe n) = n
 187
 188 -- * Class 'ModulesInj'
 189 type ModulesInj  src ss
 190  =   ModulesInjR src ss ss
 191
 192 modulesInj ::
 193  forall src ss.
 194  ModulesInj src ss =>
 195  Either Error_Module (Modules src ss)
 196 modulesInj = modulesInjR @_ @_ @ss
 197
 198 -- ** Class 'ModulesInjR'
 199 class ModulesInjR src (ss::[*]) (rs::[*]) where
 200         modulesInjR :: Either Error_Module (Modules src ss)
 201 instance ModulesInjR src ss '[] where
 202         modulesInjR = Right $ Modules mempty
 203 instance
 204  ( ModuleFor src ss s
 205  , ModulesInjR src ss rs
 206  ) => ModulesInjR src ss (Proxy s ': rs) where
 207         modulesInjR = do
 208                 x <- modulesInjR @_ @_ @rs
 209                 let (n, m) = moduleFor @_ @_  @s
 210                 Modules (Map.singleton n m) `unionModules` x
 211
 212 -- * Type 'DefTerm'
 213 data DefTerm src ss
 214  = forall vs t.
 215  (:=) (WithFixity NameTe)
 216       (forall ts. Term src ss ts vs t)
 217
 218 -- | Lookup given 'Mod' 'NameTe' into the 'Infix' 'TermDef' of given 'Modules'.
 219 --
 220 -- NOTE: 'Token_Term_App' is returned for the space 'NameTe'.
 221 lookupDefTerm ::
 222  forall src ss fixy.
 223  Fixy (ModuleFixy src ss Unifix)
 224       (ModuleFixy src ss Infix)
 225       (ModuleFixy src ss Unifix)
 226       (ModuleFixy src ss fixy) ->
 227  Imports NameTe ->
 228  Mod NameTe ->
 229  Modules src ss ->
 230  Either Error_Module (Tokenizer src ss fixy)
 231 lookupDefTerm FixyInfix _is ([] `Mod` " ") _ms =
 232         Right $ Tokenizer
 233          { token_term   = Token_Term_App @src @ss
 234          , token_fixity = Infix (Just AssocL) 9
 235          }
 236 lookupDefTerm fixy imps mn@(m `Mod` n) (Modules mods) =
 237         let m' = m `fromMaybe` lookupImports fixy mn imps in
 238         maybe (Left $ Error_Module_missing m') Right (Map.lookup m' mods) >>=
 239         maybe (Left $ Error_Module_missing_Term mn) Right .
 240         Map.lookup n . selectByFixity fixy
 241
 242 -- | Delete given 'Mod' 'NameTe' into given 'Modules'.
 243 deleteDefTerm :: Mod NameTe -> Modules src ss -> Modules src ss
 244 deleteDefTerm (m `Mod` n) (Modules ms) = Modules $ Map.adjust del m ms
 245         where del mod = mod
 246                  { byPrefix  = Map.delete n $ byPrefix  mod
 247                  , byInfix   = Map.delete n $ byInfix   mod
 248                  , byPostfix = Map.delete n $ byPostfix mod
 249                  }
 250
 251 -- | Delete given 'Mod' 'NameTe' into 'byInfix's of given 'Modules'.
 252 deleteDefTermInfix :: Mod NameTe -> Modules src ss -> Modules src ss
 253 deleteDefTermInfix (m `Mod` n) (Modules ms) = Modules $ Map.adjust del m ms
 254         where del mod = mod{byInfix = Map.delete n $ byInfix mod}
 255
 256 -- | Delete given 'Mod' 'NameTe' into 'byPrefix's of given 'Modules'.
 257 deleteDefTermPrefix :: Mod NameTe -> Modules src ss -> Modules src ss
 258 deleteDefTermPrefix (m `Mod` n) (Modules ms) = Modules $ Map.adjust del m ms
 259         where del mod = mod{byPrefix = Map.delete n $ byPrefix mod}
 260
 261 -- | Delete given 'Mod' 'NameTe' into 'byPostfix's of given 'Modules'.
 262 deleteDefTermPostix :: Mod NameTe -> Modules src ss -> Modules src ss
 263 deleteDefTermPostix (m `Mod` n) (Modules ms) = Modules $ Map.adjust del m ms
 264         where del mod = mod{byPostfix = Map.delete n $ byPostfix mod}
 265
 266 insertDefTerm ::
 267  forall src ss.
 268  Source src =>
 269  Mod (DefTerm src ss) -> Modules src ss -> Modules src ss
 270 insertDefTerm (m `Mod` (n `WithFixity` fixy := t)) (Modules ms) =
 271         Modules $ Map.insert m (insertFixity ins fixy moduleEmpty) ms
 272         where
 273         ins :: fx -> ModuleFixy src ss fx -> ModuleFixy src ss fx
 274         ins fx = Map.insert n $ Tokenizer fx $ Token_Term . setSource (TermAVT t)
 275
 276 insertTermVT ::
 277  forall src ss.
 278  Source src =>
 279  Mod (TermVT src ss '[]) -> NameTe -> Fixity ->
 280  Modules src ss -> Modules src ss
 281 insertTermVT (m `Mod` t) n fixy (Modules ms) =
 282         Modules $ Map.insert m (insertFixity ins fixy moduleEmpty) ms
 283         where
 284         ins :: fx -> ModuleFixy src ss fx -> ModuleFixy src ss fx
 285         ins fx = Map.insert n $ Tokenizer fx $ Token_TermVT . setSource t
 286
 287 insertFixity ::
 288  (forall fx. fx -> ModuleFixy src ss fx -> ModuleFixy src ss fx) ->
 289  Fixity -> Module src ss -> Module src ss
 290 insertFixity ins fx mod =
 291         case fx of
 292          Fixity1 uni@Prefix{}  -> mod {byPrefix  = ins uni $ byPrefix  mod}
 293          Fixity2 inf@Infix{}   -> mod {byInfix   = ins inf $ byInfix   mod}
 294          Fixity1 uni@Postfix{} -> mod {byPostfix = ins uni $ byPostfix mod}