{-# Language BlockArguments #-}
{-# Language OverloadedStrings #-}
module Cryptol.Parser.Layout where

import Cryptol.Utils.Panic(panic)
import Cryptol.Parser.Position
import Cryptol.Parser.Token

{-

We assume the existence of an explicit EOF token at the end of the input.  This token is *less* indented
than all other tokens (i.e., it is at column 0)

Explicit Layout Blocks

  * The symbols `(`, `{`, and `[` start an explicit layout block.
  * While in an explicit layout block we pass through tokens, except:
      - We may start new implicit or explicit layout blocks
      - A `,` terminates any *nested* layout blocks
      - We terminate the current layout block if we encounter the matching
        closing symbol `)`, `}`, `]`

Implicit Layout Blocks

  * The keywords `where`, `private`, and `parameter` start an implicit
    layout block.
  * The layout block starts at the column of the *following* token and we
    insert "virtual start block" between the current and the following tokens.
  * While in an implicit layout block:
    - We may start new implicit or explicit layout blocks
    - We insert a "virtual separator" before tokens starting at the same
      column as the layout block, EXCEPT:
        * we do not insert a separator if the previous token was a
          "documentation comment"
        * we do not insert a separator before the first token in the block

    - The implicit layout block is ended by:
          * a token than is less indented that the block, or
          * `)`, `}`, `]`, or
          * ',' but only if there is an outer paren block
          block's column.
    - When an implicit layout block ends, we insert a "virtual end block"
      token just before the token that caused the block to end.

Examples:

f = x where x = 0x1         -- end implicit layout by layout
g = 0x3                     -- (`g` is less indented than `x`)

f (x where x = 2)           -- end implicit layout by `)`

[ x where x = 2, 3 ]        -- end implicit layout by `,`

module A where              -- two implicit layout blocks with the
private                     -- *same* indentation (`where` and `private`)
x = 0x2
-}


layout :: Bool -> [Located Token] -> [Located Token]
layout :: Bool -> [Located Token] -> [Located Token]
layout Bool
isMod [Located Token]
ts0

  -- Star an implicit layout block at the top of the module
  | let t :: Located Token
t         = [Located Token] -> Located Token
forall a. [a] -> a
head [Located Token]
ts0
        rng :: Range
rng       = Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
t
        blockCol :: Int
blockCol  = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Position -> Int
col (Range -> Position
from Range
rng)) -- see startImplicitBlock
  , Bool
isMod Bool -> Bool -> Bool
&& Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
t) TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
/= TokenKW -> TokenT
KW TokenKW
KW_module =
    Range -> TokenV -> Located Token
virt Range
rng TokenV
VCurlyL Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [ Int -> Block
Virtual Int
blockCol ] Int
blockCol Bool
True [Located Token]
ts0

  | Bool
