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
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 "")
where
prepoint_digits = init . show . round . abs $ (r * 10)

View file

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

View file

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

View file

@ -1,13 +1,12 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# 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: []
snapshots:
- completed:
sha256: edbd50d7e7c85c13ad5f5835ae2db92fab1e9cf05ecf85340e2622ec0a303df1
size: 720020
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml
sha256: f519f0130813ac275982b1a378f4ffd38680394a98ce27c76341e7f7e94ee0a8
size: 722616
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2025/7/4.yaml
original: nightly-2025-07-04