{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Jikka.Common.Parse.OffsideRule
  ( insertIndents,
  )
where

import Jikka.Common.Error
import Jikka.Common.Location

splitToLines :: forall a. (a -> Bool) -> [WithLoc a] -> [[WithLoc a]]
splitToLines :: (a -> Bool) -> [WithLoc a] -> [[WithLoc a]]
splitToLines a -> Bool
isNewline = [WithLoc a] -> [WithLoc a] -> [[WithLoc a]]
go []
  where
    go :: [WithLoc a] -> [WithLoc a] -> [[WithLoc a]]
    go :: [WithLoc a] -> [WithLoc a] -> [[WithLoc a]]
go [] [] = []
    go [WithLoc a]
acc [] = [[WithLoc a] -> [WithLoc a]
forall a. [a] -> [a]
reverse [WithLoc a]
acc]
    go [WithLoc a]
acc (WithLoc a
token : [WithLoc a]
tokens)
      | a -> Bool
isNewline (WithLoc a -> a
forall a. WithLoc a -> a
value WithLoc a
token) = [WithLoc a] -> [WithLoc a]
forall a. [a] -> [a]
reverse (WithLoc a
token WithLoc a -> [WithLoc a] -> [WithLoc a]
forall a. a -> [a] -> [a]
: [WithLoc a]
acc) [WithLoc a] -> [[WithLoc a]] -> [[WithLoc a]]
forall a. a -> [a] -> [a]
: [WithLoc a] -> [WithLoc a] -> [[WithLoc a]]
go [] [WithLoc a]
tokens
      | Bool
otherwise = [WithLoc a] -> [WithLoc a] -> [[WithLoc a]]
go (WithLoc a
token WithLoc a -> [WithLoc a] -> [WithLoc a]
forall a. a -> [a] -> [a]
: [WithLoc a]
acc) [WithLoc a]
tokens

insertIndents' :: forall m a. (MonadError Error m, Show a) => a -> a -> [[WithLoc a]] -> m [WithLoc a]
insertIndents' :: a -> a -> [[WithLoc a]] -> m [WithLoc a]
insertIndents' a
indent a
dedent = [Int] -> [[WithLoc a]] -> m [WithLoc a]
go [Int
1]
  where
    go :: [Int] -> [[WithLoc a]] -> m [WithLoc a]
    go :: [Int] -> [[WithLoc a]] -> m [WithLoc a]
go [Int]
stk [[WithLoc a]]
tokens = case ([Int]
stk, [[WithLoc a]]
tokens) of
      ([Int
1], []) -> [WithLoc a] -> m [WithLoc a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      (Int
_ : [Int]
stk, []) -> (Loc -> a -> WithLoc a
forall a. Loc -> a -> WithLoc a
WithLoc (Int -> Int -> Int -> Loc
Loc Int
0 Int
1 Int
0) a
dedent WithLoc a -> [WithLoc a] -> [WithLoc a]
forall a. a -> [a] -> [a]
:) ([WithLoc a] -> [WithLoc a]) -> m [WithLoc a] -> m [WithLoc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [[WithLoc a]] -> m [WithLoc a]
go [Int]
stk []
      ([Int]
_, [] : [[WithLoc a]]
_) -> String -> m [WithLoc a]
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError String
"a line must be non-empty"
      ([Int]
_, (WithLoc a
token : [WithLoc a]
_) : [[WithLoc a]]
_) | Loc -> Int
column (WithLoc a -> Loc
forall a. WithLoc a -> Loc
loc WithLoc a
token) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> String -> m [WithLoc a]
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError (String -> m [WithLoc a]) -> String -> m [WithLoc a]
forall a b. (a -> b) -> a -> b
$ String
"column must be 1-based for insertIndents': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ WithLoc a -> String
forall a. Show a => a -> String
show WithLoc a
token
      ([], [[WithLoc a]]
_) -> String -> m [WithLoc a]
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError String
"too many dedents"
      (Int
x : [Int]
stk, line :: [WithLoc a]
line@(WithLoc a
token : [WithLoc a]
_) : [[WithLoc a]]
tokens') -> case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
x (Loc -> Int
column (WithLoc a -> Loc
forall a. WithLoc a -> Loc
loc WithLoc a
token)) of
        Ordering
LT -> (Loc -> a -> WithLoc a
withLoc (WithLoc a -> Loc
forall a. WithLoc a -> Loc
loc WithLoc a
token) a
indent WithLoc a -> [WithLoc a] -> [WithLoc a]
forall a. a -> [a] -> [a]
:) ([WithLoc a] -> [WithLoc a])
-> ([WithLoc a] -> [WithLoc a]) -> [WithLoc a] -> [WithLoc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([WithLoc a]
line [WithLoc a] -> [WithLoc a] -> [WithLoc a]
forall a. [a] -> [a] -> [a]
++) ([WithLoc a] -> [WithLoc a]) -> m [WithLoc a] -> m [WithLoc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [[WithLoc a]] -> m [WithLoc a]
go (Loc -> Int
column (WithLoc a -> Loc
forall a. WithLoc a -> Loc
loc WithLoc a
token) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int
x Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
stk) [[WithLoc a]]
tokens'
        Ordering
EQ -> ([WithLoc a]
line [WithLoc a] -> [WithLoc a] -> [WithLoc a]
forall a. [a] -> [a] -> [a]
++) ([WithLoc a] -> [WithLoc a]) -> m [WithLoc a] -> m [WithLoc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [[WithLoc a]] -> m [WithLoc a]
go (Int
x Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
stk) [[WithLoc a]]
tokens'
        Ordering
GT -> case [Int]
stk of
          [] -> String -> m [WithLoc a]
forall (m :: * -> *) a. MonadError Error m => String -> m a
throwInternalError String
"too many dedents"
          (Int
x' : [Int]
_)
            | Int
x' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Loc -> Int
column (WithLoc a -> Loc
forall a. WithLoc a -> Loc
loc WithLoc a
token) -> Loc -> String -> m [WithLoc a]
forall (m :: * -> *) a. MonadError Error m => Loc -> String -> m a
throwLexicalErrorAt (WithLoc a -> Loc
forall a. WithLoc a -> Loc
loc WithLoc a
token) (String -> m [WithLoc a]) -> String -> m [WithLoc a]
forall a b. (a -> b) -> a -> b
$ String
"unindent does not match any outer indentation level: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ WithLoc a -> String
forall a. Show a => a -> String
show WithLoc a
token
            | Bool
otherwise -> (Loc -> a -> WithLoc a
withLoc (WithLoc a -> Loc
forall a. WithLoc a -> Loc
loc WithLoc a
token) a
dedent WithLoc a -> [WithLoc a] -> [WithLoc a]
forall a. a -> [a] -> [a]
:) ([WithLoc a] -> [WithLoc a]) -> m [WithLoc a] -> m [WithLoc a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> [[WithLoc a]] -> m [WithLoc a]
go [Int]
stk ([WithLoc a]
line [WithLoc a] -> [[WithLoc a]] -> [[WithLoc a]]
forall a. a -> [a] -> [a]
: [[WithLoc a]]
tokens')
    withLoc :: Loc -> a -> WithLoc a
    withLoc :: Loc -> a -> WithLoc a
withLoc (Loc Int
y Int
x Int
_) a
a = Loc -> a -> WithLoc a
forall a. Loc -> a -> WithLoc a
WithLoc (Int -> Int -> Int -> Loc
Loc Int
y Int
x Int
0) a
a

-- | `insertIndents` inserts @INDENT@ and @DEDENT@ tokens with Python's way (<https://docs.python.org/3/reference/lexical_analysis.html#indentation>). The `column` of `Loc` must be 1-based. This doen't use physical `line` of `Loc` because logical lines are used for indentation.
insertIndents :: forall m a. (MonadError Error m, Show a) => a -> a -> (a -> Bool) -> [WithLoc a] -> m [WithLoc a]
insertIndents :: a -> a -> (a -> Bool) -> [WithLoc a] -> m [WithLoc a]
insertIndents a
indent a
dedent a -> Bool
isNewline [WithLoc a]
tokens = String -> m [WithLoc a] -> m [WithLoc a]
forall (m :: * -> *) a. MonadError Error m => String -> m a -> m a
wrapError' String
"Jikka.Common.Parse.OffsideRule failed" (m [WithLoc a] -> m [WithLoc a]) -> m [WithLoc a] -> m [WithLoc a]
forall a b. (a -> b) -> a -> b
$ do
  let lines :: [[WithLoc a]]
lines = (a -> Bool) -> [WithLoc a] -> [[WithLoc a]]
forall a. (a -> Bool) -> [WithLoc a] -> [[WithLoc a]]
splitToLines a -> Bool
isNewline [WithLoc a]
tokens
  a -> a -> [[WithLoc a]] -> m [WithLoc a]
forall (m :: * -> *) a.
(MonadError Error m, Show a) =>
a -> a -> [[WithLoc a]] -> m [WithLoc a]
insertIndents' a
indent a
dedent [[WithLoc a]]
lines