otherwise =
    [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [] Int
0 Bool
False [Located Token]
ts0

  where

  {- State parameters for `go`:

       stack:
          The stack of implicit and explicit blocks

       lastVirt:
          The indentation of the outer most implicit block, or 0 if none.
          This can be computed from the stack but we cache
          it here as we need to check it on each token.

       noVirtSep:
          Do not emit a virtual separator even if token matches block alignment.
          This is enabled at the beginning of a block, or after a doc string,
          or if we just emitted a separtor, but have not yet consumed the
          next token.

       tokens:
          remaining tokens to process
  -}

  go :: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [Block]
stack Int
lastVirt Bool
noVirtSep [Located Token]
tokens

    -- End implicit layout due to indentation.  If the outermost block
    -- is a lyout block we just end it.   If the outermost block is an
    -- explicit layout block we report a lexical error.
    | Position -> Int
col Position
curLoc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
lastVirt =
      [Located Token]
endImplictBlock

    -- End implicit layout block due to a symbol
    | Just (Virtual {}) <- Maybe Block
curBlock, TokenT -> Bool
endsLayout TokenT
curTokTy =
      [Located Token]
endImplictBlock

    -- End implicit layout block due to a comma
    | Just (Virtual {}) <- Maybe Block
curBlock
    , Sym TokenSym
Comma <- TokenT
curTokTy
    , Bool -> Bool
not ([()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ () | Explicit TokenT
_ <- [Block]
popStack ]) =
      [Located Token]
endImplictBlock

    -- Insert a virtual separator
    | Just (Virtual {}) <- Maybe Block
curBlock
    , Position -> Int
col Position
curLoc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lastVirt Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
noVirtSep =
      Range -> TokenV -> Located Token
virt Range
curRange TokenV
VSemi Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [Block]
stack Int
lastVirt Bool
True [Located Token]
tokens

    -- Start a new implicit layout. Advances token position.
    | TokenT -> Bool
startsLayout TokenT
curTokTy = [Located Token]
startImplicitBlock

    -- Start a paren block.  Advances token position
    | Just TokenT
close <- TokenT -> Maybe TokenT
startsParenBlock TokenT
curTokTy =
      Located Token
curTok Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go (TokenT -> Block
Explicit TokenT
close Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
stack) Int
lastVirt Bool
False [Located Token]
advanceTokens

    -- End a paren block. Advances token position
    | Just (Explicit TokenT
close) <- Maybe Block
curBlock, TokenT
close TokenT -> TokenT -> Bool
forall a. Eq a => a -> a -> Bool
== TokenT
curTokTy =
      Located Token
curTok Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [Block]
popStack Int
lastVirt Bool
False [Located Token]
advanceTokens

    -- Disable virtual separator after doc string. Advances token position
    | White TokenW
DocStr <- TokenT
curTokTy =
      Located Token
curTok Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [Block]
stack Int
lastVirt Bool
True [Located Token]
advanceTokens

    -- Check to see if we are done.  Note that if we got here, implicit layout
    -- blocks should have already been closed, as `EOF` is less indented than
    -- all other tokens
    | TokenT
EOF <- TokenT
curTokTy =
      [Located Token
curTok]

    -- Any other token, just emit.  Advances token position
    | Bool
otherwise =
      Located Token
curTok Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [Block]
stack Int
lastVirt Bool
False [Located Token]
advanceTokens

    where
    (Located Token
curTok, [Located Token]
advanceTokens) = case [Located Token]
tokens of
                                (curTok' : advanceTokens') -> (Located Token
curTok', [Located Token]
advanceTokens')
                                [] -> [Char] -> (Located Token, [Located Token])
forall a. HasCallStack => [Char] -> a
error [Char]
"layout: Unexpected empty list of tokens"
    curTokTy :: TokenT
curTokTy               = Token -> TokenT
tokenType (Located Token -> Token
forall a. Located a -> a
thing Located Token
curTok)
    curRange :: Range
curRange               = Located Token -> Range
forall a. Located a -> Range
srcRange Located Token
curTok
    curLoc :: Position
curLoc                 = Range -> Position
from Range
curRange

    (Maybe Block
curBlock,[Block]
popStack) =
      case [Block]
stack of
        a : b -> (Block -> Maybe Block
forall a. a -> Maybe a
Just Block
a,[Block]
b)
        []    -> (Maybe Block
forall a. Maybe a
Nothing, [Char] -> [[Char]] -> [Block]
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"layout" [[Char]
"pop empty stack"])


    startImplicitBlock :: [Located Token]
startImplicitBlock =
      let nextRng :: Range
nextRng  = Located Token -> Range
forall a. Located a -> Range
srcRange ([Located Token] -> Located Token
forall a. [a] -> a
head [Located Token]
advanceTokens)
          nextLoc :: Position
nextLoc  = Range -> Position
from Range
nextRng
          blockCol :: Int
blockCol = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Position -> Int
col Position
nextLoc)
          -- the `max` ensuraes that indentation is always at least 1,
          -- in case we are starting a block at the very end of the input

      in Located Token
curTok
       Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: Range -> TokenV -> Located Token
virt Range
nextRng TokenV
VCurlyL
       Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go (Int -> Block
Virtual Int
blockCol Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
stack) Int
blockCol Bool
True [Located Token]
advanceTokens


    endImplictBlock :: [Located Token]
endImplictBlock =
      case Maybe Block
curBlock of
        Just (Virtual {}) ->
           Range -> TokenV -> Located Token
virt Range
curRange TokenV
VCurlyR
           Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Block] -> Int -> Bool -> [Located Token] -> [Located Token]
