Ran a Language server on my old code

This commit is contained in:
vegowotenks 2025-07-04 10:06:45 +02:00
parent 64967afb9b
commit 38ed3f1be8
4 changed files with 51 additions and 28 deletions

View file

@ -34,6 +34,7 @@ main = ioLoop initVars
precision = 5 :: Int precision = 5 :: Int
showRatio :: Int -> Rational -> String showRatio :: Int -> Rational -> String
showRatio _ 0 = "0"
showRatio p r = (if (r < 0) then "-" else "") ++ prepoint_digits ++ (if (length postpoint_digits > 0) then ("." ++ postpoint_digits) else "") showRatio p r = (if (r < 0) then "-" else "") ++ prepoint_digits ++ (if (length postpoint_digits > 0) then ("." ++ postpoint_digits) else "")
where where
prepoint_digits = init . show . round . abs $ (r * 10) prepoint_digits = init . show . round . abs $ (r * 10)

View file

@ -18,26 +18,46 @@
module Lib module Lib
( exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions, updateVariables, parseFullString ( exprparser, evaluate, replaceVars, Expr, extractVariableDefinitions, updateVariables, parseFullString
) where ) where
import Control.Applicative((<*))
import Data.Ratio import Data.Functor.Identity
import Data.Ratio ( (%), denominator, numerator )
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Text.Parsec import Text.Parsec
import Text.Parsec.Char ( alphaNum,
import Text.Parsec.String char,
digit,
letter,
oneOf,
eof,
notFollowedBy,
(<?>),
(<|>),
many1,
parse,
try,
ParseError,
ParsecT )
import Text.Parsec.Char ()
import Text.Parsec.String ( Parser )
import Text.Parsec.Expr import Text.Parsec.Expr
( buildExpressionParser, Assoc(AssocLeft), Operator(Infix) )
import Text.Parsec.Token import Text.Parsec.Token
import Text.Parsec.Language ( makeTokenParser,
GenLanguageDef(reservedNames, commentStart, commentEnd, identStart,
identLetter, opStart, opLetter, reservedOpNames),
GenTokenParser(whiteSpace, TokenParser, parens, identifier,
reservedOp, natural, integer) )
import Text.Parsec.Language ( emptyDef )
data Expr = Variable String | Constant Rational | Binary BinaryOperator Expr Expr | VariableDefinition String Expr data Expr = Variable String | Constant Rational | Binary BinaryOperator Expr Expr | VariableDefinition String Expr
deriving Show deriving Show
data BinaryOperator = Plus | Minus | Multiply | Divide | Power data BinaryOperator = Plus | Minus | Multiply | Divide | Power
deriving Show deriving Show
naturalRatio a = a % 1 def :: Monad m => GenLanguageDef String u m
def = emptyDef{ commentStart = "" def = emptyDef{ commentStart = ""
, commentEnd = "" , commentEnd = ""
, identStart = letter <|> char '_' , identStart = letter <|> char '_'
@ -48,20 +68,26 @@ def = emptyDef{ commentStart = ""
, reservedNames = [] , reservedNames = []
} }
m_parens :: ParsecT String u Identity a -> ParsecT String u Identity a
m_identifier :: ParsecT String u Identity String
m_whiteSpace :: ParsecT String u Identity ()
m_reservedOp :: String -> ParsecT String u Identity ()
m_natural :: ParsecT String u Identity Integer
m_integer :: ParsecT String u Identity Integer
TokenParser{ parens = m_parens TokenParser{ parens = m_parens
, identifier = m_identifier , identifier = m_identifier
, reservedOp = m_reservedOp , reservedOp = m_reservedOp
, reserved = m_reserved
, semiSep1 = m_semiSep1
, natural = m_natural , natural = m_natural
, integer = m_integer , integer = m_integer
, whiteSpace = m_whiteSpace } = makeTokenParser def , whiteSpace = m_whiteSpace } = makeTokenParser def
parseFullString :: String -> Either ParseError Expr
parseFullString s = parse (m_whiteSpace *> exprparser <* eof) "<stdin>" s parseFullString s = parse (m_whiteSpace *> exprparser <* eof) "<stdin>" s
exprparser :: Parser Expr exprparser :: Parser Expr
exprparser = buildExpressionParser table term <?> "expression" exprparser = buildExpressionParser table term <?> "expression"
table :: [[Operator String u Identity Expr]]
table = [ table = [
[ [
Infix (m_reservedOp "^" >> return (Binary Power)) AssocLeft, Infix (m_reservedOp "^" >> return (Binary Power)) AssocLeft,
@ -94,7 +120,6 @@ constantRational = do
decimal_digits <- many1 digit decimal_digits <- many1 digit
_ <- m_whiteSpace _ <- m_whiteSpace
let decimal = read decimal_digits :: Integer let decimal = read decimal_digits :: Integer
let natural_length = length . show $ natural
let decimal_length = length decimal_digits let decimal_length = length decimal_digits
let numerator = natural * (10 ^ decimal_length) + decimal let numerator = natural * (10 ^ decimal_length) + decimal
let denominator = 10 ^ decimal_length let denominator = 10 ^ decimal_length
@ -108,6 +133,7 @@ variableDefinition = try (do
return (VariableDefinition name value) return (VariableDefinition name value)
) )
term :: ParsecT String () Identity Expr
term = m_parens exprparser term = m_parens exprparser
<|> variableDefinition <|> variableDefinition
<|> fmap Variable m_identifier <|> fmap Variable m_identifier
@ -121,7 +147,7 @@ extractVariableDefinitions (Constant _) = []
extractVariableDefinitions (Variable _) = [] extractVariableDefinitions (Variable _) = []
updateVariables :: [(String, Expr)] -> Map String Rational -> Either String (Map String Rational) updateVariables :: [(String, Expr)] -> Map String Rational -> Either String (Map String Rational)
updateVariables ds vs = foldl updateVariable (Right vs) ds updateVariables ds vs = foldl' updateVariable (Right vs) ds
updateVariable :: Either String (Map String Rational) -> (String, Expr) -> Either String (Map String Rational) updateVariable :: Either String (Map String Rational) -> (String, Expr) -> Either String (Map String Rational)
updateVariable (Left e) _ = Left e updateVariable (Left e) _ = Left e
@ -135,16 +161,14 @@ updateVariable (Right vs) (name, e) = case updateVariables nvs vs of
replaceVars :: Expr -> Map.Map String Rational -> Either String Expr replaceVars :: Expr -> Map.Map String Rational -> Either String Expr
replaceVars (Constant c) vs = Right $ Constant c replaceVars (Constant c) vs = Right $ Constant c
replaceVars (Variable name) vs = maybe (Left ("Usage of unknown variable: '" ++ name ++ "'\nSuggestion: define the variable\n++ " ++ name ++ "=42")) (Right . Constant . id) $ Map.lookup name vs replaceVars (Variable name) vs = case Map.lookup name vs of
Just value -> Right $ Constant value
Nothing -> Left ("Usage of unknown variable: '" ++ name ++ "'\nSuggestion: define the variable\n++ " ++ name ++ "=42")
replaceVars (VariableDefinition name _) vs = replaceVars (Variable name) vs replaceVars (VariableDefinition name _) vs = replaceVars (Variable name) vs
replaceVars (Binary op l r) vs = case leftBranch of replaceVars (Binary op l r) vs = do
Left s -> Left s leftBranch <- replaceVars l vs
Right a -> case rightBranch of rightBranch <- replaceVars r vs
Left s -> Left s pure $ Binary op leftBranch rightBranch
Right b -> Right $ Binary op a b
where
leftBranch = replaceVars l vs
rightBranch = replaceVars r vs
{- {-
- a/b ^ c/d - a/b ^ c/d

View file

@ -17,8 +17,7 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: resolver: nightly-2025-07-04
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.

View file

@ -1,13 +1,12 @@
# This file was autogenerated by Stack. # This file was autogenerated by Stack.
# You should not edit this file by hand. # You should not edit this file by hand.
# For more information, please see the documentation at: # For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files # https://docs.haskellstack.org/en/stable/topics/lock_files
packages: [] packages: []
snapshots: snapshots:
- completed: - completed:
sha256: edbd50d7e7c85c13ad5f5835ae2db92fab1e9cf05ecf85340e2622ec0a303df1 sha256: f519f0130813ac275982b1a378f4ffd38680394a98ce27c76341e7f7e94ee0a8
size: 720020 size: 722616
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2025/7/4.yaml
original: original: nightly-2025-07-04
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml