diff options
Diffstat (limited to 'src/Transfer/Syntax/Layout.hs')
| -rw-r--r-- | src/Transfer/Syntax/Layout.hs | 227 |
1 files changed, 227 insertions, 0 deletions
diff --git a/src/Transfer/Syntax/Layout.hs b/src/Transfer/Syntax/Layout.hs new file mode 100644 index 000000000..de5c99870 --- /dev/null +++ b/src/Transfer/Syntax/Layout.hs @@ -0,0 +1,227 @@ +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 + |