zeolite-lang 0.13.0.0 → 0.14.0.0

raw patch · 32 files changed

+918/−166 lines, 32 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +17/−0
• base/builtin.0rp +2/−3
• example/parser/README.md +7/−0
• example/parser/parse-text.0rx +5/−5
• example/parser/parser.0rp +1/−1
• example/parser/parser.0rx +2/−2
• example/tree/tree.0rp +8/−8
• example/tree/tree.0rx +2/−2
• lib/util/util.0rp +6/−6
• src/Compilation/CompilerState.hs +14/−0
• src/Compilation/ProcedureContext.hs +67/−53
• src/Compilation/ScopeContext.hs +18/−11
• src/CompilerCxx/CxxFiles.hs +6/−5
• src/CompilerCxx/Naming.hs +1/−1
• src/CompilerCxx/Procedure.hs +56/−27
• src/Parser/Common.hs +11/−0
• src/Parser/Procedure.hs +1/−1
• src/Parser/TypeCategory.hs +3/−0
• src/Parser/TypeInstance.hs +10/−6
• src/Test/TypeCategory.hs +22/−0
• src/Test/TypeInstance.hs +8/−0
• src/Test/testfiles/bad_merge_self.0rx +8/−0
• src/Test/testfiles/contravariant_self.0rx +3/−0
• src/Test/testfiles/filtered_self.0rx +14/−0
• src/Test/testfiles/invariant_self.0rx +6/−0
• src/Test/testfiles/valid_self.0rx +16/−0
• src/Types/DefinedCategory.hs +7/−0
• src/Types/Procedure.hs +1/−1
• src/Types/TypeCategory.hs +60/−20
• src/Types/TypeInstance.hs +57/−13
• tests/self-type.0rt +478/−0
• zeolite-lang.cabal +1/−1

@@ -1,5 +1,22 @@ # Revision history for zeolite-lang +## 0.14.0.0  -- 2021-03-19++### Language++* **[breaking]** Adds the `#self` meta-type. This is an implicit type param that+  is dynamically replaced with the type of the object a function is called on.+  For example, if a `@value interface` function has a return type of `#self`+  then any implementation must return an object of *its own type* from that+  function. (This is a breaking change because it reserves the param name+  `#self`.)++### Libraries++* **[breaking]** Removes the type parameters from `IterateForward` and+  `IterateReverse` in `lib/util`. This was made possible by the addition of the+  `#self` meta-type.+ ## 0.13.0.0  -- 2021-03-17  ### Language

@@ -65,7 +65,6 @@   defines Equals<String>   defines LessThan<String> -  @value subSequence (Int,Int) -> (String)   @type builder () -> (Builder<String>) } @@ -92,11 +91,11 @@ @value interface ReadPosition<|#x> {   readPosition (Int) -> (#x)   readSize () -> (Int)-  subSequence (Int,Int) -> (ReadPosition<#x>)+  subSequence (Int,Int) -> (#self) }  @value interface Builder<#x> {-  append (#x) -> (Builder<#x>)+  append (#x) -> (#self)   build () -> (#x) } 

@@ -57,6 +57,13 @@   This is useful when the parameter value can be easily guessed by the reader of   the code from its context. +- **The `#self` Param.** Using `#self` as a return type in an `interface` allows+  it to require that an implementation returns *its own type*, rather than+  *the type of the `interface`*. `ParseContext.advance` uses this to allow+  callers of `advance` to get an instance of the derived type rather than an+  instance of `ParseContext`. This is useful because `ParseContext` lacks other+  functions that the derived type defines.+ ## Running  (Included with compiler package starting with version `0.6.0.0`.)

