Apply InfoLess in the Compiler

Author: bladyjoker

lambda-buffers-compiler/lambda-buffers-compiler.cabal

@@ -101,6 +101,7 @@ library
     , generics-sop                >=0.5
     , lambda-buffers-compiler-pb  >=0.1.0.0
     , mtl                         >=2.2
+    , ordered-containers
     , parsec                      >=3.1
     , prettyprinter               >=1.7
     , proto-lens                  >=0.7

lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Inference.hs

@@ -141,12 +141,12 @@ derive x = deriveTyAbs x
     deriveTyAbs tyabs = do
       case M.toList (tyabs ^. #tyArgs) of
         [] -> deriveTyBody (x ^. #tyBody)
-        a@(n, ar) : as -> do
+        a@(_, ar) : as -> do
           let argK = protoKind2Kind (ar ^. #argKind)
           bodyK <- KVar <$> fresh
           ctx <- ask
 
-          let newContext = ctx & addContext %~ (<> M.singleton (mkInfoLess (TyVar n)) argK)
+          let newContext = ctx & addContext %~ (<> M.singleton (mkInfoLess (TyVar (ar ^. #argName))) argK)
           let newAbs = tyabs & #tyArgs .~ uncurry M.singleton a
           let restAbs = tyabs & #tyArgs .~ M.fromList as
 

lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/FromProto.hs

@@ -7,17 +7,16 @@ import Control.Lens ((&), (.~), (^.))
 import Control.Monad.Except (Except, MonadError (throwError), runExcept)
 import Control.Monad.Reader (MonadReader (ask, local), ReaderT (runReaderT))
 import Data.Foldable (foldlM, toList)
-import Data.Generics.Product (HasField)
 import Data.Kind (Type)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.ProtoLens (Message (messageName), MessageEnum (showEnum), defMessage)
 import Data.Proxy (Proxy (Proxy))
-import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
 import GHC.Generics (Generic)
 import LambdaBuffers.Compiler.NamingCheck (checkClassName, checkConstrName, checkFieldName, checkModuleNamePart, checkTyName, checkVarName)
+import LambdaBuffers.Compiler.ProtoCompat.InfoLess (mkInfoLess)
 import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC
 import Proto.Compiler (NamingError)
 import Proto.Compiler qualified as P
@@ -87,12 +86,6 @@ parseAndIndex key =
     )
     (mempty, mempty)
 
--- WARN(bladyjoker): This function is used to 'strip' the SourceInfo from types that end up as Map keys.
---   This can cause confusion and errors and we should rather parametrize types with `info` and
---   maintain `Map (TyName ()) (TyDef SourceInfo)`
-stripSourceInfo :: HasField "sourceInfo" s t a PC.SourceInfo => s -> t
-stripSourceInfo x = x & #sourceInfo .~ PC.defSourceInfo
-
 {-
     SourceInfo
 -}
@@ -299,7 +292,7 @@ instance IsMessage P.TyDef PC.TyDef where
 
 instance IsMessage P.TyAbs PC.TyAbs where
   fromProto ta = do
-    (tyargs, mulTyArgs) <- parseAndIndex (\a -> stripSourceInfo $ a ^. #argName) (ta ^. P.tyArgs)
+    (tyargs, mulTyArgs) <- parseAndIndex (\a -> mkInfoLess $ a ^. #argName) (ta ^. P.tyArgs)
     tybody <- fromProto $ ta ^. P.tyBody
     si <- fromProto $ ta ^. P.sourceInfo
     ctx <- ask
@@ -388,7 +381,7 @@ instance IsMessage P.TyBody PC.TyBody where
 
 instance IsMessage P.Sum PC.Sum where
   fromProto s = do
-    (ctors, mulCtors) <- parseAndIndex (\c -> stripSourceInfo $ c ^. #constrName) (s ^. P.constructors)
+    (ctors, mulCtors) <- parseAndIndex (\c -> mkInfoLess $ c ^. #constrName) (s ^. P.constructors)
     si <- fromProto $ s ^. P.sourceInfo
     ctx <- ask
     (ctxMn, ctxTyd) <- case ctx of
@@ -424,7 +417,7 @@ instance IsMessage P.Sum'Constructor PC.Constructor where
 
 instance IsMessage P.Product'Record PC.Record where
   fromProto r = do
-    (fields, mulFields) <- parseAndIndex (\f -> stripSourceInfo $ f ^. #fieldName) (r ^. P.fields)
+    (fields, mulFields) <- parseAndIndex (\f -> mkInfoLess $ f ^. #fieldName) (r ^. P.fields)
     si <- fromProto $ r ^. P.sourceInfo
     ctx <- ask
     (ctxMn, ctxTyd) <- case ctx of
@@ -598,9 +591,9 @@ instance IsMessage P.Module PC.Module where
       _ -> throwInternalError "Expected to be in CompilerInput Context"
     local (const $ CtxModule (m ^. P.moduleName)) $ do
       mnm <- fromProto $ m ^. P.moduleName
-      (tydefs, mulTyDefs) <- parseAndIndex (\tyDef -> stripSourceInfo $ tyDef ^. #tyName) (m ^. P.typeDefs)
-      (cldefs, mulClDefs) <- parseAndIndex (\cldef -> stripSourceInfo $ cldef ^. #className) (m ^. P.classDefs)
-      (impts, mulImpts) <- parseAndIndex stripSourceInfo (m ^. P.imports)
+      (tydefs, mulTyDefs) <- parseAndIndex (\tyDef -> mkInfoLess $ tyDef ^. #tyName) (m ^. P.typeDefs)
+      (cldefs, mulClDefs) <- parseAndIndex (\cldef -> mkInfoLess $ cldef ^. #className) (m ^. P.classDefs)
+      (impts, mulImpts) <- parseAndIndex mkInfoLess (m ^. P.imports)
       insts <- traverse fromProto $ m ^. P.instances
       si <- fromProto $ m ^. P.sourceInfo
       let mulTyDefsErrs =
@@ -626,7 +619,7 @@ instance IsMessage P.Module PC.Module where
             ]
           protoParseErrs = mulTyDefsErrs ++ mulClassDefsErrs ++ mulImptsErrs
       if null protoParseErrs
-        then pure $ PC.Module mnm tydefs cldefs insts (Map.keysSet impts) si
+        then pure $ PC.Module mnm tydefs cldefs insts impts si
         else throwError protoParseErrs
 
   toProto (PC.Module mnm tdefs cdefs insts impts si) =
@@ -635,13 +628,13 @@ instance IsMessage P.Module PC.Module where
       & P.typeDefs .~ (toProto <$> toList tdefs)
       & P.classDefs .~ (toProto <$> toList cdefs)
       & P.instances .~ (toProto <$> insts)
-      & P.imports .~ (toProto <$> Set.toList impts)
+      & P.imports .~ (toProto <$> toList impts)
       & P.sourceInfo .~ toProto si
 
 instance IsMessage P.CompilerInput PC.CompilerInput where
   fromProto ci = do
     local (const CtxCompilerInput) $ do
-      (mods, mulModules) <- parseAndIndex (\m -> stripSourceInfo $ m ^. #moduleName) (ci ^. P.modules)
+      (mods, mulModules) <- parseAndIndex (\m -> mkInfoLess $ m ^. #moduleName) (ci ^. P.modules)
       let mulModulesErrs =
             [ FPProtoParseError $
               defMessage & P.multipleModuleError . P.modules .~ ms

lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/InfoLess.hs

@@ -7,65 +7,21 @@ module LambdaBuffers.Compiler.ProtoCompat.InfoLess (
   withInfoLess,
   withInfoLessF,
   mkInfoLess,
-  InfoLessC,
+  InfoLessC (infoLessId),
 ) where
 
 import Data.Bifunctor (Bifunctor (bimap))
-import Data.Default (Default (def))
 import Data.Map qualified as M
 import Data.Set qualified as S
 import Data.Text (Text)
 import Generics.SOP (All2, Generic (Code, from, to), Proxy (Proxy), hcmap, mapII)
-import LambdaBuffers.Compiler.ProtoCompat.Types (
-  ClassDef,
-  ClassName,
-  CompilerError,
-  CompilerInput,
-  CompilerResult,
-  ConstrName,
-  Constraint,
-  Constructor,
-  Field,
-  FieldName,
-  ForeignClassRef,
-  ForeignRef,
-  InferenceErr,
-  InstanceClause,
-  Kind,
-  KindCheckErr,
-  KindCheckError,
-  KindRefType,
-  KindType,
-  LBName,
-  LocalClassRef,
-  LocalRef,
-  Module,
-  ModuleName,
-  ModuleNamePart,
-  Product,
-  Record,
-  SourceInfo,
-  SourcePosition,
-  Sum,
-  Tuple,
-  Ty,
-  TyAbs,
-  TyApp,
-  TyArg,
-  TyBody,
-  TyClassRef,
-  TyDef,
-  TyName,
-  TyRef,
-  TyVar,
-  VarName,
-  defSourceInfo,
- )
+import Test.QuickCheck (Arbitrary)
 
 -- | InfoLess newtype. Constructor is not exported to not allow the construction of types with the Info. InfoLess a can only be constructed via its class instance and deconstructed using the exported function.
 newtype InfoLess a = InfoLess {unsafeInfoLess :: a}
   deriving stock (Show, Eq, Ord)
   deriving stock (Functor, Traversable, Foldable)
+  deriving newtype (Arbitrary, InfoLessC)
 
 {- | SourceInfo Less ID.
  A TypeClass that provides id for types with SourceInfo - where SI is defaulted - therefore ignored. Can only be derived.
@@ -104,51 +60,3 @@ instance (Ord k, InfoLessC k, InfoLessC v) => InfoLessC (M.Map k v) where
 
 instance (Ord a, InfoLessC a) => InfoLessC (S.Set a) where
   infoLessId = S.fromList . fmap infoLessId . S.toList
-
-instance InfoLessC SourceInfo where
-  infoLessId = const def
-
-instance Default SourceInfo where
-  def = defSourceInfo
-
-instance InfoLessC SourcePosition
-instance InfoLessC LBName
-instance InfoLessC TyName
-instance InfoLessC ConstrName
-instance InfoLessC ModuleName
-instance InfoLessC ModuleNamePart
-instance InfoLessC VarName
-instance InfoLessC FieldName
-instance InfoLessC ClassName
-instance InfoLessC Kind
-instance InfoLessC KindType
-instance InfoLessC KindRefType
-instance InfoLessC TyVar
-instance InfoLessC Ty
-instance InfoLessC TyApp
-instance InfoLessC ForeignRef
-instance InfoLessC LocalRef
-instance InfoLessC TyRef
-instance InfoLessC TyDef
-instance InfoLessC TyAbs
-instance InfoLessC TyArg
-instance InfoLessC TyBody
-instance InfoLessC Constructor
-instance InfoLessC Sum
-instance InfoLessC Field
-instance InfoLessC Record
-instance InfoLessC Tuple
-instance InfoLessC Product
-instance InfoLessC ForeignClassRef
-instance InfoLessC LocalClassRef
-instance InfoLessC TyClassRef
-instance InfoLessC ClassDef
-instance InfoLessC InstanceClause
-instance InfoLessC Constraint
-instance InfoLessC Module
-instance InfoLessC InferenceErr
-instance InfoLessC KindCheckErr
-instance InfoLessC CompilerInput
-instance InfoLessC KindCheckError
-instance InfoLessC CompilerError
-instance InfoLessC CompilerResult

lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/Types.hs

@@ -48,19 +48,19 @@ module LambdaBuffers.Compiler.ProtoCompat.Types (
   TyRef (..),
   TyVar (..),
   VarName (..),
-  defSourceInfo,
   InferenceErr,
   KindCheckErr,
 ) where
 
 import Control.Exception (Exception)
 import Control.Lens (Getter, to, (^.))
+import Data.Default (Default (def))
 import Data.Generics.Labels ()
 import Data.Map (Map)
-import Data.Set (Set)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Generics.SOP qualified as SOP
+import LambdaBuffers.Compiler.ProtoCompat.InfoLess (InfoLess, InfoLessC (infoLessId))
 import Test.QuickCheck (Gen, oneof, resize, sized)
 import Test.QuickCheck.Arbitrary.Generic (Arbitrary (arbitrary), GenericArbitrary (GenericArbitrary))
 import Test.QuickCheck.Instances.Semigroup ()
@@ -76,8 +76,8 @@ data SourcePosition = SourcePosition {column :: Int, row :: Int}
   deriving (Arbitrary) via GenericArbitrary SourcePosition
   deriving anyclass (SOP.Generic)
 
-defSourceInfo :: SourceInfo
-defSourceInfo = SourceInfo "" (SourcePosition 0 0) (SourcePosition 0 0)
+instance Default SourceInfo where
+  def = SourceInfo "" (SourcePosition 0 0) (SourcePosition 0 0)
 
 {- | NOTE(gnumonik): I need a "generic name" type for my template haskell, this
  shouldn't be used anywhere outside of that
@@ -202,7 +202,7 @@ data TyDef = TyDef {tyName :: TyName, tyAbs :: TyAbs, sourceInfo :: SourceInfo}
   deriving (Arbitrary) via GenericArbitrary TyDef
   deriving anyclass (SOP.Generic)
 
-data TyAbs = TyAbs {tyArgs :: Map VarName TyArg, tyBody :: TyBody, sourceInfo :: SourceInfo}
+data TyAbs = TyAbs {tyArgs :: Map (InfoLess VarName) TyArg, tyBody :: TyBody, sourceInfo :: SourceInfo}
   deriving stock (Show, Eq, Ord, Generic)
   deriving (Arbitrary) via GenericArbitrary TyAbs
   deriving anyclass (SOP.Generic)
@@ -222,7 +222,7 @@ data Constructor = Constructor {constrName :: ConstrName, product :: Product}
   deriving (Arbitrary) via GenericArbitrary Constructor
   deriving anyclass (SOP.Generic)
 
-data Sum = Sum {constructors :: Map ConstrName Constructor, sourceInfo :: SourceInfo}
+data Sum = Sum {constructors :: Map (InfoLess ConstrName) Constructor, sourceInfo :: SourceInfo}
   deriving stock (Show, Eq, Ord, Generic)
   deriving (Arbitrary) via GenericArbitrary Sum
   deriving anyclass (SOP.Generic)
@@ -232,7 +232,7 @@ data Field = Field {fieldName :: FieldName, fieldTy :: Ty}
   deriving (Arbitrary) via GenericArbitrary Field
   deriving anyclass (SOP.Generic)
 
-data Record = Record {fields :: Map FieldName Field, sourceInfo :: SourceInfo}
+data Record = Record {fields :: Map (InfoLess FieldName) Field, sourceInfo :: SourceInfo}
   deriving stock (Show, Eq, Ord, Generic)
   deriving (Arbitrary) via GenericArbitrary Record
   deriving anyclass (SOP.Generic)
@@ -309,10 +309,10 @@ data Constraint = Constraint
 
 data Module = Module
   { moduleName :: ModuleName
-  , typeDefs :: Map TyName TyDef
-  , classDefs :: Map ClassName ClassDef
+  , typeDefs :: Map (InfoLess TyName) TyDef
+  , classDefs :: Map (InfoLess ClassName) ClassDef
   , instances :: [InstanceClause]
-  , imports :: Set ModuleName
+  , imports :: Map (InfoLess ModuleName) ModuleName
   , sourceInfo :: SourceInfo
   }
   deriving stock (Show, Eq, Ord, Generic)
@@ -350,7 +350,7 @@ data KindCheckErr
 
 instance Exception KindCheckErr
 
-newtype CompilerInput = CompilerInput {modules :: Map ModuleName Module}
+newtype CompilerInput = CompilerInput {modules :: Map (InfoLess ModuleName) Module}
   deriving stock (Show, Eq, Ord, Generic)
   deriving newtype (Monoid, Semigroup)
   deriving anyclass (SOP.Generic)
@@ -385,3 +385,49 @@ data CompilerResult = CompilerResult
   deriving anyclass (SOP.Generic)
 
 type CompilerOutput = Either CompilerError CompilerResult
+
+-- | InfoLess instances
+instance InfoLessC SourceInfo where
+  infoLessId = const def
+
+instance InfoLessC SourcePosition
+instance InfoLessC LBName
+instance InfoLessC TyName
+instance InfoLessC ConstrName
+instance InfoLessC ModuleName
+instance InfoLessC ModuleNamePart
+instance InfoLessC VarName
+instance InfoLessC FieldName
+instance InfoLessC ClassName
+instance InfoLessC Kind
+instance InfoLessC KindType
+instance InfoLessC KindRefType
+instance InfoLessC TyVar
+instance InfoLessC Ty
+instance InfoLessC TyApp
+instance InfoLessC ForeignRef
+instance InfoLessC LocalRef
+instance InfoLessC TyRef
+instance InfoLessC TyDef
+instance InfoLessC TyAbs
+instance InfoLessC TyArg
+instance InfoLessC TyBody
+instance InfoLessC Constructor
+instance InfoLessC Sum
+instance InfoLessC Field
+instance InfoLessC Record
+instance InfoLessC Tuple
+instance InfoLessC Product
+instance InfoLessC ForeignClassRef
+instance InfoLessC LocalClassRef
+instance InfoLessC TyClassRef
+instance InfoLessC ClassDef
+instance InfoLessC InstanceClause
+instance InfoLessC Constraint
+instance InfoLessC Module
+instance InfoLessC InferenceErr
+instance InfoLessC KindCheckErr
+instance InfoLessC CompilerInput
+instance InfoLessC KindCheckError
+instance InfoLessC CompilerError
+instance InfoLessC CompilerResult