Implements Class/Derive/InstanceClause in Frontend

Author: bladyjoker

lambda-buffers-frontend/lambda-buffers-frontend.cabal

@@ -98,10 +98,15 @@ library
   hs-source-dirs:  src
   exposed-modules:
     LambdaBuffers.Frontend
+    LambdaBuffers.Frontend.CheckReferences
+    LambdaBuffers.Frontend.Errors
+    LambdaBuffers.Frontend.Monad
     LambdaBuffers.Frontend.Parsec
     LambdaBuffers.Frontend.PPrint
+    LambdaBuffers.Frontend.Scope
     LambdaBuffers.Frontend.Syntax
     LambdaBuffers.Frontend.ToProto
+    LambdaBuffers.Frontend.Utils
 
 executable lbf
   import:         common-language

lambda-buffers-frontend/src/LambdaBuffers/Frontend.hs

@@ -1,78 +1,24 @@
-module LambdaBuffers.Frontend (runFrontend, FrontendError (..), FrontendResult (..), Symbol, Scope, parseModule) where
+module LambdaBuffers.Frontend (runFrontend, FrontendError (..), FrontendResult (..), parseModule) where
 
-import Control.Monad (foldM, void, when)
-import Control.Monad.Except (ExceptT, runExceptT)
+import Control.Monad (foldM, when)
+import Control.Monad.Except (runExceptT)
 import Control.Monad.State.Strict (MonadIO (liftIO), MonadTrans (lift), StateT (runStateT), gets, modify)
-import Control.Monad.Trans.Except (throwE)
 import Control.Monad.Trans.Reader (ReaderT (runReaderT), asks, local)
-import Data.Foldable (for_)
 import Data.List (isSuffixOf)
-import Data.Map (Map)
 import Data.Map qualified as Map
-import Data.Maybe (fromMaybe)
-import Data.Set (Set)
-import Data.Set qualified as Set
 import Data.Text (Text, unpack)
 import Data.Text.IO qualified as Text