@@ -123,7 +123,7 @@   }    create (value) {-    return ConstParser<#x>{ value }+    return #self{ value }   } } @@ -167,7 +167,7 @@   }    create (parser) {-    return TryParser<#x>{ parser }+    return #self{ parser }   } } @@ -194,7 +194,7 @@   }    create (parser1,parser2) {-    return OrParser<#x>{ parser1, parser2 }+    return #self{ parser1, parser2 }   } } @@ -226,7 +226,7 @@   }    create (parser1,parser2) {-    return LeftParser<#x>{ parser1, parser2 }+    return #self{ parser1, parser2 }   } } @@ -253,7 +253,7 @@   }    create (parser1,parser2) {-    return RightParser<#x>{ parser1, parser2 }+    return #self{ parser1, parser2 }   } } 

@@ -44,5 +44,5 @@    // Reading data.   current () -> (Char)-  advance () -> (ParseContext<#x>)+  advance () -> (#self) }

@@ -86,9 +86,9 @@   advance () {     \ sanityCheck()     if (data.readPosition(index) == '\n') {-      return ParseState<#x>{ data, index+1, line+1, 1, value, error }+      return #self{ data, index+1, line+1, 1, value, error }     } else {-      return ParseState<#x>{ data, index+1, line, char+1, value, error }+      return #self{ data, index+1, line, char+1, value, error }     }   } 

@@ -1,8 +1,12 @@ /* An interface for updating a key-value index.  */ @value interface KVWriter<#k,#v|> {-  set (#k,#v) -> (KVWriter<#k,#v>)-  remove (#k) -> (KVWriter<#k,#v>)+  // #self below always means the type of value that the function is being+  // called from. For example, the type of foo.remove(key) is the same type as+  // foo is.++  set (#k,#v) -> (#self)+  remove (#k) -> (#self) }  /* An interface for looking up values from a key-value index.@@ -21,10 +25,6 @@   // Creates a new Tree, e.g., Tree.new().   @type new () -> (Tree<#k,#v>) -  // Normally you do not need to redeclare functions inherited from interfaces.-  // The two redeclarations below are used to refine the return type from-  // KVWriter to Tree.--  @value set (#k,#v) -> (Tree<#k,#v>)-  @value remove (#k) -> (Tree<#k,#v>)+  // Since set and remove return #self, their implementations in Tree must+  // return Tree<#k,#v>. }

@@ -2,7 +2,7 @@   @value optional Node<#k,#v> root    new () {-    return Tree<#k,#v>{ empty }+    return #self{ empty }   }    set (k,v) {@@ -49,7 +49,7 @@    insert (node,k,v) {     if (!present(node)) {-      return Node<#k,#v>{ 1, k, v, empty, empty }+      return #self{ 1, k, v, empty, empty }     }     Node<#k,#v> node2 <- require(node)     if (k `#k.lessThan` node2.getKey()) {

@@ -31,20 +31,20 @@   readCurrent () -> (#x) } -@value interface IterateForward<|#x> {-  forward () -> (#x)+@value interface IterateForward {+  forward () -> (#self)   pastForwardEnd () -> (Bool) } -@value interface IterateReverse<|#x> {-  reverse () -> (#x)+@value interface IterateReverse {+  reverse () -> (#self)   pastReverseEnd () -> (Bool) }  concrete ReadIterator<|#x> {   refines ReadCurrent<#x>-  refines IterateForward<ReadIterator<#x>>-  refines IterateReverse<ReadIterator<#x>>+  refines IterateForward+  refines IterateReverse    @category fromReadPosition<#y> (ReadPosition<#y>) -> (ReadIterator<#y>)   @category fromReadPositionAt<#y> (ReadPosition<#y>,Int) -> (ReadIterator<#y>)

@@ -33,6 +33,7 @@   MemberValue(..),   ReturnVariable(..),   UsedVariable(..),+  autoSelfType,   concatM,   csAddRequired,   csAddUsed,@@ -62,6 +63,7 @@   csReserveExprMacro,   csResolver,   csSameType,+  csSelfType,   csSetHidden,   csSetJumpType,   csSetNoTrace,@@ -87,6 +89,7 @@ #endif  import Base.CompilerError+import Base.GeneralType import Base.Positional import Types.DefinedCategory import Types.Procedure@@ -100,6 +103,7 @@   ccCurrentScope :: a -> m SymbolScope   ccResolver :: a -> m AnyTypeResolver   ccSameType :: a -> TypeInstance -> m Bool+  ccSelfType :: a -> m TypeInstance   ccAllFilters :: a -> m ParamFilters   ccGetParamScope :: a -> ParamName -> m SymbolScope   ccAddRequired :: a -> Set.Set CategoryName -> m a@@ -196,6 +200,9 @@ csSameType :: CompilerContext c m s a => TypeInstance -> CompilerState a m Bool csSameType t = fmap (\x -> ccSameType x t) get >>= lift +csSelfType :: CompilerContext c m s a => CompilerState a m TypeInstance+csSelfType = fmap ccSelfType get >>= lift+ csAllFilters :: CompilerContext c m s a => CompilerState a m ParamFilters csAllFilters = fmap ccAllFilters get >>= lift @@ -337,3 +344,10 @@  getCleanContext :: CompilerContext c m s a => CompilerState a m a getCleanContext = get >>= lift . ccClearOutput++autoSelfType :: CompilerContext c m s a => CompilerState a m GeneralInstance+autoSelfType = do+  scope <- csCurrentScope+  case scope of+       CategoryScope -> return selfType+       _ -> fmap (singleType . JustTypeInstance) csSelfType

@@ -96,13 +96,18 @@   CompilerContext c m [String] (ProcedureContext c) where   ccCurrentScope = return . (^. pcScope)   ccResolver = return . AnyTypeResolver . CategoryResolver . (^. pcCategories)-  ccSameType ctx = return . (== same) where-    same = TypeInstance (ctx ^. pcType) (fmap (singleType . JustParamName False . vpParam) $ ctx ^. pcExtParams)+  ccSameType ctx t+    | ctx ^. pcScope == CategoryScope = return False+    | otherwise = ccSelfType ctx >>= return . (== t)+  ccSelfType ctx+    | ctx ^. pcScope == CategoryScope = compilerErrorM $ "Param " ++ show ParamSelf ++ " not found"+    | otherwise = return $ TypeInstance (ctx ^. pcType)+                                        (fmap (singleType . JustParamName False . vpParam) $ ctx ^. pcExtParams)   ccAllFilters = return . (^. pcAllFilters)   ccGetParamScope ctx p = do     case p `Map.lookup` (ctx ^. pcParamScopes) of             (Just s) -> return s-            _ -> compilerErrorM $ "Param " ++ show p ++ " does not exist"+            _ -> compilerErrorM $ "Param " ++ show p ++ " not found"   ccAddRequired ctx ts = return $ ctx & pcRequiredTypes <>~ ts   ccGetRequired = return . (^. pcRequiredTypes)   ccGetCategoryFunction ctx c Nothing n = ccGetCategoryFunction ctx c (Just $ ctx ^. pcType) n@@ -124,58 +129,67 @@       return f     checkFunction _ =       compilerErrorM $ "Category " ++ show t ++-                     " does not have a category function named " ++ show n ++-                     formatFullContextBrace c-  ccGetTypeFunction ctx c t n = getFunction t where-    getFunction (Just t2) = reduceMergeTree getFromAny getFromAll getFromSingle t2-    getFunction Nothing = do-      let ps = fmap (singleType . JustParamName False . vpParam) $ ctx ^. pcExtParams-      getFunction (Just $ singleType $ JustTypeInstance $ TypeInstance (ctx ^. pcType) ps)-    getFromAny _ =-      compilerErrorM $ "Use explicit type conversion to call " ++ show n ++ " from " ++ show t-    getFromAll ts = do-      collectFirstM ts <!!-        "Function " ++ show n ++ " not available for type " ++ show t ++ formatFullContextBrace c-    getFromSingle (JustParamName _ p) = do-      fa <- ccAllFilters ctx-      fs <- case p `Map.lookup` fa of-                (Just fs) -> return fs-                _ -> compilerErrorM $ "Param " ++ show p ++ " does not exist"-      let ts = map tfType $ filter isRequiresFilter fs-      let ds = map dfType $ filter isDefinesFilter  fs-      collectFirstM (map (getFunction . Just) ts ++ map checkDefine ds) <!!-        "Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c-    getFromSingle (JustTypeInstance t2)-      -- Same category as the procedure itself.-      | tiName t2 == ctx ^. pcType =-        subAndCheckFunction (tiName t2) (fmap vpParam $ ctx ^. pcExtParams) (tiParams t2) $ n `Map.lookup` (ctx ^. pcFunctions)-      -- A different category than the procedure.-      | otherwise = do-        (_,ca) <- getCategory (ctx ^. pcCategories) (c,tiName t2)+                       " does not have a category function named " ++ show n +++                       formatFullContextBrace c+  ccGetTypeFunction ctx c t n = do+    t' <- case ctx ^. pcScope of+               CategoryScope -> case t of+                                     Nothing -> compilerErrorM $ "Category " ++ show t +++                                                                  " does not have a category function named " ++ show n +++                                                                  formatFullContextBrace c+                                     Just t0 -> return t0+               _ -> do+                 self <- fmap (singleType . JustTypeInstance) $ ccSelfType ctx+                 case t of+                      Just t0 -> replaceSelfInstance self t0+                      Nothing -> return self+    getFunction t' t' where+      getFunction t0 t2 = reduceMergeTree getFromAny getFromAll (getFromSingle t0) t2+      getFromAny _ =+        compilerErrorM $ "Use explicit type conversion to call " ++ show n ++ " from " ++ show t+      getFromAll ts = do+        collectFirstM ts <!!+          "Function " ++ show n ++ " not available for type " ++ show t ++ formatFullContextBrace c+      getFromSingle t0 (JustParamName _ p) = do+        fa <- ccAllFilters ctx+        fs <- case p `Map.lookup` fa of+                   (Just fs) -> return fs+                   _ -> compilerErrorM $ "Param " ++ show p ++ " not found"+        let ts = map tfType $ filter isRequiresFilter fs+        let ds = map dfType $ filter isDefinesFilter  fs+        collectFirstM (map (getFunction t0) ts ++ map (checkDefine t0) ds) <!!+          "Function " ++ show n ++ " not available for param " ++ show p ++ formatFullContextBrace c+      getFromSingle t0 (JustTypeInstance t2)+        -- Same category as the procedure itself.+        | tiName t2 == ctx ^. pcType =+          subAndCheckFunction t0 (tiName t2) (fmap vpParam $ ctx ^. pcExtParams) (tiParams t2) $ n `Map.lookup` (ctx ^. pcFunctions)+        -- A different category than the procedure.+        | otherwise = do+          (_,ca) <- getCategory (ctx ^. pcCategories) (c,tiName t2)+          let params = Positional $ map vpParam $ getCategoryParams ca+          let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca+          subAndCheckFunction t0 (tiName t2) params (tiParams t2) $ n `Map.lookup` fa+      getFromSingle _ _ = compilerErrorM $ "Type " ++ show t ++ " contains unresolved types"+      checkDefine t0 t2 = do+        (_,ca) <- getCategory (ctx ^. pcCategories) (c,diName t2)         let params = Positional $ map vpParam $ getCategoryParams ca         let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca-        subAndCheckFunction (tiName t2) params (tiParams t2) $ n `Map.lookup` fa-    getFromSingle _ = compilerErrorM $ "Type " ++ show t ++ " contains unresolved types"-    checkDefine t2 = do-      (_,ca) <- getCategory (ctx ^. pcCategories) (c,diName t2)-      let params = Positional $ map vpParam $ getCategoryParams ca-      let fa = Map.fromList $ map (\f -> (sfName f,f)) $ getCategoryFunctions ca-      subAndCheckFunction (diName t2) params (diParams t2) $ n `Map.lookup` fa-    subAndCheckFunction t2 ps1 ps2 (Just f) = do-      when (ctx ^. pcDisallowInit && t2 == ctx ^. pcType) $-        compilerErrorM $ "Function " ++ show n ++-                       " disallowed during initialization" ++ formatFullContextBrace c-      when (sfScope f == CategoryScope) $-        compilerErrorM $ "Function " ++ show n ++ " in " ++ show t2 ++-                       " is a category function" ++ formatFullContextBrace c-      paired <- processPairs alwaysPair ps1 ps2 <??-        "In external function call at " ++ formatFullContext c-      let assigned = Map.fromList paired-      uncheckedSubFunction assigned f-    subAndCheckFunction t2 _ _ _ =-      compilerErrorM $ "Category " ++ show t2 ++-                     " does not have a type or value function named " ++ show n ++-                     formatFullContextBrace c+        subAndCheckFunction t0 (diName t2) params (diParams t2) $ n `Map.lookup` fa+      subAndCheckFunction t0 t2 ps1 ps2 (Just f) = do+        when (ctx ^. pcDisallowInit && t2 == ctx ^. pcType) $+          compilerErrorM $ "Function " ++ show n +++                           " disallowed during initialization" ++ formatFullContextBrace c+        when (sfScope f == CategoryScope) $+          compilerErrorM $ "Function " ++ show n ++ " in " ++ show t2 +++                           " is a category function" ++ formatFullContextBrace c+        paired <- processPairs alwaysPair ps1 ps2 <??+          "In external function call at " ++ formatFullContext c+        let assigned = Map.fromList paired+        uncheckedSubFunction assigned f >>= replaceSelfFunction (fixTypeParams t0)+      subAndCheckFunction _ t2 _ _ _ =+        compilerErrorM $ "Category " ++ show t2 +++                         " does not have a type or value function named " ++ show n +++                         formatFullContextBrace c   ccCheckValueInit ctx c (TypeInstance t as) ts ps     | t /= ctx ^. pcType =       compilerErrorM $ "Category " ++ show (ctx ^. pcType) ++ " cannot initialize values from " ++

@@ -46,7 +46,7 @@     scName :: CategoryName,     scExternalParams :: Positional (ValueParam c),     scInternalparams :: Positional (ValueParam c),-    scMembers :: [DefinedMember c],+    scValueMembers :: [DefinedMember c],     scExternalFilters :: [ParamFilter c],     scInternalFilters :: [ParamFilter c],     scFunctions :: Map.Map FunctionName (ScopedFunction c),@@ -79,21 +79,28 @@   checkInternalParams pi fi (getCategoryParams t) (Map.elems fa) r fm   pa <- pairProceduresToFunctions fa ps   let (cp,tp,vp) = partitionByScope (sfScope . fst) pa+  tp' <- mapErrorsM (firstM $ replaceSelfFunction (instanceFromCategory t)) tp+  vp' <- mapErrorsM (firstM $ replaceSelfFunction (instanceFromCategory t)) vp   let (cm,tm,vm) = partitionByScope dmScope ms+  tm' <- mapErrorsM (replaceSelfMember (instanceFromCategory t)) tm+  vm' <- mapErrorsM (replaceSelfMember (instanceFromCategory t)) vm   let cm0 = builtins typeInstance CategoryScope   let tm0 = builtins typeInstance TypeScope   let vm0 = builtins typeInstance ValueScope-  cm' <- mapMembers cm-  tm' <- mapMembers $ cm ++ tm-  vm' <- mapMembers $ cm ++ tm ++ vm-  let cv = Map.union cm0 cm'-  let tv = Map.union tm0 tm'-  let vv = Map.union vm0 vm'-  let ctxC = ScopeContext ta n params params2 vm filters filters2 fa cv em-  let ctxT = ScopeContext ta n params params2 vm filters filters2 fa tv em-  let ctxV = ScopeContext ta n params params2 vm filters filters2 fa vv em-  return [ProcedureScope ctxC cp,ProcedureScope ctxT tp,ProcedureScope ctxV vp]+  cm2 <- mapMembers cm+  tm2 <- mapMembers $ cm ++ tm'+  vm2 <- mapMembers $ cm ++ tm' ++ vm'+  let cv = Map.union cm0 cm2+  let tv = Map.union tm0 tm2+  let vv = Map.union vm0 vm2+  let ctxC = ScopeContext ta n params params2 vm' filters filters2 fa cv em+  let ctxT = ScopeContext ta n params params2 vm' filters filters2 fa tv em+  let ctxV = ScopeContext ta n params params2 vm' filters filters2 fa vv em+  return [ProcedureScope ctxC cp,ProcedureScope ctxT tp',ProcedureScope ctxV vp']   where+    firstM f (x,y) = do+      x' <- f x+      return (x',y)     builtins t s0 = Map.filter ((<= s0) . vvScope) $ builtinVariables t     checkInternalParams pi2 fi2 pe fs2 r fa = do       let pm = Map.fromList $ map (\p -> (vpParam p,vpContext p)) pi2

@@ -411,7 +411,7 @@       fmap indentCompiled $ inlineValueConstructor t d,       return declareValueOverrides,       fmap indentCompiled $ concatM $ map (procedureDeclaration False) fs,-      fmap indentCompiled $ concatM $ map (createMember r allFilters) members,+      fmap indentCompiled $ concatM $ map (createMember r allFilters t) members,       return $ indentCompiled $ createParams $ dcParams d,       return $ onlyCode $ "  const S<" ++ typeName (getCategoryName t) ++ "> parent;",       return $ onlyCodes traceCreation,@@ -526,10 +526,11 @@     ] where       className = valueName (getCategoryName t) -  createMember r filters m = do-    validateGeneralInstance r filters (vtType $ dmType m) <??-      "In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)-    return $ onlyCode $ variableStoredType (dmType m) ++ " " ++ variableName (dmName m) ++ ";"+  createMember r filters t m = do+    m' <- replaceSelfMember (instanceFromCategory t) m+    validateGeneralInstance r filters (vtType $ dmType m') <??+      "In creation of " ++ show (dmName m') ++ " at " ++ formatFullContext (dmContext m')+    return $ onlyCode $ variableStoredType (dmType m') ++ " " ++ variableName (dmName m') ++ ";"   createMemberLazy r filters m = do     validateGeneralInstance r filters (vtType $ dmType m) <??       "In creation of " ++ show (dmName m) ++ " at " ++ formatFullContext (dmContext m)

@@ -98,7 +98,7 @@ mainSourceIncludes = ["#include \"logging.hpp\""]  paramName :: ParamName -> String-paramName p = "Param_" ++ tail (pnName p) -- Remove leading '#'.+paramName p = "Param_" ++ tail (show p) -- Remove leading '#'.  variableName :: VariableName -> String variableName v = "Var_" ++ show v

@@ -285,11 +285,13 @@     getVariableType (ExistingVariable (DiscardInput _)) t = return t     createVariable r fa (CreateVariable c2 t1 n) t2 =       "In creation of " ++ show n ++ " at " ++ formatFullContext c2 ??> do-        -- TODO: Call csAddRequired for t1. (Maybe needs a helper function.)-        lift $ collectAllM_ [validateGeneralInstance r fa (vtType t1),-                             checkValueAssignment r fa t2 t1]-        csAddVariable (UsedVariable c2 n) (VariableValue c2 LocalScope t1 VariableDefault)-        csWrite [variableStoredType t1 ++ " " ++ variableName n ++ ";"]+        self <- autoSelfType+        t1' <- lift $ replaceSelfValueType self t1+        -- TODO: Call csAddRequired for t1'. (Maybe needs a helper function.)+        lift $ collectAllM_ [validateGeneralInstance r fa (vtType t1'),+                             checkValueAssignment r fa t2 t1']+        csAddVariable (UsedVariable c2 n) (VariableValue c2 LocalScope t1' VariableDefault)+        csWrite [variableStoredType t1' ++ " " ++ variableName n ++ ";"]     createVariable r fa (ExistingVariable (InputValue c2 n)) t2 =       "In assignment to " ++ show n ++ " at " ++ formatFullContext c2 ??> do         (VariableValue _ _ t1 _) <- getWritableVariable c2 n@@ -423,15 +425,17 @@   ScopedBlock c -> CompilerState a m () compileScopedBlock s@(ScopedBlock _ _ _ c2 _) = do   let (vs,p,cl,st) = rewriteScoped s+  self <- autoSelfType+  vs' <- lift $ mapErrorsM (replaceSelfVariable self) vs   -- Capture context so we can discard scoped variable names.   ctx0 <- getCleanContext   r <- csResolver   fa <- csAllFilters-  sequence_ $ map (createVariable r fa) vs+  sequence_ $ map (createVariable r fa) vs'   ctxP0 <- compileProcedure ctx0 p   -- Make variables to be created visible *after* p has been compiled so that p   -- can't refer to them.-  ctxP <- lift $ execStateT (sequence $ map showVariable vs) ctxP0+  ctxP <- lift $ execStateT (sequence $ map showVariable vs') ctxP0   ctxCl0 <- lift $ ccClearOutput ctxP >>= flip ccStartCleanup c2   ctxP' <-     case cl of@@ -453,8 +457,11 @@   unreachable <- csIsUnreachable   when (not unreachable) $ autoInsertCleanup c2 NextStatement ctxP'   csWrite ["}"]-  sequence_ $ map showVariable vs+  sequence_ $ map showVariable vs'   where+    replaceSelfVariable self (c,t,n) = do+      t' <- replaceSelfValueType self t+      return (c,t',n)     createVariable r fa (c,t,n) = do       lift $ validateGeneralInstance r fa (vtType t) <??         "In creation of " ++ show n ++ " at " ++ formatFullContext c@@ -561,20 +568,30 @@         | otherwise = compilerErrorM $ "Cannot use " ++ show t ++ " with unary ~ operator" ++                                              formatFullContextBrace c   compile (InitializeValue c t ps es) = do+    scope <- csCurrentScope+    t' <- case scope of+               CategoryScope -> case t of+                                     Nothing -> compilerErrorM $ "Param " ++ show ParamSelf ++ " not found"+                                     Just t0 -> return t0+               _ -> do+                 self <- csSelfType+                 case t of+                      Just t0 -> lift $ replaceSelfSingle (singleType $ JustTypeInstance self) t0+                      Nothing -> return self     es' <- sequence $ map compileExpression $ pValues es     (ts,es'') <- lift $ getValues es'-    csCheckValueInit c t (Positional ts) ps-    params <- expandParams $ tiParams t+    csCheckValueInit c t' (Positional ts) ps+    params <- expandParams $ tiParams t'     params2 <- expandParams2 $ ps-    sameType <- csSameType t+    sameType <- csSameType t'     s <- csCurrentScope-    let typeInstance = getType sameType s params+    let typeInstance = getType t' sameType s params     -- TODO: This is unsafe if used in a type or category constructor.-    return (Positional [ValueType RequiredValue $ singleType $ JustTypeInstance t],-            UnwrappedSingle $ valueCreator (tiName t) ++ "(" ++ typeInstance ++ ", " ++ params2 ++ ", " ++ es'' ++ ")")+    return (Positional [ValueType RequiredValue $ singleType $ JustTypeInstance t'],+            UnwrappedSingle $ valueCreator (tiName t') ++ "(" ++ typeInstance ++ ", " ++ params2 ++ ", " ++ es'' ++ ")")     where-      getType True ValueScope _      = "parent"-      getType _    _          params = typeCreator (tiName t) ++ "(" ++ params ++ ")"+      getType _  True ValueScope _      = "parent"+      getType t2 _    _          params = typeCreator (tiName t2) ++ "(" ++ params ++ ")"       -- Single expression, but possibly multi-return.       getValues [(Positional ts,e)] = return (ts,useAsArgs e)       -- Multi-expression => must all be singles.@@ -712,17 +729,19 @@   t' <- expandCategory t   compileFunctionCall (Just t') f' f compileExpressionStart (TypeCall c t f@(FunctionCall _ n _ _)) = do+  self <- autoSelfType+  t' <- lift $ replaceSelfInstance self (singleType t)   r <- csResolver   fa <- csAllFilters-  lift $ validateGeneralInstance r fa (singleType t) <?? "In function call at " ++ formatFullContext c-  f' <- csGetTypeFunction c (Just $ singleType t) n+  lift $ validateGeneralInstance r fa t' <?? "In function call at " ++ formatFullContext c+  f' <- csGetTypeFunction c (Just t') n   when (sfScope f' /= TypeScope) $ compilerErrorM $ "Function " ++ show n ++-                                          " cannot be used as a type function" ++-                                          formatFullContextBrace c-  csAddRequired $ Set.unions $ map categoriesFromTypes [singleType t]+                                                    " cannot be used as a type function" +++                                                    formatFullContextBrace c+  csAddRequired $ Set.unions $ map categoriesFromTypes [t']   csAddRequired $ Set.fromList [sfType f']-  t' <- expandGeneralInstance $ singleType t-  compileFunctionCall (Just t') f' f+  t2 <- expandGeneralInstance t'+  compileFunctionCall (Just t2) f' f compileExpressionStart (UnqualifiedCall c f@(FunctionCall _ n _ _)) = do   ctx <- get   f' <- lift $ collectFirstM [tryCategory ctx,tryNonCategory ctx]@@ -760,7 +779,9 @@   when (length (pValues $ fst $ head es') /= 1) $     compilerErrorM $ "Expected single return in argument" ++ formatFullContextBrace c   let (Positional [t0],e) = head es'-  [t1,t2] <- lift $ disallowInferred ps+  self <- autoSelfType+  ps' <- lift $ disallowInferred ps+  [t1,t2] <- lift $ mapErrorsM (replaceSelfInstance self) ps'   r <- csResolver   fa <- csAllFilters   lift $ validateGeneralInstance r fa t1@@ -806,7 +827,9 @@     compilerErrorM $ "Expected 1 type parameter" ++ formatFullContextBrace c   when (length (pValues es) /= 0) $     compilerErrorM $ "Expected 0 arguments" ++ formatFullContextBrace c-  [t] <- lift $ disallowInferred ps+  self <- autoSelfType+  ps' <- lift $ disallowInferred ps+  [t] <- lift $ mapErrorsM (replaceSelfInstance self) ps'   r <- csResolver   fa <- csAllFilters   lift $ validateGeneralInstance r fa t@@ -844,8 +867,10 @@   fa <- csAllFilters   es' <- sequence $ map compileExpression $ pValues es   (ts,es'') <- lift $ getValues es'-  ps2 <- lift $ guessParamsFromArgs r fa f ps (Positional ts)-  lift $ mapErrorsM_ backgroundMessage $ zip3 (map vpParam $ pValues $ sfParams f) (pValues ps) (pValues ps2)+  self <- autoSelfType+  ps' <- lift $ fmap Positional $ mapErrorsM (replaceSelfParam self) $ pValues ps+  ps2 <- lift $ guessParamsFromArgs r fa f ps' (Positional ts)+  lift $ mapErrorsM_ backgroundMessage $ zip3 (map vpParam $ pValues $ sfParams f) (pValues ps') (pValues ps2)   f' <- lift $ parsedToFunctionType f   f'' <- lift $ assignFunctionParams r fa Map.empty ps2 f'   -- Called an extra time so arg count mismatches have reasonable errors.@@ -859,6 +884,10 @@   call <- assemble e scoped scope (sfScope f) params es''   return $ (ftReturns f'',OpaqueMulti call)   where+    replaceSelfParam self (AssignedInstance c2 t) = do+      t' <- replaceSelfInstance self t+      return $ AssignedInstance c2 t'+    replaceSelfParam _ t = return t     message = "In call to " ++ show (sfName f) ++ " at " ++ formatFullContext c     backgroundMessage (n,(InferredInstance c2),t) =       compilerBackgroundM $ "Parameter " ++ show n ++ " (from " ++ show (sfType f) ++ "." ++

