Move transfer into the GF repo.

src/Transfer/Syntax/Layout.hs

@@ -0,0 +1,205 @@
+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"]
+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 of 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 an implicit layout block
+    | isStop t0 || column t0 < n  = 
+           -- Insert a closing brace before the current token.
+       let b:t0':ts' = addToken (position t0) layoutClose (t0:ts)
+           -- Exit the current block and all implicit blocks 
+           -- such that the current token is less indented than them.
+           st' = dropWhile (isLessIndentedThan t0) ns
+        in moveAlong st' [b,t0'] ts'
+
+    -- Encounted a new line in an implicit layout block.
+    | column t0 == n = 
+       -- Insert a semicolon before the start of the next line, 
+       -- 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 (position t0) layoutSep (t0:ts)
+                in moveAlong st [b,t0'] ts'
+
+  -- Nothing to see here, move along.
+  res _ st (t:ts)  = moveAlong st [t] ts
+
+  -- We are at EOF, close all open implicit non-top-level layout blocks.
+  res (Just t) st [] = 
+        addTokens (position t) [layoutClose | Implicit n <- st, 
+                                              not (tl && n == 1)] []
+
+  -- 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
+
+-- | Checks if the given token is less indented than the given
+--   block. For explicit blocks, False is always returned.
+isLessIndentedThan :: Token -> Block -> Bool
+isLessIndentedThan t (Implicit n) = column t < n
+isLessIndentedThan _ Explicit = 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.
+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
+