Removed typechecking

Well, it's unnecessary complexity :D I might add checking again in the future, but you'll need to typecheck in your head for now.
author: Marvin Borner 2023-02-20 22:02:37 +0100
committer: Marvin Borner 2023-02-20 22:02:37 +0100
commit: 7a9768dae668d2e08cefebaf39911a9b3f2366cf (patch)
tree: a2b4836b8c7891d2e74aca8d628e1f08c1b1e246 /src
parent: 8e3a7a0d5b0096a0e7bea934fa55ee910a7a3f0a (diff)
4 files changed, 46 insertions, 124 deletions
diff --git a/src/Eval.hs b/src/Eval.hs
index 6cf1fb8..0e0e650 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -23,8 +23,6 @@ import           System.FilePath.Posix          ( takeBaseName )
 import           Text.Megaparsec         hiding ( State
                                                 , try
                                                 )
-import           Typer
-
 data EnvState = EnvState
   { _env   :: Environment
   , _conf  :: EvalConf
@@ -67,8 +65,8 @@ loadFile path conf cache = do
 evalFun :: Identifier -> Environment -> EvalState (Failable Expression)
 evalFun fun (Environment sub) = state $ \env@(Environment e) ->
   let lookup' env' = case M.lookup fun env' of
-        Nothing                               -> Left $ UndefinedIdentifier fun
-        Just (EnvDef { _exp = x, _type = t }) -> Right $ TypedExpression t x
+        Nothing                    -> Left $ UndefinedIdentifier fun
+        Just (EnvDef { _exp = x }) -> Right x
       matching n
         | null e = "<no idea>"
         | otherwise = snd $ minimumBy (compare `on` fst) $ map
@@ -122,38 +120,27 @@ evalMixfix m sub = resolve (mixfixKind m) mixfixArgs
 
 evalPrefix
   :: Identifier -> Expression -> Environment -> EvalState (Failable Expression)
--- IDEA: typing and reduce if all arguments are fulfilled
--- evalPrefix (PrefixFunction "⊩") e sub = evalExp e sub >>= \case
---   Left  e' -> pure $ Left e'
---   Right e' -> pure $ Right $ reduce e'
--- evalPrefix p e sub = evalExp (Application (Function p) e) sub
 evalPrefix p e = evalExp $ Application (Function p) e
 
 evalExp :: Expression -> Environment -> EvalState (Failable Expression)
-evalExp idx@(Bruijn      _      ) = const $ pure $ Right idx
-evalExp (    Function    fun    ) = evalFun fun
-evalExp (    Abstraction e      ) = evalAbs e
-evalExp (    Application f g    ) = evalApp f g
-evalExp (    MixfixChain es     ) = evalMixfix es
-evalExp (    Prefix          p e) = evalPrefix p e
-evalExp (    TypedExpression t e) = error "invalid"
+evalExp idx@(Bruijn      _  ) = const $ pure $ Right idx
+evalExp (    Function    fun) = evalFun fun
+evalExp (    Abstraction e  ) = evalAbs e
+evalExp (    Application f g) = evalApp f g
+evalExp (    MixfixChain es ) = evalMixfix es
+evalExp (    Prefix p e     ) = evalPrefix p e
+evalExp _                     = error "invalid"
 
 evalDefinition
-  :: Identifier
-  -> Expression
-  -> Type
-  -> Environment
-  -> EvalState (Failable Expression)
-evalDefinition i e t sub = evalExp e sub >>= \case
-  Left  e' -> pure $ Left e'
-  Right f  -> case typeCheck f t of
-    err@(Left _) -> pure err
-    Right f' ->
-      modify
-          (\(Environment s) -> Environment
-            $ M.insert i (EnvDef f' t (Environment M.empty) defaultFlags) s
-          )
-        >> pure (Right f)
+  :: Identifier -> Expression -> Environment -> EvalState (Failable Expression)
+evalDefinition i e sub = evalExp e sub >>= \case
+  Left e' -> pure $ Left e'
+  Right f ->
+    modify
+        (\(Environment s) -> Environment
+          $ M.insert i (EnvDef f (Environment M.empty) defaultFlags) s
+        )
+      >> pure (Right f)
 
 evalTest
   :: Expression -> Expression -> Environment -> EvalState (Failable Command)
@@ -274,9 +261,9 @@ evalInstruction
   :: Instruction -> EnvState -> (EnvState -> IO EnvState) -> IO EnvState
 evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf _) rec =
   case instr of
-    Define i e t sub -> do
-      EnvState subEnv _ _ <- evalSubEnv sub s
-      (res, env') <- pure $ evalDefinition i e t subEnv `runState` env
+    Define i e sub -> do
+      EnvState subEnv _     _ <- evalSubEnv sub s
+      (        res    , env') <- pure $ evalDefinition i e subEnv `runState` env
       case res of
         Left err ->
           print (ContextualError err $ Context inp $ _nicePath conf) >> pure s -- don't continue
diff --git a/src/Helper.hs b/src/Helper.hs
index 9c3df50..a1333fb 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -39,13 +39,11 @@ printContext (Context inp path) = p $ lines inp
 
 errPrefix :: String
 errPrefix = "\ESC[101m\ESC[30mERROR\ESC[0m "
-data Error = SyntaxError String | UndefinedIdentifier Identifier | UnmatchedMixfix [MixfixIdentifierKind] [Mixfix] | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | SuggestSolution Error String | ImportError String | TypeError [Type]
+data Error = SyntaxError String | UndefinedIdentifier Identifier | UnmatchedMixfix [MixfixIdentifierKind] [Mixfix] | InvalidIndex Int | FailedTest Expression Expression Expression Expression | ContextualError Error Context | SuggestSolution Error String | ImportError String
 instance Show Error where
   show (ContextualError err ctx) = show err <> "\n" <> (printContext ctx)
   show (SuggestSolution err sol) =
-    show err
-      <> "\n\ESC[102m\ESC[30msuggestion\ESC[0m Perhaps you meant: "
-      <> sol
+    show err <> "\n\ESC[102m\ESC[30msuggestion\ESC[0m Perhaps you meant " <> sol
   show (SyntaxError err) =
     errPrefix <> "invalid syntax\n\ESC[105m\ESC[30mnear\ESC[0m " <> err
   show (UndefinedIdentifier ident) =
@@ -68,8 +66,6 @@ instance Show Error where
       <> " = "
       <> show red2
   show (ImportError path) = errPrefix <> "invalid import " <> show path
-  show (TypeError ts) =
-    errPrefix <> "couldn't match types " <> intercalate " and " (map show ts)
 type Failable = Either Error
 
 -- Modified from megaparsec's errorBundlePretty
@@ -128,7 +124,7 @@ instance Show Mixfix where
   show (MixfixOperator   i) = show i
   show (MixfixExpression e) = show e
 -- TODO: Remove Application and replace with Chain (renaming of MixfixChain)
-data Expression = Bruijn Int | Function Identifier | Abstraction Expression | Application Expression Expression | MixfixChain [Mixfix] | Prefix Identifier Expression | TypedExpression Type Expression
+data Expression = Bruijn Int | Function Identifier | Abstraction Expression | Application Expression Expression | MixfixChain [Mixfix] | Prefix Identifier Expression
   deriving (Ord, Eq)
 instance Show Expression where
   show (Bruijn      x    ) = "\ESC[91m" <> show x <> "\ESC[0m"
@@ -138,25 +134,10 @@ instance Show Expression where
     "\ESC[33m(\ESC[0m" <> show exp1 <> " " <> show exp2 <> "\ESC[33m)\ESC[0m"
   show (MixfixChain ms) =
     "\ESC[33m(\ESC[0m" <> (intercalate " " $ map show ms) <> "\ESC[33m)\ESC[0m"
-  show (Prefix          p e) = show p <> " " <> show e
-  show (TypedExpression t e) = show e <> " ⧗ " <> show t
+  show (Prefix p e) = show p <> " " <> show e
 data Command = Input String | Import String String | Test Expression Expression
   deriving (Show)
-data Type = AnyType | PolymorphicType String | NormalType String | ConstructorType String [Type] | FunctionType [Type]
-  deriving (Ord, Eq)
-instance Show Type where
-  show AnyType             = "\ESC[33mAny\ESC[0m"
-  show (PolymorphicType n) = "\ESC[36m" <> n <> "\ESC[0m"
-  show (NormalType      n) = "\ESC[95m" <> n <> "\ESC[0m"
-  show (ConstructorType n ts) =
-    "("
-      <> "\ESC[95m"
-      <> n
-      <> "\ESC[0m"
-      <> (intercalate " " (map show ts))
-      <> ")"
-  show (FunctionType ts) = "(" <> (intercalate " → " (map show ts)) <> ")"
-data Instruction = Define Identifier Expression Type [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String
+data Instruction = Define Identifier Expression [Instruction] | Evaluate Expression | Comment | Commands [Command] | ContextualInstruction Instruction String
   deriving (Show)
 
 data EvalConf = EvalConf
@@ -171,7 +152,6 @@ data ExpFlags = ExpFlags
   deriving Show
 data EnvDef = EnvDef
   { _exp   :: Expression
-  , _type  :: Type
   , _sub   :: Environment
   , _flags :: ExpFlags
   }
diff --git a/src/Parser.hs b/src/Parser.hs
index b65a59e..b2579a9 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -197,40 +197,39 @@ parseEvaluate = do
   e   <- parseExpression
   pure $ ContextualInstruction (Evaluate e) inp
 
-parseFunctionType :: Parser Type
+parseFunctionType :: Parser ()
 parseFunctionType =
-  (FunctionType <$> sepBy1 parseTypeSingleton (sc *> char '→' <* sc))
+  sepBy1 parseTypeSingleton (sc *> char '→' <* sc)
+    >>  return ()
     <?> "function type"
 
-parseConstructorType :: Parser Type
+parseConstructorType :: Parser ()
 parseConstructorType = do
-  i <- typeIdentifier
+  _ <- typeIdentifier
   sc
-  is <- sepBy1 parseTypeSingleton sc
-  (pure $ ConstructorType i is) <?> "constructor type"
+  _ <- sepBy1 parseTypeSingleton sc
+  return () <?> "constructor type"
 
-parseTypeIdentifier :: Parser Type
-parseTypeIdentifier = NormalType <$> typeIdentifier <?> "type identifier"
+parseTypeIdentifier :: Parser ()
+parseTypeIdentifier = typeIdentifier >> return () <?> "type identifier"
 
-parsePolymorphicTypeIdentifier :: Parser Type
+parsePolymorphicTypeIdentifier :: Parser ()
 parsePolymorphicTypeIdentifier =
-  PolymorphicType
-    <$> polymorphicTypeIdentifier
-    <?> "polymorphic type identifier"
+  polymorphicTypeIdentifier >> return () <?> "polymorphic type identifier"
 
-parseTypeSingleton :: Parser Type
+parseTypeSingleton :: Parser ()
 parseTypeSingleton =
   try (parens parseFunctionType)
     <|> try (parens parseConstructorType)
     <|> try parseTypeIdentifier
     <|> try parsePolymorphicTypeIdentifier
 
-parseTypeExpression :: Parser Type
+parseTypeExpression :: Parser ()
 parseTypeExpression = parseFunctionType <?> "type expression"
 
-parseDefineType :: Parser Type
+parseDefineType :: Parser ()
 parseDefineType = do
-  (try $ char '⧗' <* sc *> parseTypeExpression) <|> (return AnyType)
+  (try $ char '⧗' <* sc *> parseTypeExpression) <|> (return ())
 
 parseDefine :: Int -> Parser Instruction
 parseDefine lvl = do
@@ -238,10 +237,10 @@ parseDefine lvl = do
   var <- defIdentifier
   sc
   e    <- parseExpression
-  t    <- parseDefineType
+  _    <- parseDefineType
   subs <-
     (try $ newline *> (many (parseBlock (lvl + 1)))) <|> (try eof >> return [])
-  pure $ ContextualInstruction (Define var e t subs) inp
+  pure $ ContextualInstruction (Define var e subs) inp
 
 parseReplDefine :: Parser Instruction
 parseReplDefine = do
@@ -250,7 +249,7 @@ parseReplDefine = do
   _   <- sc *> char '=' <* sc
   e   <- parseExpression
   t   <- parseDefineType
-  pure $ ContextualInstruction (Define var e t []) inp
+  pure $ ContextualInstruction (Define var e []) inp
 
 parseComment :: Parser ()
 parseComment = do
@@ -308,6 +307,7 @@ parseBlock lvl =
 parseReplLine :: Parser Instruction
 parseReplLine =
   try parseReplDefine -- TODO: This is kinda hacky
-    <|> ((Commands . (: [])) <$> (try parseImport))
     <|> ((Commands . (: [])) <$> (try parseTest))
+    <|> ((Commands . (: [])) <$> (try parseInput))
+    <|> ((Commands . (: [])) <$> (try parseImport))
     <|> try parseEvaluate
diff --git a/src/Typer.hs b/src/Typer.hs
deleted file mode 100644
index 0de01dd..0000000
--- a/src/Typer.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Typer
-  ( typeCheck
-  ) where
-
-import           Helper
-
--- removes ys from start of xs
-dropList :: (Eq a) => [a] -> [a] -> [a]
-dropList [] _  = []
-dropList xs [] = xs
-dropList e@(x : xs) (y : ys) | x == y    = dropList xs ys
-                             | otherwise = e
-
-typeMatches :: Type -> Type -> Bool
-typeMatches AnyType _       = True
-typeMatches _       AnyType = True
-typeMatches a       b       = a == b
-
-typeApply :: Type -> Type -> Type
-typeApply (FunctionType ts1) (FunctionType ts2) =
-  FunctionType $ dropList ts1 ts2
-typeApply AnyType _       = AnyType
-typeApply _       AnyType = AnyType
-typeApply a       b       = error "invalid"
-
-typeImply :: Expression -> Type
-typeImply (Bruijn      _        ) = AnyType
-typeImply (Abstraction e        ) = typeImply e
-typeImply (Application     e1 e2) = typeApply (typeImply e1) (typeImply e2)
-typeImply (TypedExpression t  _ ) = t
-typeImply _                       = error "invalid"
-
-typeCheck :: Expression -> Type -> Failable Expression
-typeCheck e@(Bruijn   _) _ = Right e
-typeCheck e@(Function _) _ = error "invalid"
-typeCheck e@(Abstraction e') (FunctionType (t : ts)) =
-  typeCheck e' (FunctionType ts) >>= pure (Right e)
-typeCheck e@(Abstraction _) _ = Right e
-typeCheck e@(Application e1 e2) t
-  | typeMatches (typeImply e) t = Right e
-  | otherwise = Left $ TypeError [(typeImply e1), (typeImply e2), t]
-typeCheck e@(MixfixChain _) _ = Right e
-typeCheck e@(Prefix _ _   ) _ = Right e
-typeCheck (TypedExpression t' e) t | typeMatches t' t = Right e
-                                   | otherwise        = Left $ TypeError [t', t]
author	Marvin Borner	2023-02-20 22:02:37 +0100
committer	Marvin Borner	2023-02-20 22:02:37 +0100
commit	7a9768dae668d2e08cefebaf39911a9b3f2366cf (patch)
tree	a2b4836b8c7891d2e74aca8d628e1f08c1b1e246 /src
parent	8e3a7a0d5b0096a0e7bea934fa55ee910a7a3f0a (diff)