@@ -77,10 +77,12 @@   merge2,   merge3,   noKeywords,+  noParamSelf,   notAllowed,   nullParse,   operator,   optionalSpace,+  paramSelf,   parseAny2,   parseAny3,   parseBin,@@ -118,6 +120,7 @@  import Base.CompilerError import Parser.TextParser+import Types.TypeInstance (ParamName(ParamSelf))   class ParseFromSource a where@@ -286,6 +289,14 @@  kwWhile :: TextParser () kwWhile = keyword "while"++paramSelf :: TextParser ()+paramSelf = keyword (show ParamSelf)++noParamSelf :: TextParser ()+noParamSelf = (<|> return ()) $ do+    try paramSelf+    compilerErrorM "#self is not allowed here"  operatorSymbol :: TextParser Char operatorSymbol = labeled "operator symbol" $ satisfy (`Set.member` Set.fromList "+-*/%=!<>&|?")

@@ -414,7 +414,7 @@       initalize = do         c <- getSourceContext         t <- try $ do  -- Avoids consuming the type name if { isn't present.-          t2 <- sourceParser+          t2 <- (paramSelf >> return Nothing) <|> fmap Just sourceParser           sepAfter (labeled "@value initializer" $ string_ "{")           return t2         withParams c t <|> withoutParams c t

@@ -106,6 +106,7 @@                      (sepBy singleParam (sepAfter $ string_ ","))       return (con,inv,cov)     singleParam = labeled "param declaration" $ do+      noParamSelf       c <- getSourceContext       n <- sourceParser       return (c,n)@@ -128,6 +129,7 @@ singleFilter :: TextParser (ParamFilter SourceContext) singleFilter = try $ do   c <- getSourceContext+  noParamSelf   n <- sourceParser   f <- sourceParser   return $ ParamFilter [c] n f@@ -179,6 +181,7 @@                          (sepAfter $ string_ ">")                          (sepBy singleParam (sepAfter $ string ","))     singleParam = labeled "param declaration" $ do+      noParamSelf       c <- getSourceContext       n <- sourceParser       return $ ValueParam [c] n Invariant

@@ -84,12 +84,16 @@         | otherwise = CategoryName n  instance ParseFromSource ParamName where-  sourceParser = labeled "param name" $ do-    noKeywords-    char_ '#'-    b <- lowerChar-    e <- sepAfter $ many alphaNumChar-    return $ ParamName ('#':b:e)+  sourceParser = labeled "param name" $ self <|> custom where+    self = do+      paramSelf+      return ParamSelf+    custom = do+      noKeywords+      char_ '#'+      b <- lowerChar+      e <- sepAfter $ many alphaNumChar+      return $ ParamName ('#':b:e)  instance ParseFromSource TypeInstance where   sourceParser = labeled "type instance" $ do

@@ -20,6 +20,7 @@ module Test.TypeCategory (tests) where  import Control.Arrow+import Control.Monad ((>=>)) import System.FilePath import qualified Data.Map as Map import qualified Data.Set as Set@@ -72,6 +73,11 @@     checkShortParseFail "@value interface Type { defines T }",     checkShortParseSuccess "@value interface Type<#x> { #x allows T }", +    checkShortParseSuccess "@value interface Type { call () -> (#self) }",+    checkShortParseFail "@value interface Type<#self> {}",+    checkShortParseFail "@value interface Type { #self refines Foo }",+    checkShortParseFail "@value interface Type { call<#self> () -> () }",+     checkOperationSuccess ("testfiles" </> "value_refines_value.0rx") (checkConnectedTypes defaultCategories),     checkOperationFail ("testfiles" </> "value_refines_instance.0rx") (checkConnectedTypes defaultCategories),     checkOperationFail ("testfiles" </> "value_refines_concrete.0rx") (checkConnectedTypes defaultCategories),@@ -792,6 +798,22 @@       (\ts -> do         ts2 <- topoSortCategories defaultCategories ts         flattenAllConnections defaultCategories ts2 >> return ()),++    checkOperationSuccess+      ("testfiles" </> "valid_self.0rx")+      (includeNewTypes defaultCategories >=> const (return ())),+    checkOperationSuccess+      ("testfiles" </> "filtered_self.0rx")+      (includeNewTypes defaultCategories >=> const (return ())),+    checkOperationFail+      ("testfiles" </> "bad_merge_self.0rx")+      (includeNewTypes defaultCategories >=> const (return ())),+    checkOperationFail+      ("testfiles" </> "contravariant_self.0rx")+      (includeNewTypes defaultCategories >=> const (return ())),+    checkOperationFail+      ("testfiles" </> "invariant_self.0rx")+      (includeNewTypes defaultCategories >=> const (return ())),      checkOperationSuccess       ("testfiles" </> "inference.0rx")

@@ -47,6 +47,14 @@     checkParseSuccess       "#x"       (singleType $ JustParamName False $ ParamName "#x"),+    checkParseSuccess+      "#self"+      (singleType $ JustParamName False $ ParamSelf),+    checkParseSuccess+      "Type0<#self>"+      (singleType $ JustTypeInstance $ TypeInstance (CategoryName "Type0") (Positional [+          singleType $ JustParamName False $ ParamSelf+        ])),     checkParseFail "x",     checkParseFail "", 

@@ -0,0 +1,8 @@+@value interface Value {+  call () -> (#self)+}++concrete Child {+  refines Value+  @value call () -> (Child)+}

@@ -0,0 +1,3 @@+@value interface Value<#x|#y|#z> {+  call (#self) -> ()+}

@@ -0,0 +1,14 @@+@value interface Foo {}++@type interface Bar {}++@value interface Base<|#x> {+  #x requires Foo+  #x defines Bar+}++concrete Value<#y|> {+  refines Base<#self>+  refines Foo+  defines Bar+}

@@ -0,0 +1,6 @@+@value interface Base<#x> {}++@value interface Value<#x|#y|#z> {+  refines Base<#self>+  call () -> (#self)+}

@@ -0,0 +1,16 @@+@value interface Base<|#x> {}++@value interface Value<#x|#y|#z> {+  refines Base<#self>+  call () -> (#self)+}++concrete Child1 {+  refines Value<all,all,all>+  @value call () -> (#self)+}++concrete Child2 {+  refines Value<all,all,all>+  @value call () -> (all)+}

@@ -27,6 +27,7 @@   mapMembers,   mergeInternalInheritance,   pairProceduresToFunctions,+  replaceSelfMember,   setInternalFunctions, ) where @@ -197,3 +198,9 @@   let tm0 = (dcName d) `Map.delete` tm   checkCategoryInstances tm0 [c2']   return $ Map.insert (dcName d) c2' tm++replaceSelfMember :: (Show c, CollectErrorsM m) =>+  GeneralInstance -> DefinedMember c -> m (DefinedMember c)+replaceSelfMember self (DefinedMember c s t n i) = do+  t' <- replaceSelfValueType self t+  return $ DefinedMember c s t' n i

@@ -228,7 +228,7 @@   Literal (ValueLiteral c) |   UnaryExpression [c] (Operator c) (Expression c) |   InfixExpression [c] (Expression c) (Operator c) (Expression c) |-  InitializeValue [c] TypeInstance (Positional GeneralInstance) (Positional (Expression c))+  InitializeValue [c] (Maybe TypeInstance) (Positional GeneralInstance) (Positional (Expression c))   deriving (Show)  data FunctionQualifier c =

@@ -1,5 +1,5 @@ {- ------------------------------------------------------------------------------Copyright 2019-2020 Kevin P. Barry+Copyright 2019-2021 Kevin P. Barry  Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -61,6 +61,7 @@   guessesAsParams,   includeNewTypes,   inferParamTypes,+  instanceFromCategory,   isInstanceInterface,   isNoNamespace,   isPrivateNamespace,@@ -76,6 +77,7 @@   noDuplicateRefines,   parsedToFunctionType,   partitionByScope,+  replaceSelfFunction,   setCategoryNamespace,   topoSortCategories,   uncheckedSubFunction,@@ -220,6 +222,11 @@ getCategoryFunctions (InstanceInterface _ _ _ _ _ fs) = fs getCategoryFunctions (ValueConcrete _ _ _ _ _ _ _ fs) = fs +instanceFromCategory :: AnyCategory c -> GeneralInstance+instanceFromCategory t = singleType $ JustTypeInstance $ TypeInstance n (Positional ps) where+  n = getCategoryName t+  ps = map (singleType . JustParamName True . vpParam) $ getCategoryParams t+ getCategoryDeps :: AnyCategory c -> Set.Set CategoryName getCategoryDeps t = Set.fromList $ filter (/= getCategoryName t) $ refines ++ defines ++ filters ++ functions where   refines = concat $ map (fromInstance . singleType . JustTypeInstance . vrType) $ getCategoryRefines t@@ -384,12 +391,12 @@ checkFilters :: CollectErrorsM m =>   AnyCategory c -> Positional GeneralInstance -> m (Positional [TypeFilter]) checkFilters t ps = do-  let params = map vpParam $ getCategoryParams t-  assigned <- fmap Map.fromList $ processPairs alwaysPair (Positional params) ps-  fs <- mapErrorsM (subSingleFilter assigned . \f -> (pfParam f,pfFilter f))-                                  (getCategoryFilters t)+  assigned <- fmap (Map.insert ParamSelf selfType . Map.fromList) $ processPairs alwaysPair (Positional params) ps+  fs <- mapErrorsM (subSingleFilter assigned . \f -> (pfParam f,pfFilter f)) allFilters   let fa = Map.fromListWith (++) $ map (second (:[])) fs   fmap Positional $ mapErrorsM (assignFilter fa) params where+    params = map vpParam $ getCategoryParams t+    allFilters = getCategoryFilters t ++ map (ParamFilter (getCategoryContext t) ParamSelf) (getSelfFilters t)     subSingleFilter pa (n,(TypeFilter v t2)) = do       t3<- uncheckedSubInstance (getValueForParam pa) t2       return (n,(TypeFilter v t3))@@ -401,6 +408,20 @@             (Just x) -> return x             _ -> return [] +getSelfFilters :: AnyCategory c -> [TypeFilter]+getSelfFilters t = selfFilters where+  params = map vpParam $ getCategoryParams t+  selfParams = Positional $ map (singleType . JustParamName False) params+  selfFilters+    | isInstanceInterface t = [+        DefinesFilter $ DefinesInstance (getCategoryName t) selfParams+      ] ++ inheritedFilters+    | otherwise = [+        TypeFilter FilterRequires $ singleType $ JustTypeInstance $ TypeInstance (getCategoryName t) selfParams+      ] ++ inheritedFilters+  inheritedFilters = map (DefinesFilter . vdType) (getCategoryDefines t) +++                     map (TypeFilter FilterRequires . singleType . JustTypeInstance . vrType) (getCategoryRefines t)+ subAllParams :: CollectErrorsM m =>   ParamValues -> GeneralInstance -> m GeneralInstance subAllParams pa = uncheckedSubInstance (getValueForParam pa)@@ -465,9 +486,9 @@   update t tm =     case getCategoryName t `Map.lookup` tm of         (Just t2) -> compilerErrorM $ "Type " ++ show (getCategoryName t) ++-                                     formatFullContextBrace (getCategoryContext t) ++-                                     " has already been declared" ++-                                     formatFullContextBrace (getCategoryContext t2)+                                      formatFullContextBrace (getCategoryContext t) +++                                      " has already been declared" +++                                      formatFullContextBrace (getCategoryContext t2)         _ -> return $ Map.insert (getCategoryName t) t tm  getFilterMap :: CollectErrorsM m => [ValueParam c] -> [ParamFilter c] -> m ParamFilters@@ -488,7 +509,9 @@                              Map.fromListWith (++) $ map (second (:[])) fs' ++ pa0  getCategoryFilterMap :: CollectErrorsM m => AnyCategory c -> m ParamFilters-getCategoryFilterMap t = getFilterMap (getCategoryParams t) (getCategoryFilters t)+getCategoryFilterMap t = do+  defaultMap <- getFilterMap (getCategoryParams t) (getCategoryFilters t)+  return $ Map.insert ParamSelf (getSelfFilters t) defaultMap  -- TODO: Use this where it's needed in this file. getFunctionFilterMap :: CollectErrorsM m => ScopedFunction c -> m ParamFilters@@ -496,7 +519,7 @@  getCategoryParamMap :: AnyCategory c -> ParamValues getCategoryParamMap t = let ps = map vpParam $ getCategoryParams t in-                          Map.fromList $ zip ps (map (singleType . JustParamName False) ps)+  Map.fromList $ zip ps (map (singleType . JustParamName False) ps) ++ [(ParamSelf,selfType)]  disallowBoundedParams :: CollectErrorsM m => ParamFilters -> m () disallowBoundedParams = mapErrorsM_ checkBounds . Map.toList where@@ -672,7 +695,7 @@       mapErrorsM_ (validateCategoryFunction r t) (getCategoryFunctions t)     checkFilterParam pa (ParamFilter c n _) =       when (not $ n `Set.member` pa) $-        compilerErrorM $ "Param " ++ show n ++ formatFullContextBrace c ++ " does not exist"+        compilerErrorM $ "Param " ++ show n ++ formatFullContextBrace c ++ " not found"     checkRefine r fm (ValueRefine c t) =       validateTypeInstance r fm t <??         ("In " ++ show t ++ formatFullContextBrace c)@@ -831,7 +854,7 @@       (_,v) <- getValueCategory tm (c,n)       let ns = map vpParam $ getCategoryParams v       paired <- processPairs alwaysPair (Positional ns) ps-      return $ Map.fromList paired+      return $ Map.insert ParamSelf selfType $ Map.fromList paired     checkMerged r fm rs rs2 = do       let rm = Map.fromList $ map (\t -> (tiName $ vrType t,t)) rs       mapErrorsM_ (\t -> checkConvert r fm (tiName (vrType t) `Map.lookup` rm) t) rs2@@ -858,14 +881,14 @@       let ps = map vpParam $ getCategoryParams t       let fs2 = getCategoryFunctions t       paired <- processPairs alwaysPair (Positional ps) ts2-      let assigned = Map.fromList paired+      let assigned = Map.fromList $ (ParamSelf,selfType):paired       mapErrorsM (unfixedSubFunction assigned) fs2     getDefinesFuncs tm2 (ValueDefine c (DefinesInstance n ts2)) = do       (_,t) <- getInstanceCategory tm2 (c,n)       let ps = map vpParam $ getCategoryParams t       let fs2 = getCategoryFunctions t       paired <- processPairs alwaysPair (Positional ps) ts2-      let assigned = Map.fromList paired+      let assigned = Map.fromList $ (ParamSelf,selfType):paired       mapErrorsM (unfixedSubFunction assigned) fs2     mergeByName r2 fm2 im em n =       tryMerge r2 fm2 n (n `Map.lookup` im) (n `Map.lookup` em)@@ -873,15 +896,15 @@     tryMerge _ _ n (Just is) Nothing       | length is == 1 = return $ head is       | otherwise = compilerErrorM $ "Function " ++ show n ++ " is inherited " ++-                                   show (length is) ++ " times:\n---\n" ++-                                   intercalate "\n---\n" (map show is)+                                     show (length is) ++ " times:\n---\n" +++                                     intercalate "\n---\n" (map show is)     -- Not inherited.     tryMerge r2 fm2 n Nothing es = tryMerge r2 fm2 n (Just []) es     -- Explicit override, possibly inherited.     tryMerge r2 fm2 n (Just is) (Just es)       | length es /= 1 = compilerErrorM $ "Function " ++ show n ++ " is declared " ++-                                        show (length es) ++ " times:\n---\n" ++-                                        intercalate "\n---\n" (map show es)+                                          show (length es) ++ " times:\n---\n" +++                                          intercalate "\n---\n" (map show es)       | otherwise = do         let ff@(ScopedFunction c n2 t s as rs2 ps fa ms) = head es         mapErrorsM_ (checkMerge r2 fm2 ff) is@@ -890,8 +913,8 @@           checkMerge r3 fm3 f1 f2             | sfScope f1 /= sfScope f2 =               compilerErrorM $ "Cannot merge " ++ show (sfScope f2) ++ " with " ++-                             show (sfScope f1) ++ " in function merge:\n---\n" ++-                             show f2 ++ "\n  ->\n" ++ show f1+                               show (sfScope f1) ++ " in function merge:\n---\n" +++                               show f2 ++ "\n  ->\n" ++ show f1             | otherwise =               ("In function merge:\n---\n" ++ show f2 ++                "\n  ->\n" ++ show f1 ++ "\n---\n") ??> do@@ -1005,6 +1028,23 @@         return $ PassedValue c2 t'       subFilter pa2 (ParamFilter c2 n2 f) = do         f' <- uncheckedSubFilter (getValueForParam pa2) f+        return $ ParamFilter c2 n2 f'++replaceSelfFunction :: (Show c, CollectErrorsM m) =>+  GeneralInstance -> ScopedFunction c -> m (ScopedFunction c)+replaceSelfFunction self ff@(ScopedFunction c n t s as rs ps fa ms) =+  ("In function:\n---\n" ++ show ff ++ "\n---\n") ??> do+    as' <- fmap Positional $ mapErrorsM subPassed $ pValues as+    rs' <- fmap Positional $ mapErrorsM subPassed $ pValues rs+    fa' <- mapErrorsM subFilter fa+    ms' <- mapErrorsM (replaceSelfFunction self) ms+    return $ (ScopedFunction c n t s as' rs' ps fa' ms')+    where+      subPassed (PassedValue c2 t2) = do+        t' <- replaceSelfValueType self t2+        return $ PassedValue c2 t'+      subFilter (ParamFilter c2 n2 f) = do+        f' <- replaceSelfFilter self f         return $ ParamFilter c2 n2 f'  data PatternMatch a =

@@ -1,5 +1,5 @@ {- ------------------------------------------------------------------------------Copyright 2019-2020 Kevin P. Barry+Copyright 2019-2021 Kevin P. Barry  Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -54,8 +54,13 @@   isWeakValue,   mapTypeGuesses,   noInferredTypes,+  replaceSelfFilter,+  replaceSelfInstance,+  replaceSelfSingle,+  replaceSelfValueType,   requiredParam,   requiredSingleton,+  selfType,   uncheckedSubFilter,   uncheckedSubFilters,   uncheckedSubInstance,@@ -147,15 +152,20 @@ instance Ord CategoryName where   c1 <= c2 = show c1 <= show c2 -newtype ParamName =+data ParamName =   ParamName {     pnName :: String-  }+  } |+  ParamSelf   deriving (Eq,Ord)  instance Show ParamName where   show (ParamName n) = n+  show ParamSelf     = "#self" +selfType :: GeneralInstance+selfType = singleType $ JustParamName True ParamSelf+ data TypeInstance =   TypeInstance {     tiName :: CategoryName,@@ -271,7 +281,7 @@   -- Performs parameter substitution for defines.   trDefines :: CollectErrorsM m =>     r -> TypeInstance -> CategoryName -> m InstanceParams-  -- Get the parameter variances for the category.+  -- Gets the parameter variances for the category.   trVariance :: CollectErrorsM m =>     r -> CategoryName -> m InstanceVariances   -- Gets filters for the assigned parameters.@@ -305,7 +315,7 @@ getValueForParam pa n =   case n `Map.lookup` pa of        (Just x) -> return x-       _ -> compilerErrorM $ "Param " ++ show n ++ " does not exist"+       _ -> compilerErrorM $ "Param " ++ show n ++ " not found"  fixTypeParams :: GeneralInstance -> GeneralInstance fixTypeParams = setParamsFixed True@@ -535,7 +545,7 @@ validateGeneralInstance r f = reduceMergeTree collectAllM_ collectAllM_ validateSingle where   validateSingle (JustTypeInstance t) = validateTypeInstance r f t   validateSingle (JustParamName _ n) = when (not $ n `Map.member` f) $-      compilerErrorM $ "Param " ++ show n ++ " does not exist"+      compilerErrorM $ "Param " ++ show n ++ " not found"   validateSingle (JustInferredType n) = compilerErrorM $ "Inferred param " ++ show n ++ " is not allowed here"  validateTypeInstance :: (CollectErrorsM m, TypeResolver r) =>@@ -590,12 +600,13 @@ validateInstanceVariance :: (CollectErrorsM m, TypeResolver r) =>   r -> ParamVariances -> Variance -> GeneralInstance -> m () validateInstanceVariance r vm v = reduceMergeTree collectAllM_ collectAllM_ validateSingle where+  vm' = Map.insert ParamSelf Covariant vm   validateSingle (JustTypeInstance (TypeInstance n ps)) = do     vs <- trVariance r n     paired <- processPairs alwaysPair vs ps-    mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired+    mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm' (v `composeVariance` v2) p) paired   validateSingle (JustParamName _ n) =-    case n `Map.lookup` vm of+    case n `Map.lookup` vm' of         Nothing -> compilerErrorM $ "Param " ++ show n ++ " is undefined"         (Just v0) -> when (not $ v0 `allowsVariance` v) $                           compilerErrorM $ "Param " ++ show n ++ " cannot be " ++ show v@@ -607,7 +618,8 @@ validateDefinesVariance r vm v (DefinesInstance n ps) = do   vs <- trVariance r n   paired <- processPairs alwaysPair vs ps-  mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm (v `composeVariance` v2) p) paired+  mapErrorsM_ (\(v2,p) -> validateInstanceVariance r vm' (v `composeVariance` v2) p) paired where+    vm' = Map.insert ParamSelf Covariant vm  uncheckedSubValueType :: CollectErrorsM m =>   (ParamName -> m GeneralInstance) -> ValueType -> m ValueType@@ -621,10 +633,11 @@   -- NOTE: Don't use mergeAnyM because it will fail if the union is empty.   subAny = fmap mergeAny . sequence   subAll = fmap mergeAll . sequence-  subSingle p@(JustParamName True _) = return $ singleType p-  subSingle (JustParamName _ n)      = replace n-  subSingle (JustInferredType n)     = replace n-  subSingle (JustTypeInstance t)     = fmap (singleType . JustTypeInstance) $ uncheckedSubSingle replace t+  subSingle p@(JustParamName _ ParamSelf) = return $ singleType p+  subSingle p@(JustParamName True _)      = return $ singleType p+  subSingle (JustParamName _ n)           = replace n+  subSingle (JustInferredType n)          = replace n+  subSingle (JustTypeInstance t)          = fmap (singleType . JustTypeInstance) $ uncheckedSubSingle replace t  uncheckedSubSingle :: CollectErrorsM m => (ParamName -> m GeneralInstance) ->   TypeInstance -> m TypeInstance@@ -650,3 +663,34 @@     subParam (n,fs) = do       fs' <- mapErrorsM (uncheckedSubFilter replace) fs       return (n,fs')++replaceSelfValueType :: CollectErrorsM m =>+  GeneralInstance -> ValueType -> m ValueType+replaceSelfValueType self (ValueType s t) = do+  t' <- replaceSelfInstance self t+  return $ ValueType s t'++replaceSelfInstance :: CollectErrorsM m =>+  GeneralInstance -> GeneralInstance -> m GeneralInstance+replaceSelfInstance self = reduceMergeTree subAny subAll subSingle where+  -- NOTE: Don't use mergeAnyM because it will fail if the union is empty.+  subAny = fmap mergeAny . sequence+  subAll = fmap mergeAll . sequence+  subSingle (JustParamName _ ParamSelf) = return self+  subSingle (JustTypeInstance t)        = fmap (singleType . JustTypeInstance) $ replaceSelfSingle self t+  subSingle p                           = return $ singleType p++replaceSelfSingle :: CollectErrorsM m =>+  GeneralInstance -> TypeInstance -> m TypeInstance+replaceSelfSingle self (TypeInstance n (Positional ts)) = do+  ts' <- mapErrorsM (replaceSelfInstance self) ts+  return $ TypeInstance n (Positional ts')++replaceSelfFilter :: CollectErrorsM m =>+  GeneralInstance -> TypeFilter -> m TypeFilter+replaceSelfFilter self (TypeFilter d t) = do+  t' <- replaceSelfInstance self t+  return (TypeFilter d t')+replaceSelfFilter self (DefinesFilter (DefinesInstance n ts)) = do+  ts' <- mapErrorsM (replaceSelfInstance self) (pValues ts)+  return (DefinesFilter (DefinesInstance n (Positional ts')))

@@ -0,0 +1,478 @@+/* -----------------------------------------------------------------------------+Copyright 2021 Kevin P. Barry++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++    http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.+----------------------------------------------------------------------------- */++// Author: Kevin P. Barry [ta0kira@gmail.com]++testcase "disallowed in @category functions" {+  error+  require "#self not found"+}++concrete Type {+  @category call () -> (#self)+}++define Type {+  call () {+    fail("")+  }+}+++testcase "disallowed in @category members" {+  error+  require "#self not found"+}++concrete Type {+  @type create () -> (#self)+}++define Type {+  @category #self value <- Type.create()++  create () {+    return Type{ }+  }+}+++testcase "disallowed in @category procedures" {+  error+  require "#self not found"+}++concrete Type {+  @category call () -> ()+}++define Type {+  call () {+    optional #self value <- empty+  }+}+++testcase "in @type functions" {+  success+}++unittest test {+  Type value <- Type.create()+}++concrete Type {+  @type create () -> (#self)+}++define Type {+  create () {+    return Type{ }+  }+}+++testcase "as base for @type call" {+  success+}++unittest test {+  Type value <- Type.create()+}++concrete Type {+  @type create () -> (Type)+}++define Type {+  create () {+    return #self.new()+  }++  @type new () -> (Type)+  new () {+    return Type{ }+  }+}+++testcase "in @value functions" {+  success+}++unittest test {+  Type value <- Type.create().call()+}++concrete Type {+  @type create () -> (Type)+  @value call () -> (#self)+}++define Type {+  create () {+    return Type{ }+  }++  call () {+    return self+  }+}+++testcase "in @value members" {+  success+}++unittest test {+  Type value <- Type.create(Type.create(empty))+}++concrete Type {+  @type create (optional Type) -> (Type)+}++define Type {+  @value optional #self parent++  create (p) {+    return Type{ p }+  }+}+++testcase "in local variables in @type procedures" {+  success+}++unittest test {+  Type value <- Type.create()+}++concrete Type {+  @type create () -> (Type)+}++define Type {+  create () {+    #self new <- Type{ }+    return new+  }+}+++testcase "in local variables in @value procedures" {+  success+}++unittest test {+  Type value <- Type.create()+}++concrete Type {+  @type create () -> (Type)+  @value get () -> (Type)+}++define Type {+  create () {+    return Type{ }+  }++  get () {+    #self me <- self+    return me+  }+}+++testcase "in local variables in scoped" {+  success+}++unittest test {+  Type value <- Type.create()+}++concrete Type {+  @type create () -> (Type)+}++define Type {+  create () {+    scoped {+    } in #self new <- Type{ }+    return new+  }+}+++testcase "in reduce" {+  success+}++unittest test {+  Type<String>    value1 <- Type<String>.create()+  Type<Formatted> value2 <- Type<Formatted>.create()+  \ Testing.checkEquals<?>(value1.checkFrom<Type<Formatted>>(),true)+  \ Testing.checkEquals<?>(value2.checkFrom<Type<String>>(),false)+  \ Testing.checkEquals<?>(value1.checkTo<?>(value2),false)+  \ Testing.checkEquals<?>(value2.checkTo<?>(value1),true)+}++concrete Type<|#x> {+  @type create () -> (Type<#x>)+  @value checkFrom<#y> () -> (Bool)+  @value checkTo<#y> (#y) -> (Bool)+}++define Type {+  create () {+    return Type<#x>{ }+  }++  checkFrom () {+    return present(reduce<#self,#y>(self))+  }++  checkTo (from) {+    return present(reduce<#y,#self>(from))+  }+}+++testcase "in typename" {+  success+}++unittest test {+  \ Testing.checkEquals<?>(Type<Bool>.get(),"Type<Type<Bool>>")+}++concrete Type<#x> {+  @type get () -> (String)+}++define Type {+  get () {+    return typename<Type<#self>>().formatted()+  }+}+++testcase "with type inference" {+  success+}++unittest test {+  \ Type.create().call<?>("message")+}++concrete Type {+  @type create () -> (Type)+  @value call<#x> (#x) -> (#self)+}++define Type {+  create () {+    return Type{ }+  }++  call (_) {+    return self+  }+}+++testcase "as an explicit function param" {+  success+}++unittest test {+  \ Type.create().call()+}++concrete Test {+  @type identity<#x> (#x) -> (#x)+}++define Test {+  identity (x) {+    return x+  }+}++concrete Type {+  @type create () -> (Type)+  @value call () -> ()+}++define Type {+  create () {+    return Type{ }+  }++  call () {+    Type me <- Test.identity<#self>(self)+  }+}+++testcase "nested in initializer type" {+  success+}++unittest test {+  Type<Type<String>> value <- Type<String>.create().nest()+}++concrete Type<|#x> {+  @type create () -> (#self)+  @value nest () -> (Type<#self>)+}++define Type {+  create () {+    return Type<#x>{ }+  }++  nest () {+    return Type<#self>{ }+  }+}+++testcase "top level initializer type" {+  success+}++unittest test {+  Type<String> value <- Type<String>.create()+}++concrete Type<|#x> {+  @type create () -> (#self)+}++define Type {+  create () {+    return #self{ }+  }+}+++testcase "preserves type in implementations" {+  success+}++unittest test {+  Type value <- Type.create()+  \ Testing.checkEquals<?>(value.next().prev().prev().next().next().get(),1)+}++@value interface Forward {+  next () -> (#self)+}++@value interface Reverse {+  prev () -> (#self)+}++concrete Type {+  refines Forward+  refines Reverse++  @type create () -> (Type)+  @value get () -> (Int)+}++define Type {+  @value Int num++  create () {+    return Type{ 0 }+  }++  get () {+    return num+  }++  next () {+    num <- num+1+    return self+  }++  prev () {+    num <- num-1+    return self+  }+}+++testcase "preserves type in function param filter" {+  success+}++unittest test {+  Type value <- Type.create()+  \ Testing.checkEquals<?>((value `Advance.by<?>` 3).get(),3)+}++@value interface Forward {+  next () -> (#self)+}++concrete Advance {+  @type by<#x>+    #x requires Forward+  (#x,Int) -> (#x)+}++define Advance {+  by (x,i) (x2) {+    x2 <- x+    scoped {+      Int count <- 0+    } in while (count < i) {+      x2 <- x2.next()+    } update {+      count <- count+1+    }+  }+}++concrete Type {+  refines Forward++  @type create () -> (Type)+  @value get () -> (Int)+}++define Type {+  @value Int num++  create () {+    return Type{ 0 }+  }++  get () {+    return num+  }++  next () {+    return Type{ num+1 }+  }+}

@@ -1,7 +1,7 @@ cabal-version:       2.2  name:                zeolite-lang-version:             0.13.0.0+version:             0.14.0.0 synopsis:            Zeolite is a statically-typed, general-purpose programming language.  description: