diff --git a/code/cs325-langs/sols/hw1.lang b/code/cs325-langs/sols/hw1.lang new file mode 100644 index 0000000..1fd834e --- /dev/null +++ b/code/cs325-langs/sols/hw1.lang @@ -0,0 +1,20 @@ +qselect(xs,k) = + ~xs -> { + pivot <- xs[0]! + left <- xs[#0 <= pivot] + right <- xs[#0 > pivot] + } -> + if k > |left| + 1 then qselect(right, k - |left| - 1) + else if k == |left| + 1 then [pivot] + else qselect(left, k); + +_search(xs, k) = + if xs[1] == k then xs + else if xs[1] > k then _search(xs[0], k) + else _search(xs[2], k); + +sorted(xs) = sorted(xs[0]) ++ [xs[1]] ++ sorted(xs[2]); +search(xs, k) = |_search(xs, k)| != 0; +insert(xs, k) = _insert(k, _search(xs, k)); +_insert(k, xs) = if |xs| == 0 then xs << [] << k << [] else xs + diff --git a/code/cs325-langs/src/LanguageOne.hs b/code/cs325-langs/src/LanguageOne.hs new file mode 100644 index 0000000..f6d80a9 --- /dev/null +++ b/code/cs325-langs/src/LanguageOne.hs @@ -0,0 +1,433 @@ +module LanguageOne where +import qualified PythonAst as Py +import Data.Bifunctor +import Data.Char +import Data.Functor +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Set as Set +import Text.Parsec +import Text.Parsec.Char +import Text.Parsec.Combinator +import Control.Monad.State + +{- Data Types -} +data PossibleType = List | Any deriving Eq + +data SelectorMarker = None | Remove + +data Op + = Add + | Subtract + | Multiply + | Divide + | Insert + | Concat + | LessThan + | LessThanEq + | GreaterThan + | GreaterThanEq + | Equal + | NotEqual + | And + | Or + +data Selector = Selector String Expr + +data Expr + = Var String + | IntLiteral Int + | ListLiteral [Expr] + | Split Expr [Selector] Expr + | IfElse Expr Expr Expr + | BinOp Op Expr Expr + | FunctionCall Expr [Expr] + | LengthOf Expr + | Random + | Access Expr Expr SelectorMarker + | Parameter Int + +data Function = Function String [String] Expr + +data Prog = Prog [Function] + +{- Parser -} +type Parser = Parsec String (Maybe Int) + +parseInt :: Parser Int +parseInt = read <$> (many1 digit <* spaces) + +parseVar :: Parser String +parseVar = + do + c <- satisfy (\c -> (isLetter c && isLower c) || c == '_') + cs <- many (satisfy isLetter <|> digit) + spaces + let var = c:cs + if var `elem` ["if", "then", "else", "rand"] + then fail "reserved" + else return var + +parseKwIf :: Parser () +parseKwIf = string "if" $> () + +parseKwThen :: Parser () +parseKwThen = string "then" $> () + +parseKwElse :: Parser () +parseKwElse = string "else" $> () + +parseKwRand :: Parser Expr +parseKwRand = string "rand" $> Random + +parseThis :: Parser Expr +parseThis = + do + char '&' + contextNum <- getState + spaces + return (Var $ "context_" ++ show contextNum) + +parseList :: Parser Expr +parseList = ListLiteral <$> + do + char '[' >> spaces + es <- sepBy parseExpr (char ',' >> spaces) + spaces >> char ']' >> spaces + return es + +parseSplit :: Parser Expr +parseSplit = + do + char '~' >> spaces + e <- parseExpr + spaces >> string "->" + spaces >> char '{' + contextNum <- getState + putState $ return $ 1 + fromMaybe (-1) contextNum + es <- many1 (spaces >> parseSelector) + putState contextNum + spaces >> char '}' >> spaces >> string "->" >> spaces + e' <- parseExpr + spaces + return $ Split e es e' + +parseSelectorMarker :: Parser SelectorMarker +parseSelectorMarker = (char '!' >> return Remove) <|> return None + +parseSelector :: Parser Selector +parseSelector = + do + name <- parseVar + spaces >> string "<-" >> spaces + expr <- parseExpr + spaces + return $ Selector name expr + +parseIfElse :: Parser Expr +parseIfElse = + do + parseKwIf >> spaces + ec <- parseExpr + spaces >> parseKwThen >> spaces + et <- parseExpr + spaces >> parseKwElse >> spaces + ee <- parseExpr + spaces + return $ IfElse ec et ee + +parseLength :: Parser Expr +parseLength = + do + char '|' >> spaces + e <- parseExpr + spaces >> char '|' >> spaces + return $ LengthOf e + +parseParameter :: Parser Expr +parseParameter = + do + char '#' + d <- digit + spaces + return $ Parameter $ read [d] + +parseParenthesized :: Parser Expr +parseParenthesized = + do + char '(' >> spaces + e <- parseExpr + spaces >> char ')' >> spaces + return e + +parseBasicExpr :: Parser Expr +parseBasicExpr = choice + [ IntLiteral <$> parseInt + , parseThis + , parseList + , parseSplit + , parseLength + , parseParameter + , parseParenthesized + , Var <$> try parseVar + , parseKwRand + , parseIfElse + ] + +parsePostfix :: Parser (Expr -> Expr) +parsePostfix = parsePostfixAccess <|> parsePostfixCall + +parsePostfixAccess :: Parser (Expr -> Expr) +parsePostfixAccess = + do + char '[' >> spaces + e <- parseExpr + spaces >> char ']' >> spaces + marker <- parseSelectorMarker + spaces + return $ \e' -> Access e' e marker + +parsePostfixCall :: Parser (Expr -> Expr) +parsePostfixCall = + do + char '(' >> spaces + es <- sepBy parseExpr (char ',' >> spaces) + char ')' >> spaces + return $ flip FunctionCall es + +parsePostfixedExpr :: Parser Expr +parsePostfixedExpr = + do + eb <- parseBasicExpr + spaces + ps <- many parsePostfix + return $ foldl (flip ($)) eb ps + +parseOp :: String -> Op -> Parser Op +parseOp s o = try (string s) >> return o + +parseLevel :: Parser Expr -> Parser Op -> Parser Expr +parseLevel pe po = + do + start <- pe + spaces + ops <- many $ try $ do + op <- po + spaces + val <- pe + spaces + return (op, val) + spaces + return $ foldl (\l (o, r) -> BinOp o l r) start ops + +parseExpr :: Parser Expr +parseExpr = foldl parseLevel parsePostfixedExpr + [ parseOp "*" Multiply, parseOp "/" Divide + , parseOp "+" Add, parseOp "-" Subtract + , parseOp "<<" Insert + , parseOp "++" Concat + , parseOp "<=" LessThanEq <|> parseOp ">=" GreaterThanEq <|> + parseOp "<" LessThan <|> parseOp ">" GreaterThan <|> + parseOp "==" Equal <|> parseOp "!=" NotEqual + , parseOp "&&" And <|> parseOp "||" Or + ] + +parseFunction :: Parser Function +parseFunction = + do + name <- parseVar + spaces >> char '(' >> spaces + vs <- sepBy parseVar (char ',' >> spaces) + spaces >> char ')' >> spaces >> char '=' >> spaces + body <- parseExpr + spaces + return $ Function name vs body + +parseProg :: Parser Prog +parseProg = Prog <$> sepBy1 parseFunction (char ';' >> spaces) + +parse :: SourceName -> String -> Either ParseError Prog +parse = runParser parseProg Nothing + +{- "Type" checker -} +mergePossibleType :: PossibleType -> PossibleType -> PossibleType +mergePossibleType List _ = List +mergePossibleType _ List = List +mergePossibleType _ _ = Any + +getPossibleType :: String -> Expr -> PossibleType +getPossibleType s (Var s') = if s == s' then List else Any +getPossibleType _ (ListLiteral _) = List +getPossibleType s (Split _ _ e) = getPossibleType s e +getPossibleType s (IfElse i t e) = + foldl1 mergePossibleType $ map (getPossibleType s) [i, t, e] +getPossibleType _ (BinOp Insert _ _) = List +getPossibleType _ (BinOp Concat _ _) = List +getPossibleType _ _ = Any + +{- Translator -} +type Translator = Control.Monad.State.State (Map.Map String [String], Int) + +currentTemp :: Translator String +currentTemp = do + (_, t) <- get + return $ "temp" ++ show t + +incrementTemp :: Translator String +incrementTemp = do + (vs, t) <- get + put (vs, t+1) + return $ "temp" ++ show t + +hasLambda :: Expr -> Bool +hasLambda (ListLiteral es) = any hasLambda es +hasLambda (Split e ss r) = + hasLambda e || any (\(Selector _ e') -> hasLambda e') ss || hasLambda r +hasLambda (IfElse i t e) = hasLambda i || hasLambda t || hasLambda e +hasLambda (BinOp o l r) = hasLambda l || hasLambda r +hasLambda (FunctionCall e es) = any hasLambda $ e : es +hasLambda (LengthOf e) = hasLambda e +hasLambda (Access e _ _) = hasLambda e +hasLambda Parameter{} = True +hasLambda _ = False + +translate :: Prog -> [Py.PyStmt] +translate p = fst $ runState (translateProg p) (Map.empty, 0) + +translateProg :: Prog -> Translator [Py.PyStmt] +translateProg (Prog fs) = concat <$> traverse translateFunction fs + +translateFunction :: Function -> Translator [Py.PyStmt] +translateFunction (Function n ps ex) = do + let createIf p = Py.BinOp Py.Equal (Py.Var p) (Py.ListLiteral []) + let createReturn p = Py.IfElse (createIf p) [Py.Return (Py.Var p)] [] Nothing + let fastReturn = [createReturn p | p <- take 1 ps, getPossibleType p ex == List] + (ss, e) <- translateExpr ex + return $ return $ Py.FunctionDef n ps $ fastReturn ++ ss ++ [Py.Return e] + +translateSelector :: Selector -> Translator Py.PyStmt +translateSelector (Selector n e) = + let + cacheCheck = Py.NotIn (Py.StrLiteral n) (Py.Var "cache") + cacheAccess = Py.Access (Py.Var "cache") [Py.StrLiteral n] + cacheSet = Py.Assign (Py.AccessPat (Py.Var "cache") [Py.StrLiteral n]) + body e' = [ Py.IfElse cacheCheck [cacheSet e'] [] Nothing, Py.Return cacheAccess] + in + do + (ss, e') <- translateExpr e + vs <- gets fst + let callPrereq p = Py.Standalone $ Py.FunctionCall (Py.Var p) [] + let prereqs = maybe [] (map callPrereq) $ Map.lookup n vs + return $ Py.FunctionDef n [] $ ss ++ prereqs ++ body e' + +translateExpr :: Expr -> Translator ([Py.PyStmt], Py.PyExpr) +translateExpr (Var s) = do + vs <- gets fst + let sVar = Py.Var s + let expr = if Map.member s vs then Py.FunctionCall sVar [] else sVar + return ([], expr) +translateExpr (IntLiteral i) = return ([], Py.IntLiteral i) +translateExpr (ListLiteral l) = do + tl <- mapM translateExpr l + return (concatMap fst tl, Py.ListLiteral $ map snd tl) +translateExpr (Split e ss e') = do + vs <- gets fst + let cacheAssign = Py.Assign (Py.VarPat "cache") (Py.DictLiteral []) + let cacheStmt = [ cacheAssign | Map.size vs == 0 ] + let vnames = map (\(Selector n es) -> n) ss + let prereqs = snd $ foldl (\(ds, m) (Selector n es) -> (n:ds, Map.insert n ds m)) ([], Map.empty) ss + modify $ first $ Map.union prereqs + fs <- mapM translateSelector ss + (sts, te) <- translateExpr e' + modify $ first $ const vs + return (cacheStmt ++ fs ++ sts, te) +translateExpr (IfElse i t e) = do + temp <- incrementTemp + let tempPat = Py.VarPat temp + (ists, ie) <- translateExpr i + (tsts, te) <- translateExpr t + (ests, ee) <- translateExpr e + let thenSts = tsts ++ [Py.Assign tempPat te] + let elseSts = ests ++ [Py.Assign tempPat ee] + let newIf = Py.IfElse ie thenSts [] $ Just elseSts + return (ists ++ [newIf], Py.Var temp) +translateExpr (BinOp o l r) = do + (lsts, le) <- translateExpr l + (rsts, re) <- translateExpr r + (opsts, oe) <- translateOp o le re + return (lsts ++ rsts ++ opsts, oe) +translateExpr (FunctionCall f ps) = do + (fsts, fe) <- translateExpr f + tps <- mapM translateExpr ps + return (fsts ++ concatMap fst tps, Py.FunctionCall fe $ map snd tps) +translateExpr (LengthOf e) = + second (Py.FunctionCall (Py.Var "len") . return) <$> translateExpr e +translateExpr (Access e Random m) = do + temp <- incrementTemp + (sts, ce) <- translateExpr e + let lenExpr = Py.FunctionCall (Py.Var "len") [Py.Var temp] + let randExpr = Py.FunctionCall (Py.Var "randint") [ Py.IntLiteral 0, lenExpr ] + return (sts, singleAccess ce randExpr m) +translateExpr (Access c i m) = do + (csts, ce) <- translateExpr c + (ists, ie) <- translateExpr i + temp <- incrementTemp + if hasLambda i + then return (csts ++ ists ++ [createFilterLambda temp ie m], Py.FunctionCall (Py.Var temp) [ce]) + else return (csts ++ ists, singleAccess ce ie m) +translateExpr (Parameter i) = return $ ([], Py.Var $ "arg" ++ show i) +translateExpr _ = fail "Invalid expression" + +singleAccess :: Py.PyExpr -> Py.PyExpr -> SelectorMarker -> Py.PyExpr +singleAccess c i None = Py.Access c [i] +singleAccess c i Remove = Py.FunctionCall (Py.Member c "pop") [i] + +createFilterLambda :: String -> Py.PyExpr -> SelectorMarker -> Py.PyStmt +createFilterLambda s e None = Py.FunctionDef s ["arg"] + [ Py.Assign (Py.VarPat "out") (Py.ListLiteral []) + , Py.For (Py.VarPat "arg0") (Py.Var "arg") + [ Py.IfElse e + [ Py.Standalone $ Py.FunctionCall (Py.Member (Py.Var "out") "append") + [ Py.Var "arg0" ] + ] + [] + Nothing + ] + , Py.Return $ Py.Var "out" + ] +createFilterLambda s e Remove = Py.FunctionDef s ["arg"] + [ Py.Assign (Py.VarPat "i") $ Py.IntLiteral 0 + , Py.Assign (Py.VarPat "out") (Py.ListLiteral []) + , Py.While (Py.BinOp Py.LessThan (Py.Var "i") $ Py.FunctionCall (Py.Var "len") [Py.Var "arg"]) + [ Py.IfElse e + [ Py.Standalone $ Py.FunctionCall (Py.Member (Py.Var "out") "append") + [ singleAccess (Py.Var "arg") (Py.Var "i") Remove + ] + ] + [] + Nothing + , Py.Assign (Py.VarPat "i") (Py.BinOp Py.Add (Py.Var "i") (Py.IntLiteral 1)) + ] + , Py.Return $ Py.Var "out" + ] + +translateOp :: Op -> Py.PyExpr -> Py.PyExpr -> Translator ([Py.PyStmt], Py.PyExpr) +translateOp Add l r = return ([], Py.BinOp Py.Add l r) +translateOp Subtract l r = return ([], Py.BinOp Py.Subtract l r) +translateOp Multiply l r = return ([], Py.BinOp Py.Multiply l r) +translateOp Divide l r = return ([], Py.BinOp Py.Divide l r) +translateOp LessThan l r = return ([], Py.BinOp Py.LessThan l r) +translateOp LessThanEq l r = return ([], Py.BinOp Py.LessThanEq l r) +translateOp GreaterThan l r = return ([], Py.BinOp Py.GreaterThan l r) +translateOp GreaterThanEq l r = return ([], Py.BinOp Py.GreaterThanEq l r) +translateOp Equal l r = return ([], Py.BinOp Py.Equal l r) +translateOp NotEqual l r = return ([], Py.BinOp Py.NotEqual l r) +translateOp And l r = return ([], Py.BinOp Py.And l r) +translateOp Or l r = return ([], Py.BinOp Py.Or l r) +translateOp Concat l r = return ([], Py.BinOp Py.Add l r) +translateOp Insert l r = do + temp <- incrementTemp + let assignStmt = Py.Assign (Py.VarPat temp) l + let appendFunc = Py.Member (Py.Var temp) "append" + let insertStmt = Py.Standalone $ Py.FunctionCall appendFunc [r] + return ([assignStmt, insertStmt], Py.Var temp)