{- |
Module : Abstract Syntax Tree
Description : Helper module for Lexer which cares about everything related to the interchageable AST.
Maintainer : Christian H. et al.
License : MIT
-}
module AST (fromAST, toAST, parse, adjacent, valids)
where
import InterfaceDT as IDT
import ErrorHandling as EH
import Data.Maybe
import Data.List
import Text.Printf
import qualified Data.Map as Map
import InstructionPointer
-- |Convert a graph/AST into a portable text representation.
-- See also 'fromGraph'.
fromAST :: IDT.Lexer2SynAna -- ^Input graph/AST/forest.
-> String -- ^Portable text representation of the AST:
--
-- Each function is represented by its own section. A section has a header
-- and content; it continues either until the next section, a blank line or
-- the end of the file, whichever comes first.
--
-- A section header consists of a single line containing the name of the function,
-- enclosed in square brackets, e. g. @[function_name]@. There cannot be any whitespace
-- before the opening bracket.
--
-- The section content consists of zero or more non-blank lines containing exactly
-- three records delimited by a semicolon @;@. Each line describes a node and contains
-- the following records, in this order:
--
-- * The node ID (numeric), e. g. @1@.
-- * The Rail lexeme, e. g. @o@ or @[constant]@ etc. Note that track lexemes like
-- @-@ or @+@ are not included in the graph. Multi-character lexemes like constants
-- may include semicolons, so you need to parse them correctly! In other words, you need
-- to take care of lines like @1;[some ; constant];2@.
-- * Node ID of the follower node, e. g. @2@. May be @0@ if there is no next node.
fromAST (IDT.ILS graph) = unlines $ map fromGraph graph
-- |Convert a portable text representation of a graph into a concrete graph representation.
-- See also 'toGraph'. See 'fromAST' for a specification of the portable text representation.
toAST :: String -- ^Portable text representation. See 'fromAST'.
-> IDT.Lexer2SynAna -- ^Output graph.
toAST input = IDT.ILS (map toGraph $ splitfunctions input)
-- |Convert an 'IDT.Graph' for a single function to a portable text representation.
-- See 'fromAST' for a specification of the representation.
--
-- TODO: Currently, this apparently crashes the program on invalid input. More sensible error handling?
-- At least a nice error message would be nice.
fromGraph :: IDT.Graph -- ^Input graph.
-> String -- ^Text representation.
fromGraph (funcname, nodes) = unlines $ ("["++funcname++"]"):tail (map (fromLexNode . offset (-1)) nodes)
where
fromLexNode :: IDT.LexNode -> String
fromLexNode (id, lexeme, follower) = show id ++ ";" ++ fromLexeme lexeme ++ ";" ++ show follower ++ optional lexeme
fromLexeme :: IDT.Lexeme -> String
fromLexeme Boom = "b"
fromLexeme EOF = "e"
fromLexeme Input = "i"
fromLexeme Output = "o"
fromLexeme Underflow = "u"
fromLexeme RType = "?"
fromLexeme (Constant string) = "["++escapestring string++"]"
fromLexeme (Push string) = "("++string++")"
fromLexeme (Pop string) = "(!"++string++"!)"
fromLexeme (Call string) = "{"++string++"}"
fromLexeme Add1 = "a"
fromLexeme Divide = "d"
fromLexeme Multiply = "m"
fromLexeme Remainder = "r"
fromLexeme Subtract = "s"
fromLexeme Cut = "c"
fromLexeme Append = "p"
fromLexeme Size = "z"
fromLexeme Nil = "n"
fromLexeme Cons = ":"
fromLexeme Breakup = "~"
fromLexeme Greater = "g"
fromLexeme Equal = "q"
fromLexeme Start = "$"
fromLexeme Finish = "#"
fromLexeme (Junction _) = "v"
fromLexeme (Lambda _) = "&"
fromLexeme NOP = "."
optional (Junction follow) = ';' : show follow
optional (Lambda follow) = ';' : show follow
optional _ = ";0"
-- |Split a portable text representation of multiple function graphs (a forest) into separate
-- text representations of each function graph.
splitfunctions :: String -- ^Portable text representation of the forest.
-> [[String]] -- ^List of lists, each being a list of lines making up a separate function graph.
splitfunctions = groupBy (\_ y -> null y || head y /= '[') . filter (not . null) . lines
-- |Convert a portable text representation of a single function into an 'IDT.Graph'.
-- Raises 'error's on invalid input (see 'ErrorHandling').
toGraph :: [String] -- ^List of lines making up the text representation of the function.
-> IDT.Graph -- ^Graph describing the function.
toGraph lns = (init $ tail $ head lns, (1, Start, if null nodelist then 0 else 2):map (offset 1) nodelist)
where
nodelist = nodes $ tail lns
nodes [] = []
nodes (ln:lns) = (read id, fixedlex, read follower):nodes lns
where
(id, other) = span (/=';') ln
(lex, ip) = parse (convert [other]) (IP 0 1 0 E Forward Map.empty)
(follower, attribute) = span (/=';') (drop (2 + posx ip) other)
fixedlex
| isJunction lex = Junction (read $ tail attribute)
| isLambda lex = Lambda (read $ tail attribute)
| otherwise = fromJust lex
fromJust Nothing = error $ printf EH.shrLineNoLexeme ln
fromJust (Just x) = x
isJunction (Just (Junction _)) = True
isJunction _ = False
isLambda (Just (Lambda _)) = True
isLambda _ = False
convert code = Map.fromList $ zip [0..] (map (Map.fromList . zip [0..]) code)
-- |Shift a node by the given amount. May be positive or negative.
-- This is used by 'toGraph' and 'fromGraph' to shift all nodes by 1 or -1, respectively,
-- which is done because the portable text representation of the graph does not include
-- a leading "Start" node with ID 1 -- instead, the node with ID 1 is the first "real"
-- graph node. In other words, when exporting to the text representation, the "Start"
-- node is removed and all other nodes are "shifted" by -1 using this function. When
-- importing, a "Start" node is added and all nodes are shifted by 1.
offset :: Int -- ^Amount to shift node by.
-> IDT.LexNode -- ^Node to operate on.
-> IDT.LexNode -- ^Shifted node.
offset c (node, lexeme, 0) = (node + c, lexeme, 0)
offset c (node, lexeme, following) = (node + c, lexeme, following + c)
-- |Get adjacent (left secondary, primary, right secondary)
-- symbols for the current IP position.
adjacent :: IDT.Grid2D -- ^Line representation of the current function.
-> IP -- ^Current instruction pointer.
-> (Char, Char, Char) -- ^Adjacent (left secondary, primary, right secondary) symbols
adjacent code ip
| current code ip `elem` turnblocked = (' ', charat code (posdir ip Forward), ' ')
| otherwise = (charat code (posdir ip InstructionPointer.Left), charat code (posdir ip Forward), charat code (posdir ip InstructionPointer.Right))
-- |Get the next lexeme at the current position.
parse :: IDT.Grid2D -- ^Line representation of current function.
-> IP -- ^Current instruction pointer.
-> (Maybe IDT.Lexeme, IP) -- ^Resulting lexeme (if any) and
-- the new instruction pointer.
parse code ip = junctioncheck $ case current code ip of
'b' -> (Just Boom, ip)
'e' -> (Just EOF, ip)
'i' -> (Just Input, ip)
'o' -> (Just Output, ip)
'u' -> (Just Underflow, ip)
'?' -> (Just RType, ip)
'a' -> (Just Add1, ip)
'd' -> (Just Divide, ip)
'm' -> (Just Multiply, ip)
'r' -> (Just Remainder, ip)
's' -> (Just Subtract, ip)
'0' -> (Just (Constant "0"), ip)
'1' -> (Just (Constant "1"), ip)
'2' -> (Just (Constant "2"), ip)
'3' -> (Just (Constant "3"), ip)
'4' -> (Just (Constant "4"), ip)
'5' -> (Just (Constant "5"), ip)
'6' -> (Just (Constant "6"), ip)
'7' -> (Just (Constant "7"), ip)
'8' -> (Just (Constant "8"), ip)
'9' -> (Just (Constant "9"), ip)
'c' -> (Just Cut, ip)
'p' -> (Just Append, ip)
'z' -> (Just Size, ip)
'n' -> (Just Nil, ip)
':' -> (Just Cons, ip)
'~' -> (Just Breakup, ip)
'f' -> (Just (Constant "0"), ip)
't' -> (Just (Constant "1"), ip)
'g' -> (Just Greater, ip)
'q' -> (Just Equal, ip)
'$' -> (Just Start, ip)
'#' -> (Just Finish, ip)
'.' -> (Just NOP, ip)
'v' -> (Just (Junction 0), ip)
'^' -> (Just (Junction 0), ip)
'>' -> (Just (Junction 0), ip)
'<' -> (Just (Junction 0), ip)
'&' -> (Just (Lambda 0), ip)
'[' -> let (string, newip) = readconstant code tempip '[' ']' in (Just (Constant string), newip)
']' -> let (string, newip) = readconstant code tempip ']' '[' in (Just (Constant string), newip)
'{' -> let (string, newip) = stepwhile code tempip (/= '}') in (Just (Call $ checkstring string), newip)
'}' -> let (string, newip) = stepwhile code tempip (/= '{') in (Just (Call $ checkstring string), newip)
'(' -> let (string, newip) = stepwhile code tempip (/= ')') in (pushpop string, newip)
')' -> let (string, newip) = stepwhile code tempip (/= '(') in (pushpop string, newip)
_ -> (Nothing, turn (current code ip) ip)
where
junctioncheck (Nothing, ip)
| current code ip `elem` "+x*" && next code ip `elem` "v^<>" = (Nothing, crashfrom ip)
-- | forward == ' ' && (left == current code ip || right == current code ip) = (Nothing, crashfrom ip)
| forward == ' ' && (left `elem` "v^<>+x*" || right `elem` "v^<>+x*") = (Nothing, crashfrom ip)
| otherwise = (Nothing, ip)
where
(left, forward, right) = adjacent code ip
junctioncheck (lexeme, ip)
| next code ip `elem` "v^<>" = (lexeme, crashfrom ip)
| otherwise = (lexeme, ip)
tempip = move ip Forward
checkstring string = if '!' `elem` string then error EH.strInvalidVarName else string
pushpop string
| length string < 2 = Just (Push $ checkstring string)
| head string == '!' && last string == '!' = Just (Pop (checkstring $ tail $ init string))
| otherwise = Just (Push $ checkstring string)
-- |Collect characters until a condition is met while moving in the current direction.
stepwhile :: IDT.Grid2D -- ^Line representation of current function.
-> IP -- ^Current instruction pointer.
-> (Char -> Bool) -- ^Function: Should return True if collection should stop.
-- Gets the current Char as an argument.
-> (String, IP) -- ^Collected characters and the new instruction pointer.
stepwhile code ip fn
| not (fn curchar) = ("", ip)
| not (moveable code ip Forward) = error EH.strMissingClosingBracket
| curchar `elem` "'{}()" = error EH.strInvalidVarName
| otherwise = (curchar:resstring, resip)
where
curchar = current code ip
(resstring, resip) = stepwhile code (move ip Forward) fn
-- |Checks if the instruction pointer can be moved without leaving the grid
moveable :: IDT.Grid2D -- ^Line representation of current function
-> IP -- ^Current instruction pointer
-> RelDirection -- ^Where to move to
-> Bool -- ^Whether or not the move could be made
moveable code ip reldir
| Map.size code == 0 = False
| isNothing (Map.lookup newy code) = False
| dir ip `elem` [W, E] && isNothing (Map.lookup newx line) = False
| otherwise = True
where
(newy, newx) = posdir ip reldir
line = fromJust (Map.lookup newy code)
-- |Read a string constant and handle escape sequences like \n.
-- Raises an error on invalid escape sequences and badly formatted constants.
readconstant :: IDT.Grid2D -- ^Current function in line representation
-> IP -- ^Current instruction pointer
-> Char -- ^Opening string delimiter, e. g. '['
-> Char -- ^Closing string delimiter, e. g. ']'
-> (String, IP) -- ^The processed constant and the new instruction pointer
readconstant code ip startchar endchar
| curchar == startchar = error EH.strNestedOpenBracket
| curchar == endchar = ("", ip)
| not (moveable code ip Forward) = error EH.strMissingClosingBracket
| otherwise = (newchar:resstring, resip)
where
curchar = current code ip
(newchar, newip) = processescape
(resstring, resip) = readconstant code newip startchar endchar
-- This does the actual work and converts the escape sequence
-- (if there is no escape sequence at the current position, do
-- nothing and pass the current Char through).
processescape :: (Char, IP)
processescape
| curchar /= '\\' = (curchar, move ip Forward)
| curchar == '\\' && escsym == '\\' = ('\\', skip code ip 2)
| esctrail /= '\\' = error EH.strNonSymmetricEscape
| otherwise = case escsym of
'[' -> ('[', escip)
']' -> (']', escip)
'n' -> ('\n', escip)
't' -> ('\t', escip)
_ -> error $ printf EH.strUnhandledEscape escsym
where
[escsym, esctrail] = lookahead code ip 2
-- Points to the character after the trailing backslash
escip = skip code ip 3
escapestring :: String -> String
escapestring [] = []
escapestring (x:xs) = newx ++ escapestring xs
where
newx = case x of
'\\' -> "\\\\"
'\n' -> "\\n\\"
'[' -> "\\[\\"
']' -> "\\]\\"
'\t' -> "\\t\\"
_ -> [x]
-- |Lookahead n characters in the current direction.
lookahead :: IDT.Grid2D -- ^Line representation of current function
-> IP -- ^Current instruction pointer
-> Int -- ^How many characters of lookahead to produce?
-> String -- ^n characters of lookahead
lookahead code ip 0 = []
lookahead code ip n = current code newip : lookahead code newip (n-1)
where
newip = move ip Forward
-- |Skip n characters in the current direction and return the new IP.
skip :: IDT.Grid2D -- ^Line representation of current function
-> IP -- ^Current instruction pointer
-> Int -- ^How many characters to skip? If 1, this is the same
-- as doing "move ip Forward".
-> IP -- ^New instruction pointer
skip code ip n = foldl (\x _ -> move x Forward) ip [1..n]
-- |Get the 'Char' at the next position of the instruction pointer
next :: IDT.Grid2D -> IP -> Char
next code ip = current code $ move ip Forward
-- |Return valid chars for movement depending on the current direction.
valids :: IDT.Grid2D -- ^Line representation of current function.
-> IP -- ^Current instruction pointer.
-> (String, String, String) -- ^Tuple consisting of:
--
-- * Valid characters for movement to the (relative) left.
-- * Valid characters for movement in the (relative) forward direction.
-- * Valid characters for movement to the (relative) right.
valids code ip = tripleinvert (secinv code ip InstructionPointer.Left, finvalid ip, secinv code ip InstructionPointer.Right)
where
secinv code ip direction = [current code ip] ++ commandchars ++ dirinvalid ip ++ finvalid ip{dir = absolute ip direction}
tripleinvert (l, f, r) = (filter (`notElem` l) everything, filter (`notElem` f) everything, filter (`notElem` r) everything)
finvalid ip = dirinvalid ip ++ crossinvalid ip -- illegal to move forward
dirinvalid ip -- illegal without crosses
| dir ip `elem` [E, W] = "|"
| dir ip `elem` [NE, SW] = "\\"
| dir ip `elem` [N, S] = "-"
| dir ip `elem` [NW, SE] = "/"
| otherwise = ""
crossinvalid ip -- illegal crosses
| dir ip `elem` [N, E, S, W] = "x"
| otherwise = "+"
cur = current code ip
everything = "+\\/x|-" ++ always
always = "^v<>*@{}[]()" ++ commandchars
-- list of chars that are commands in rail
commandchars :: String
commandchars = "abcdefgimnopqrstuz:~0123456789?#&"
-- list of chars which do not allow any turning
turnblocked :: String
turnblocked = "$*+x" ++ commandchars
-- vim:ts=2 sw=2 et