go [Block]
popStack Int
newVirt Bool
False [Located Token]
tokens
          where newVirt :: Int
newVirt = case [ Int
n | Virtual n <- [Block]
popStack ] of
                            Int
n : [Int]
_ -> Int
n
                            [Int]
_     -> Int
0

        Just (Explicit c) ->
          Range -> TokenErr -> Located Token
errTok Range
curRange (TokenT -> TokenErr
InvalidIndentation TokenT
c) Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Located Token]
advanceTokens

        Maybe Block
Nothing -> [Char] -> [[Char]] -> [Located Token]
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"layout" [[Char]
"endImplictBlock with empty stack"]


--------------------------------------------------------------------------------

data Block =
    Virtual Int     -- ^ Virtual layout block
  | Explicit TokenT -- ^ An explicit layout block, expecting this ending token.
    deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> [Char]
(Int -> Block -> ShowS)
-> (Block -> [Char]) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> [Char]
$cshow :: Block -> [Char]
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show)

-- | These tokens start an implicit layout block
startsLayout :: TokenT -> Bool
startsLayout :: TokenT -> Bool
startsLayout TokenT
ty =
  case TokenT
ty of
    KW TokenKW
KW_where       -> Bool
True
    KW TokenKW
KW_private     -> Bool
True
    KW TokenKW
KW_parameter   -> Bool
True
    TokenT
_                 -> Bool
False

-- | These tokens end an implicit layout block
endsLayout :: TokenT -> Bool
endsLayout :: TokenT -> Bool
endsLayout TokenT
ty =
  case TokenT
ty of
    Sym TokenSym
BracketR -> Bool
True
    Sym TokenSym
ParenR   -> Bool
True
    Sym TokenSym
CurlyR   -> Bool
True
    TokenT
_            -> Bool
False

-- | These tokens start an explicit "paren" layout block.
-- If so, the result contains the corresponding closing paren.
startsParenBlock :: TokenT -> Maybe TokenT
startsParenBlock :: TokenT -> Maybe TokenT
startsParenBlock TokenT
ty =
  case TokenT
ty of
    Sym TokenSym
BracketL -> TokenT -> Maybe TokenT
forall a. a -> Maybe a
Just (TokenSym -> TokenT
Sym TokenSym
BracketR)
    Sym TokenSym
ParenL   -> TokenT -> Maybe TokenT
forall a. a -> Maybe a
Just (TokenSym -> TokenT
Sym TokenSym
ParenR)
    Sym TokenSym
CurlyL   -> TokenT -> Maybe TokenT
forall a. a -> Maybe a
Just (TokenSym -> TokenT
Sym TokenSym
CurlyR)
    TokenT
_            -> Maybe TokenT
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------

-- | Make a virtual token of the given type
virt :: Range -> TokenV -> Located Token
virt :: Range -> TokenV -> Located Token
virt Range
rng TokenV
x = Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
rng { to :: Position
to = Range -> Position
from Range
rng }, thing :: Token
thing = Token
t }
  where
  t :: Token
t = TokenT -> Text -> Token
Token (TokenV -> TokenT
Virt TokenV
x)
      case TokenV
x of
        TokenV
VCurlyL -> Text
"beginning of layout block"
        TokenV
VCurlyR -> Text
"end of layout block"
        TokenV
VSemi   -> Text
"layout block separator"

errTok :: Range -> TokenErr -> Located Token
errTok :: Range -> TokenErr -> Located Token
errTok Range
rng TokenErr
x = Located :: forall a. Range -> a -> Located a
Located { srcRange :: Range
srcRange = Range
rng { to :: Position
to = Range -> Position
from Range
rng }, thing :: Token
thing = Token
t }
  where
  t :: Token
t = Token :: TokenT -> Text -> Token
Token { tokenType :: TokenT
tokenType = TokenErr -> TokenT
Err TokenErr
x, tokenText :: Text
tokenText = Text
"" }