summaryrefslogtreecommitdiff
path: root/src/Transfer/Syntax/Layout.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-26 21:05:50 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-26 21:05:50 +0000
commita1da4b7c4808b3da1a0dba5a85b5e35134d9222c (patch)
treee4210dc3161ffa1114ad77431458a7a4b1529956 /src/Transfer/Syntax/Layout.hs
parentfb1d9b7d2c3c8261fc5a2ce3698e6749458b207a (diff)
removed Transfer interpreter
Diffstat (limited to 'src/Transfer/Syntax/Layout.hs')
-rw-r--r--src/Transfer/Syntax/Layout.hs227
1 files changed, 0 insertions, 227 deletions
diff --git a/src/Transfer/Syntax/Layout.hs b/src/Transfer/Syntax/Layout.hs
deleted file mode 100644
index de5c99870..000000000
--- a/src/Transfer/Syntax/Layout.hs
+++ /dev/null
@@ -1,227 +0,0 @@
-module Transfer.Syntax.Layout where
-
-import Transfer.Syntax.Lex
-
-
-import Data.Maybe (isNothing, fromJust)
-
--- Generated by the BNF Converter
-
--- local parameters
-
-topLayout = True
-layoutWords = ["let","where","of","rec","sig","do"]
-layoutStopWords = ["in"]
-
--- layout separators
-
-layoutOpen = "{"
-layoutClose = "}"
-layoutSep = ";"
-
--- | Replace layout syntax with explicit layout tokens.
-resolveLayout :: Bool -- ^ Whether to use top-level layout.
- -> [Token] -> [Token]
-resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]
- where
- -- Do top-level layout if the function parameter and the grammar say so.
- tl = tp && topLayout
-
- res :: Maybe Token -- ^ The previous token, if any.
- -> [Block] -- ^ A stack of layout blocks.
- -> [Token] -> [Token]
-
- -- The stack should never be empty.
- res _ [] ts = error $ "Layout error: stack empty. Tokens: " ++ show ts
-
- res _ st (t0:ts)
- -- We found an open brace in the input,
- -- put an explicit layout block on the stack.
- -- This is done even if there was no layout word,
- -- to keep opening and closing braces.
- | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts
-
- res _ st (t0:ts)
- -- Start a new layout block if the first token is a layout word
- | isLayout t0 =
- case ts of
- -- Explicit layout, just move on. The case above
- -- will push an explicit layout block.
- t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts
- -- at end of file, the start column doesn't matter
- _ -> let col = if null ts then column t0 else column (head ts)
- -- insert an open brace after the layout word
- b:ts' = addToken (nextPos t0) layoutOpen ts
- -- save the start column
- st' = Implicit col:st
- in moveAlong st' [t0,b] ts'
-
- -- If we encounter a closing brace, exit the first explicit layout block.
- | isLayoutClose t0 =
- let st' = drop 1 (dropWhile isImplicit st)
- in if null st'
- then error $ "Layout error: Found " ++ layoutClose ++ " at ("
- ++ show (line t0) ++ "," ++ show (column t0)
- ++ ") without an explicit layout block."
- else moveAlong st' [t0] ts
-
- -- We are in an implicit layout block
- res pt st@(Implicit n:ns) (t0:ts)
-
- -- End of implicit block by a layout stop word
- | isStop t0 =
- -- Exit the current block and all implicit blocks
- -- more indented than the current token
- let (ebs,ns') = span (`moreIndent` column t0) ns
- moreIndent (Implicit x) y = x > y
- moreIndent Explicit _ = False
- -- the number of blocks exited
- b = 1 + length ebs
- bs = replicate b layoutClose
- -- Insert closing braces after the previous token.
- (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)
- in moveAlong ns' ts1 ts2
-
- -- End of an implicit layout block
- | newLine && column t0 < n =
- -- Insert a closing brace after the previous token.
- let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)
- -- Repeat, with the current block removed from the stack
- in moveAlong ns [b] (t0':ts')
-
- -- Encounted a new line in an implicit layout block.
- | newLine && column t0 == n =
- -- Insert a semicolon after the previous token.
- -- unless we are the beginning of the file,
- -- or the previous token is a semicolon or open brace.
- if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt)
- then moveAlong st [t0] ts
- else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)
- in moveAlong st [b,t0'] ts'
- where newLine = case pt of
- Nothing -> True
- Just t -> line t /= line t0
-
- -- Nothing to see here, move along.
- res _ st (t:ts) = moveAlong st [t] ts
-
- -- At EOF: skip explicit blocks.
- res (Just t) (Explicit:bs) [] | null bs = []
- | otherwise = res (Just t) bs []
-
- -- If we are using top-level layout, insert a semicolon after
- -- the last token, if there isn't one already
- res (Just t) [Implicit n] []
- | isTokenIn [layoutSep] t = []
- | otherwise = addToken (nextPos t) layoutSep []
-
- -- At EOF in an implicit, non-top-level block: close the block
- res (Just t) (Implicit n:bs) [] =
- let c = addToken (nextPos t) layoutClose []
- in moveAlong bs c []
-
- -- This should only happen if the input is empty.
- res Nothing st [] = []
-
- -- | Move on to the next token.
- moveAlong :: [Block] -- ^ The layout stack.
- -> [Token] -- ^ Any tokens just processed.
- -> [Token] -- ^ the rest of the tokens.
- -> [Token]
- moveAlong st [] ts = error $ "Layout error: moveAlong got [] as old tokens"
- moveAlong st ot ts = ot ++ res (Just $ last ot) st ts
-
-data Block = Implicit Int -- ^ An implicit layout block with its start column.
- | Explicit
- deriving Show
-
-type Position = Posn
-
--- | Check if s block is implicit.
-isImplicit :: Block -> Bool
-isImplicit (Implicit _) = True
-isImplicit _ = False
-
--- | Insert a number of tokens at the begninning of a list of tokens.
-addTokens :: Position -- ^ Position of the first new token.
- -> [String] -- ^ Token symbols.
- -> [Token] -- ^ The rest of the tokens. These will have their
- -- positions updated to make room for the new tokens .
- -> [Token]
-addTokens p ss ts = foldr (addToken p) ts ss
-
--- | Insert a new symbol token at the begninning of a list of tokens.
-addToken :: Position -- ^ Position of the new token.
- -> String -- ^ Symbol in the new token.
- -> [Token] -- ^ The rest of the tokens. These will have their
- -- positions updated to make room for the new token.
- -> [Token]
-addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts
-
--- | Get the position immediately to the right of the given token.
--- If no token is given, gets the first position in the file.
-afterPrev :: Maybe Token -> Position
-afterPrev = maybe (Pn 0 1 1) nextPos
-
--- | Get the position immediately to the right of the given token.
-nextPos :: Token -> Position
-nextPos t = Pn (g + s) l (c + s + 1)
- where Pn g l c = position t
- s = tokenLength t
-
--- | Add to the global and column positions of a token.
--- The column position is only changed if the token is on
--- the same line as the given position.
-incrGlobal :: Position -- ^ If the token is on the same line
- -- as this position, update the column position.
- -> Int -- ^ Number of characters to add to the position.
- -> Token -> Token
-incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =
- if l /= l0 then PT (Pn (g + i) l c) t
- else PT (Pn (g + i) l (c + i)) t
-incrGlobal _ _ p = error $ "cannot add token at " ++ show p
-
--- | Create a symbol token.
-sToken :: Position -> String -> Token
-sToken p s = PT p (TS s) -- reserved word or symbol
-
--- | Get the position of a token.
-position :: Token -> Position
-position t = case t of
- PT p _ -> p
- Err p -> p
-
--- | Get the line number of a token.
-line :: Token -> Int
-line t = case position t of Pn _ l _ -> l
-
--- | Get the column number of a token.
-column :: Token -> Int
-column t = case position t of Pn _ _ c -> c
-
--- | Check if a token is one of the given symbols.
-isTokenIn :: [String] -> Token -> Bool
-isTokenIn ts t = case t of
- PT _ (TS r) | elem r ts -> True
- _ -> False
-
--- | Check if a word is a layout start token.
-isLayout :: Token -> Bool
-isLayout = isTokenIn layoutWords
-
--- | Check if a token is a layout stop token.
-isStop :: Token -> Bool
-isStop = isTokenIn layoutStopWords
-
--- | Check if a token is the layout open token.
-isLayoutOpen :: Token -> Bool
-isLayoutOpen = isTokenIn [layoutOpen]
-
--- | Check if a token is the layout close token.
-isLayoutClose :: Token -> Bool
-isLayoutClose = isTokenIn [layoutClose]
-
--- | Get the number of characters in the token.
-tokenLength :: Token -> Int
-tokenLength t = length $ prToken t
-