-import Data.Traversable (for)
+import LambdaBuffers.Frontend.CheckReferences (checkReferences)
+import LambdaBuffers.Frontend.Errors (FrontendError)
+import LambdaBuffers.Frontend.Errors qualified as Errors
+import LambdaBuffers.Frontend.Monad (FrontRead (FrontRead, current, importPaths, visited), FrontState (FrontState, importedModules), FrontendResult (FrontendResult), FrontendT, throwE')
 import LambdaBuffers.Frontend.PPrint ()
 import LambdaBuffers.Frontend.Parsec qualified as Parsec
-import LambdaBuffers.Frontend.Syntax (Constructor (Constructor), Field (Field), Import (Import, importInfo, importModuleName), Module (moduleImports, moduleName, moduleTyDefs), ModuleAlias (ModuleAlias), ModuleName (ModuleName), ModuleNamePart (ModuleNamePart), Product (Product), Record (Record), SourceInfo, Sum (Sum), Ty (TyApp, TyRef', TyVar), TyBody (Opaque, ProductBody, RecordBody, SumBody), TyDef (TyDef, tyBody, tyDefInfo, tyName), TyName (TyName), TyRef (TyRef), defSourceInfo)
-import Prettyprinter (Doc, LayoutOptions (layoutPageWidth), PageWidth (Unbounded), Pretty (pretty), defaultLayoutOptions, layoutPretty, (<+>))
-import Prettyprinter.Render.String (renderShowS)
+import LambdaBuffers.Frontend.Scope (addToClassScope, addToTyScope, collectImportedScope, collectLocalScope)
+import LambdaBuffers.Frontend.Syntax (Import (importModuleName), Module (moduleImports, moduleName), ModuleName (ModuleName), ModuleNamePart (ModuleNamePart), SourceInfo, defSourceInfo)
+import LambdaBuffers.Frontend.Utils (ClassScope, TyScope, strip)
 import System.Directory (findFiles)
 import System.FilePath (joinPath, (<.>))
-import Text.Parsec (ParseError)
-
-data FrontRead = FrontRead
-  { current :: ModuleName SourceInfo
-  , visited :: [ModuleName ()]
-  , importPaths :: [FilePath]
-  }
-  deriving stock (Eq, Show)
-
-newtype FrontState = FrontState
-  { importedModules :: Map (ModuleName ()) (Module SourceInfo, Scope)
-  }
-  deriving stock (Eq, Show)
-
-type Symbol = TyRef ()
-type Scope = Map Symbol (ModuleName SourceInfo)
-
-data FrontendError
-  = ModuleNotFound (ModuleName SourceInfo) (Import SourceInfo) [FilePath]
-  | MultipleModulesFound (ModuleName SourceInfo) (Import SourceInfo) [FilePath]
-  | ImportCycleFound (ModuleName SourceInfo) (Import SourceInfo) [ModuleName ()]
-  | ModuleParseError FilePath ParseError
-  | ImportedNotFound (ModuleName SourceInfo) (ModuleName SourceInfo) (TyName SourceInfo) (Set (TyName SourceInfo))
-  | InvalidModuleFilepath (ModuleName SourceInfo) FilePath FilePath
-  | SymbolAlreadyImported (ModuleName SourceInfo) (Import SourceInfo) Symbol (ModuleName SourceInfo)
-  | TyRefNotFound (ModuleName SourceInfo) (TyRef SourceInfo) Scope
-  | DuplicateTyDef (ModuleName SourceInfo) (TyDef SourceInfo)
-  | TyDefNameConflict (ModuleName SourceInfo) (TyDef SourceInfo) (ModuleName SourceInfo)
-  deriving stock (Eq)
-
-newtype FrontendResult = FrontendResult
-  { processedModules :: Map (ModuleName ()) (Module SourceInfo, Scope)
-  }
-  deriving stock (Eq, Show)
-
-showOneLine :: Doc a -> String
-showOneLine d = (renderShowS . layoutPretty (defaultLayoutOptions {layoutPageWidth = Unbounded}) $ d) ""
-
-instance Show FrontendError where
-  show (ModuleNotFound _cm imp impPaths) = showOneLine $ pretty (importInfo imp) <+> "Module" <+> pretty (importModuleName imp) <+> "not found in available import paths" <+> pretty impPaths
-  show (MultipleModulesFound _cm imp conflictingPaths) = showOneLine $ pretty (importInfo imp) <+> "Module" <+> pretty (importModuleName imp) <+> "found in multiple files" <+> pretty conflictingPaths
-  show (ImportCycleFound _cm imp visited) = showOneLine $ pretty (importInfo imp) <+> "Tried to load module" <+> pretty (importModuleName imp) <+> "which constitutes a cycle" <+> pretty visited
-  show (ModuleParseError _fp err) = showOneLine $ pretty err
-  show (ImportedNotFound _cm mn tn@(TyName _ info) available) = showOneLine $ pretty info <+> "Type" <+> pretty tn <+> "not found in module" <+> pretty mn <> ", did you mean one of" <+> pretty (Set.toList available)
-  show (InvalidModuleFilepath mn@(ModuleName _ info) gotModFp wantedFpSuffix) = showOneLine $ pretty info <+> "File name" <+> pretty gotModFp <+> "doesn't match module name" <+> pretty mn <+> "expected" <+> pretty wantedFpSuffix
-  show (SymbolAlreadyImported _cm imp sym alreadyInModuleName) = showOneLine $ pretty (importInfo imp) <+> "Symbol" <+> pretty sym <+> "already imported from module" <+> pretty alreadyInModuleName
-  show (TyRefNotFound _cm tyR@(TyRef _ _ info) scope) = showOneLine $ pretty info <+> "Type " <> pretty tyR <+> "not found in the module's scope" <+> (pretty . Map.keys $ scope)
-  show (DuplicateTyDef _cm tyDef) = showOneLine $ pretty (tyDefInfo tyDef) <+> "Duplicate type definition with the name" <+> pretty (tyName tyDef)
-  show (TyDefNameConflict _cm tyDef imn) = showOneLine $ pretty (tyDefInfo tyDef) <+> "Type name" <+> pretty (tyName tyDef) <+> "conflicts with an imported type name from module" <+> pretty imn
-
-type FrontendT m a = MonadIO m => ReaderT FrontRead (StateT FrontState (ExceptT FrontendError m)) a
 
 -- | Run a Frontend compilation action on a "lbf" file, return the entire compilation closure or a frontend error.
 runFrontend :: MonadIO m => [FilePath] -> FilePath -> m (Either FrontendError FrontendResult)
@@ -82,29 +28,23 @@ runFrontend importPaths modFp = do
       ioM = runExceptT exM
   fmap (FrontendResult . importedModules . snd) <$> ioM
 
-throwE' :: FrontendError -> FrontendT m a
-throwE' = lift . lift . throwE
-
 moduleNameToFilepath :: ModuleName info -> FilePath
 moduleNameToFilepath (ModuleName parts _) = joinPath [unpack p | ModuleNamePart p _ <- parts] <.> "lbf"
 
 checkCycle :: Import SourceInfo -> FrontendT m ()
 checkCycle imp = do
   ms <- asks visited
   cm <- asks current
-  when ((strip . importModuleName $ imp) `elem` ms) $ throwE' $ ImportCycleFound cm imp ms
+  when ((strip . importModuleName $ imp) `elem` ms) $ throwE' $ Errors.ImportCycleFound cm imp ms
 
--- | Parse a LambdaBuffers modules with a specified filename (for reporting) and content.
+-- | `parseModule fp txt` parses a LambdaBuffers module with a specified filename `fp` (for reporting) and content in `txt`.
 parseModule :: FilePath -> Text -> FrontendT m (Module SourceInfo)
 parseModule modFp modContent = do
   modOrErr <- liftIO $ Parsec.runParser Parsec.parseModule modFp modContent
   case modOrErr of
-    Left err -> throwE' $ ModuleParseError modFp err
+    Left err -> throwE' $ Errors.ModuleParseError modFp err
     Right m -> return m
 
-strip :: Functor f => f a -> f ()
-strip = void
-
 importModule :: Import SourceInfo -> FrontendT m (Module SourceInfo)
 importModule imp = do
   let modName = importModuleName imp
@@ -116,16 +56,16 @@ importModule imp = do
       case found of
         [] -> do
           cm <- asks current
-          throwE' $ ModuleNotFound cm imp ips
+          throwE' $ Errors.ModuleNotFound cm imp ips
         [modFp] -> do
           modContent <- liftIO $ Text.readFile modFp
           modOrErr <- liftIO $ Parsec.runParser Parsec.parseModule modFp modContent
           case modOrErr of
-            Left err -> throwE' $ ModuleParseError modFp err
+            Left err -> throwE' $ Errors.ModuleParseError modFp err
             Right m -> return m
         modFps -> do
           cm <- asks current
-          throwE' $ MultipleModulesFound cm imp modFps
+          throwE' $ Errors.MultipleModulesFound cm imp modFps
     Just (m, _) -> return m
 
 processFile :: FilePath -> FrontendT m (Module SourceInfo)
@@ -147,101 +87,34 @@ processModule m = local
     importedScope <- processImports m
     localScope <- collectLocalScope m importedScope
     let modScope = localScope <> importedScope
-    checkReferences modScope m
+    checkReferences m modScope
     _ <- lift $ modify (FrontState . Map.insert (strip . moduleName $ m) (m, modScope) . importedModules)
     return m
 
-checkReferences :: Scope -> Module SourceInfo -> FrontendT m ()
-checkReferences scope m = for_ (moduleTyDefs m) (checkBody . tyBody)
-  where
-    checkBody (SumBody (Sum cs _)) = for_ cs checkConstructor
-    checkBody (ProductBody (Product fields _)) = for_ fields checkTy
-    checkBody (RecordBody (Record fields _)) = for_ fields (\(Field _ ty _) -> checkTy ty)
-    checkBody Opaque = return ()
-
-    checkConstructor (Constructor _ (Product tys _) _) = for tys checkTy
-
-    checkTy (TyApp tyF tyAs _) = checkTy tyF >> for_ tyAs checkTy
-    checkTy (TyVar _) = return ()
-    checkTy (TyRef' tyR _) =
-      if Map.member (strip tyR) scope
-        then return ()
-        else do
-          cm <- asks current
-          throwE' $ TyRefNotFound cm tyR scope
-
 checkModuleName :: FilePath -> ModuleName SourceInfo -> FrontendT m ()
 checkModuleName fp mn =
   let suffix = moduleNameToFilepath mn
    in if suffix `isSuffixOf` fp
         then return ()
-        else throwE' $ InvalidModuleFilepath mn fp suffix
-
-processImports :: Module SourceInfo -> FrontendT m Scope
-processImports m =
-  foldM
-    ( \totalScope imp -> do
-        scope <- processImport imp
-        foldM
-          ( \totalScope' sym -> case Map.lookup sym totalScope' of
-              Nothing -> return $ Map.insert sym (importModuleName imp) totalScope'
-              Just mn -> do
-                cm <- asks current
-                throwE' $ SymbolAlreadyImported cm imp sym mn
-          )
-          totalScope
-          scope
-    )
-    mempty
-    (moduleImports m)
-
-processImport :: Import SourceInfo -> FrontendT m (Set Symbol)
+        else throwE' $ Errors.InvalidModuleFilepath mn fp suffix
+
+processImports :: Module SourceInfo -> FrontendT m (TyScope, ClassScope)
+processImports m = do
+  (totalTyScope, totalClassScope) <-
+    foldM
+      ( \(totalTyScope', totalClassScope') imp ->
+          do
+            (tyScope, classScope) <- processImport imp
+            (,)
+              <$> addToTyScope totalTyScope' (imp, tyScope)
+              <*> addToClassScope totalClassScope' (imp, classScope)
+      )
+      mempty
+      (moduleImports m)
+  return (totalTyScope, totalClassScope)
+
+processImport :: Import SourceInfo -> FrontendT m (TyScope, ClassScope)
 processImport imp = do
   checkCycle imp
   im <- importModule imp >>= processModule
   collectImportedScope imp im
-
-collectImportedScope :: Import SourceInfo -> Module SourceInfo -> FrontendT m (Set Symbol)
-collectImportedScope (Import isQual modName mayImports mayAlias _) m =
-  let availableTyNs = [tyN | (TyDef tyN _ _ _) <- moduleTyDefs m]
-      availableTyNs' = Set.fromList availableTyNs
-      importedTyNs = fromMaybe availableTyNs mayImports
-      availableSTyNs = Set.fromList $ strip <$> availableTyNs
-   in foldM
-        ( \total tyN ->
-            let styN = strip tyN
-             in if Set.member styN availableSTyNs
-                  then return . Set.union total . Set.fromList $
-                    case mayAlias of
-                      Nothing ->
-                        if isQual
-                          then [TyRef (Just $ ModuleAlias (strip modName) ()) styN ()]
-                          else [TyRef (Just $ ModuleAlias (strip modName) ()) styN (), TyRef Nothing styN ()]
-                      Just al ->
-                        if isQual
-                          then [TyRef (Just . strip $ al) styN ()]
-                          else [TyRef (Just . strip $ al) styN (), TyRef Nothing styN ()]
-                  else do
-                    cm <- asks current
-                    throwE' $ ImportedNotFound cm modName tyN availableTyNs'
-        )
-        Set.empty
-        importedTyNs
-
-collectLocalScope :: Module SourceInfo -> Scope -> FrontendT m Scope
-collectLocalScope m importedScope =
-  foldM
-    ( \totalScope tyDef@(TyDef tn _ _ _) -> do
-        let tyR = TyRef Nothing (strip tn) ()
-        case Map.lookup tyR totalScope of
-          Nothing -> case Map.lookup tyR importedScope of
-            Nothing -> return $ Map.insert tyR (moduleName m) totalScope
-            Just im -> do
-              cm <- asks current
-              throwE' $ TyDefNameConflict cm tyDef im
-          Just _ -> do
-            cm <- asks current
-            throwE' $ DuplicateTyDef cm tyDef
-    )
-    mempty
-    (moduleTyDefs m)

lambda-buffers-frontend/src/LambdaBuffers/Frontend/CheckReferences.hs

@@ -0,0 +1,73 @@
+module LambdaBuffers.Frontend.CheckReferences (checkReferences) where
+
+import Control.Monad.Trans.Reader (asks)
+import Data.Foldable (for_)
+import Data.Map qualified as Map
+import LambdaBuffers.Frontend.Errors qualified as Errors
+import LambdaBuffers.Frontend.Monad (FrontRead (current), FrontendT, throwE')
+import LambdaBuffers.Frontend.PPrint ()
+import LambdaBuffers.Frontend.Syntax (ClassConstraint (ClassConstraint), ClassDef (classSupers), ClassRef (ClassRef), Constraint (Constraint), Constructor (Constructor), Derive (Derive), Field (Field), InstanceClause (instanceBody, instanceHead), Module (moduleStatements), Product (Product), Record (Record), SourceInfo, Statement (StClassDef, StDerive, StInstanceClause, StTyDef), Sum (Sum), Ty (TyApp, TyRef', TyVar), TyBody (Opaque, ProductBody, RecordBody, SumBody), TyDef (tyBody), TyRef (TyRef))
+import LambdaBuffers.Frontend.Utils (ClassScope, TyScope, strip)
+
+checkReferences :: Module SourceInfo -> (TyScope, ClassScope) -> FrontendT m ()
+checkReferences m scope@(tyScope, classScope) = do
+  for_
+    (moduleStatements m)
+    ( \case
+        StTyDef tds -> checkTyDef tyScope tds
+        StClassDef cds -> checkClassDef classScope cds
+        StInstanceClause ics -> checkInstanceClause scope ics
+        StDerive drv -> checkDerive scope drv
+    )
+
+checkTyDef :: TyScope -> TyDef SourceInfo -> FrontendT m ()
+checkTyDef tyScope = checkBody . tyBody
+  where
+    checkBody :: TyBody SourceInfo -> FrontendT m ()
+    checkBody (SumBody (Sum cs _)) = for_ cs checkConstructor
+    checkBody (ProductBody (Product fields _)) = for_ fields (checkTy tyScope)
+    checkBody (RecordBody (Record fields _)) = for_ fields (\(Field _ ty _) -> checkTy tyScope ty)
+    checkBody Opaque = return ()
+
+    checkConstructor :: Constructor SourceInfo -> FrontendT m ()
+    checkConstructor (Constructor _ (Product tys _) _) = for_ tys (checkTy tyScope)
+
+checkClassDef :: ClassScope -> ClassDef SourceInfo -> FrontendT m ()
+checkClassDef classScope = checkSups . classSupers
+  where
+    checkSups :: [ClassConstraint SourceInfo] -> FrontendT m ()
+    checkSups sups = for_ sups checkClassConstraint
+
+    checkClassConstraint :: ClassConstraint SourceInfo -> FrontendT m ()
+    checkClassConstraint (ClassConstraint cr _) = checkClassRef classScope cr
+
+checkClassRef :: ClassScope -> ClassRef SourceInfo -> FrontendT m ()
+checkClassRef classScope cr@(ClassRef mayAlias clN _) =
+  if Map.member (strip <$> mayAlias, strip clN) classScope
+    then return ()
+    else do
+      cm <- asks current
+      throwE' $ Errors.classRefNotFoundErr cm cr classScope
+
+checkInstanceClause :: (TyScope, ClassScope) -> InstanceClause SourceInfo -> FrontendT m ()
+checkInstanceClause scope inst = do
+  checkConstraint scope (instanceHead inst)
+  for_ (instanceBody inst) (checkConstraint scope)
+
+checkDerive :: (TyScope, ClassScope) -> Derive SourceInfo -> FrontendT m ()
+checkDerive scope (Derive cstr) = checkConstraint scope cstr
+
+checkConstraint :: (TyScope, ClassScope) -> Constraint SourceInfo -> FrontendT m ()
+checkConstraint (tyScope, classScope) (Constraint cr tys _) = do
+  checkClassRef classScope cr
+  for_ tys (checkTy tyScope)
+
+checkTy :: TyScope -> Ty SourceInfo -> FrontendT m ()
+checkTy tyScope (TyApp tyF tyAs _) = checkTy tyScope tyF >> for_ tyAs (checkTy tyScope)
+checkTy _tyScope (TyVar _) = return ()
+checkTy tyScope (TyRef' tr@(TyRef mayAlias tyN _) _) =
+  if Map.member (strip <$> mayAlias, strip tyN) tyScope
+    then return ()
+    else do
+      cm <- asks current
+      throwE' $ Errors.tyRefNotFoundErr cm tr tyScope