| TBool
| TFun Type Type
-instance toString Expression, Value, Type
+instance toString Function, Expression, Value, Type
([], _) = Left ["No start function defined"]
([Function _ [] e], fs) = Right (foldr (\(Function i a e)->Let i a e) e fs)
([Function _ _ _], _) = Left ["Start cannot have arguments"]
-where
- funs = [i\\(Function i _ _)<-fs]
//import qualified Data.Map as DM
//from Data.Map import instance Functor (Map k)
import ast
int :: Expression -> Either [String] Value
-int _ = Left ["intbork"]
-/*int (AST fs) = evalStateT (mapM evalFun fs >>| getStart fs >>= eval >>= printer) preamble
+int e = evalStateT (eval e >>= printer) preamble
err :: String -> Eval a
err e = liftT (Left [e])
-getStart :: [Function] -> Eval Expression
-getStart [] = err "No start rule defined"
-getStart [(Function ['start'] _ e):_] = pure e
-getStart [_:fs] = getStart fs
-
:: Eval a :== StateT EvalState (Either [String]) a
:: EvalState :== [([Char], Value)]
preamble =
,(['sub'], Func 2 [] (Builtin ['sub']))
]
-putEnv :: [Char] Value -> Eval ()
-putEnv i v = modify (\vs->[(i,v):vs])
-
-getEnv :: [Char] -> Eval Value
-getEnv v = gets (lookup v)
- >>= maybe (err ("Variable " +++ toString v +++ " not found")) pure
-
-evalFun :: Function -> Eval ()
-evalFun (Function v a b) = putEnv v (Func (length a) [] (\es->fun a es b))
-where
- fun [] [] body = body
- fun [a:as] [e:es] body = fun as es (sub a e body)
-
-printer :: Value -> Eval Value
-printer t=:(Func 0 args body) = eval (body args) >>= printer
-printer a = pure a
-
sub :: [Char] Expression Expression -> Expression
+sub ident subst (Let v a b rest)
+ = Let v a (if (isMember ident a) b (sub ident subst b))
+ (if (v == ident) rest (sub ident subst rest))
sub ident subst (Var v)
| ident == v = subst
sub ident subst (App e1 e2) = App (sub ident subst e1) (sub ident subst e2)
| ident <> v = Lambda v (sub ident b subst)
sub _ _ x = x
+printer :: Value -> Eval Value
+printer (Func 0 args body) = eval (body args) >>= printer
+printer a = pure a
+
eval :: Expression -> Eval Value
+eval (Let ident as body rest)
+ = modify (\vs->[(ident, Func (length as) [] \e->zipSt sub as e body):vs])
+ >>| eval rest
eval (Lit v) = pure v
-eval (Var v) = getEnv v
+eval (Var v) = gets (lookup v)
+ >>= maybe (err ("Variable " +++ toString v +++ " not found")) pure
eval (App e1 e2) = eval e1 >>= \v->case v of
-// (Func 0 a b) = err "Saturated function"
+ (Func 0 a b) = err ("Saturated function: : " +++ toString e1)
(Func n as b) = pure (Func (n-1) (as ++ [e2]) b)
-// _ = err ("Cannot apply " +++ toString e2 +++ " to " +++ toString e1)
+ _ = err ("Cannot apply " +++ toString e2 +++ " to " +++ toString e1)
eval (Lambda a b) = pure (Func 1 [] (\[arg]->sub a arg b))
eval (Builtin i as) = case (i, as) of
(['if'], [p,t,e]) = eval p >>= printer >>= \v->case v of
(['eq'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
(Int a, Int b) = pure (Bool (a == b))
// _ = err "eq only defined for integers"
-*/
import Data.Either
import Data.Functor
import Data.Func
-import Control.Monad
+import Text
+import Control.Monad => qualified join
import System.GetOpt
import System.CommandLine
:: Mode = MHelp | MLex | MParse | MType | MInterpret | MGen
:: Result
= Lex [Token]
- | Parse [Function]
+ | Parse String
| Type Expression
| Interpret Value
| Gen [String]
= case mode of
MHelp = Left [usageInfo ("Usage: " +++ argv0 +++ " [options]\n") options]
MLex = Lex <$> lex cs
- MParse = Parse <$> (lex cs >>= parse)
+ MParse = Parse <$> join "\n" <$> map toString <$> (lex cs >>= parse)
MType = Type <$> (lex cs >>= parse >>= check)
MInterpret = Interpret <$> (lex cs >>= parse >>= check >>= int)
MGen = Gen <$> (lex cs >>= parse >>= check >>= gen)
(<:>) infixl 0 :: a (m [a]) -> m [a] | Functor m
(<:>) l r = (\xs->[l:xs]) <$> r
-:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTIdent [Char]
+:: Token = TTEq | TTSemiColon | TTLambda | TTDot | TTBrackOpen | TTBrackClose | TTBool Bool | TTInt Int | TTOp [Char] | TTIdent [Char]
derive gEq Token
lex :: [Char] -> Either [String] [Token]
lex [] = pure []
| isDigit t
# (i, ts) = span isDigit [t:ts]
= TTInt (toInt (toString i)) <:> lex ts
- | isIdent t
- # (i, ts) = span isIdent [t:ts]
+ | isAlpha t
+ # (i, ts) = span isAlpha [t:ts]
+ = TTIdent i <:> lex ts
+ | isOp t
+ # (i, ts) = span isOp [t:ts]
| i =: ['='] = TTEq <:> lex ts
| i =: ['.'] = TTDot <:> lex ts
| i =: ['\\'] = TTLambda <:> lex ts
- = TTIdent i <:> lex ts
+ = TTOp i <:> lex ts
= Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
where
- isIdent c = isAlpha c || isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
+ isOp c = isMember c ['!@#$%^&*=+/?-_|\\\'",<>.:']
:: Parser a :== StateT ParseState (Either [String]) a
:: ParseState =
{ tokens :: [Token]
- , ifxs :: [((Parser Expression) -> Parser Expression, Int)]
+ , ifxs :: [((Parser Expression) -> Parser Expression, Int)]
}
-instance zero ParseState where zero = {tokens=[],ifxs=[]}
pTop :: Parser Token
pTop = getState >>= \s->case s.tokens of
[] = pure ()
[t:ts] = liftT (Left ["Expected EOF"])
-pSatisfy :: (Token -> Bool) -> Parser Token
-pSatisfy f = pTop >>= \t->if (f t) (pure t) empty
+(?) infixl 9 :: (Parser a) (a -> Bool) -> Parser a
+(?) p f = p >>= \v->if (f v) (pure v) empty
pToken :: (Token -> Parser Token)
-pToken = pSatisfy o (===)
+pToken = (?) pTop o (===)
pChainl :: (Parser (a a -> a)) (Parser a) -> Parser a
pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p)
pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p
parse :: [Token] -> Either [String] [Function]
-parse ts = case runStateT (pAST <* pEof) {zero & tokens=ts} of
- Right (a, _) = Right a
- Left e = Left e
+parse ts = fst <$> runStateT (pAST <* pEof) {tokens=ts, ifxs=[]}
where
pAST :: Parser [Function]
pAST = many pFunction >>= mapM \(id, args, body)->Function id args <$
- modify (\t->{t&tokens=body}) <*> pExpression <* pEof
+ modify (\t->{t & tokens=body}) <*> pExpression <* pEof
- pId = (\(TTIdent i)->i) <$> pSatisfy (\t->t=:(TTIdent _))
- pCId a = pId >>= \b->if (a == b) (pure a) empty
+ pId = (\(TTIdent i)->i) <$> pTop ? (\t->t=:(TTIdent _))
+ pOp = (\(TTOp i)->i) <$> pTop ? (\t->t=:(TTOp _))
pFunction :: Parser ([Char], [[Char]], [Token])
pFunction
<$> (pFunId <|> pId)
<*> many pId
<* pToken TTEq
- <*> many (pSatisfy ((=!=)TTSemiColon))
+ <*> many (pTop ? ((=!=)TTSemiColon))
<* pToken TTSemiColon
pFunId :: Parser [Char]
- pFunId = pId
- >>= \i->pChainr <$ pCId ['ifxr'] <|> pChainl <$ pCId ['ifxl']
- >>= \p->(\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
- >>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pCId i), s):t.ifxs]})
+ pFunId = pOp
+ >>= \i->pChainr <$ pId ? ((==) ['ifxr']) <|> pChainl <$ pId ? ((==)['ifxl'])
+ >>= \p->(\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
+ >>= \s->modify (\t->{t & ifxs=[(p (App o App (Var i) <$ pOp ? ((==)i)), s):t.ifxs]})
>>| pure i
pExpression :: Parser Expression
pExpression = getState >>= \{ifxs}->flip (foldr ($))
- [pChainl (pure App):map fst $ sortBy (on (<) snd) ifxs]
+ (map fst $ sortBy (on (<) snd) ifxs)
+ $ pChainl (pure App)
$ Lambda <$ pToken TTLambda <*> pId <* pToken TTDot <*> pExpression
<|> pToken TTBrackOpen *> pExpression <* pToken TTBrackClose
- <|> Lit o Int <$> (\(TTInt i)->i) <$> pSatisfy (\t->t=:(TTInt _))
- <|> (\(TTBool i)->Lit (Bool i)) <$> pSatisfy (\t->t=:(TTBool _))
+ <|> Lit o Int <$> (\(TTInt i)->i) <$> pTop ? (\t->t=:(TTInt _))
+ <|> (\(TTBool i)->Lit (Bool i)) <$> pTop ? (\t->t=:(TTBool _))
<|> Var <$> pId
* ifxl 7 x y = mul x y;
- ifxl 6 x y = sub x y;
+ ifxl 6 x y = add x y;
-start = 3 - 2 - 1;
+fac i = if (i == 0) 1 (i * fac (i - 1));
+start = fac 5;
repositories / minfp.git / commitdiff