{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.Rzk.Syntax.Layout where
import Prelude
import Data.Maybe ( fromMaybe, listToMaybe, mapMaybe )
import qualified Data.List as List
import Language.Rzk.Syntax.Lex
( Posn(..), Tok(..), Token(..), TokSymbol(..)
, prToken, tokenLineCol, tokenPos, tokenPosn
)
data LayoutDelimiters
= LayoutDelimiters
{ LayoutDelimiters -> TokSymbol
delimSep :: TokSymbol
, LayoutDelimiters -> Maybe TokSymbol
delimOpen :: Maybe TokSymbol
, LayoutDelimiters -> Maybe TokSymbol
delimClose :: Maybe TokSymbol
}
layoutWords :: [(TokSymbol, LayoutDelimiters)]
layoutWords :: [(TokSymbol, LayoutDelimiters)]
layoutWords = []
layoutStopWords :: [TokSymbol]
layoutStopWords :: [TokSymbol]
layoutStopWords = []
layoutOpen, layoutClose, layoutSep :: [TokSymbol]
layoutOpen :: [TokSymbol]
layoutOpen = forall a. Eq a => [a] -> [a]
List.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (LayoutDelimiters -> Maybe TokSymbol
delimOpen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(TokSymbol, LayoutDelimiters)]
layoutWords
layoutClose :: [TokSymbol]
layoutClose = forall a. Eq a => [a] -> [a]
List.nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (LayoutDelimiters -> Maybe TokSymbol
delimClose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(TokSymbol, LayoutDelimiters)]
layoutWords
layoutSep :: [TokSymbol]
layoutSep = forall a. Eq a => [a] -> [a]
List.nub forall a b. (a -> b) -> a -> b
$ String -> Line -> TokSymbol
TokSymbol String
";" Line
24 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (LayoutDelimiters -> TokSymbol
delimSep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(TokSymbol, LayoutDelimiters)]
layoutWords
parenOpen, parenClose :: [TokSymbol]
parenOpen :: [TokSymbol]
parenOpen =
[ String -> Line -> TokSymbol
TokSymbol String
"(" Line
11
, String -> Line -> TokSymbol
TokSymbol String
"[" Line
37
]
parenClose :: [TokSymbol]
parenClose =
[ String -> Line -> TokSymbol
TokSymbol String
")" Line
12
, String -> Line -> TokSymbol
TokSymbol String
"]" Line
40
]
layoutError
:: [Token]
-> String
-> a
layoutError :: forall a. [Token] -> String -> a
layoutError [Token]
ts String
msg
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
ts = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Layout error: ", String
msg, String
"." ]
| Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"Layout error at ", [Token] -> String
tokenPos [Token]
ts, String
": ", String
msg, String
"." ]
, [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ String
"Remaining tokens:" ]
, forall a b. (a -> b) -> [a] -> [b]
map Token -> String
prToken forall a b. (a -> b) -> a -> b
$ forall a. Line -> [a] -> [a]
take Line
10 [Token]
ts
, [ String
"..." | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. Line -> [a] -> [a]
drop Line
10 [Token]
ts ]
]
]
resolveLayout
:: Bool
-> [Token]
-> [Token]
resolveLayout :: Bool -> [Token] -> [Token]
resolveLayout Bool
topLayout =
Maybe Token -> [Block] -> [Token] -> [Token]
res forall a. Maybe a
Nothing [if Bool
topLayout then LayoutDelimiters -> Status -> Line -> Block
Implicit LayoutDelimiters
topDelim Status
Definitive Line
1 else Block
Explicit]
where
topDelim :: LayoutDelimiters
topDelim :: LayoutDelimiters
topDelim = TokSymbol -> Maybe TokSymbol -> Maybe TokSymbol -> LayoutDelimiters
LayoutDelimiters (String -> Line -> TokSymbol
TokSymbol String
";" Line
24) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
res :: Maybe Token
-> [Block]
-> [Token] -> [Token]
res :: Maybe Token -> [Block] -> [Token] -> [Token]
res Maybe Token
_ [] [Token]
ts = forall a. [Token] -> String -> a
layoutError [Token]
ts String
"layout stack empty"
res Maybe Token
_ [Block]
st (Token
t0 : [Token]
ts)
| Token -> Bool
isLayoutOpen Token
t0 Bool -> Bool -> Bool
|| Token -> Bool
isParenOpen Token
t0
= Token
t0 forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
t0) (Block
Explicit forall a. a -> [a] -> [a]
: [Block]
st) [Token]
ts
| Token -> Bool
isLayoutClose Token
t0 Bool -> Bool -> Bool
|| Token -> Bool
isParenClose Token
t0
, let ([Block]
imps, [Block]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Block -> Bool
isImplicit [Block]
st
, let st' :: [Block]
st' = forall a. Line -> [a] -> [a]
drop Line
1 [Block]
rest
= if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
st'
then forall a. [Token] -> String -> a
layoutError [Token]
ts forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"found", Token -> String
prToken Token
t0, String
"at" , [Token] -> String
tokenPos [Token
t0]
, String
"without an explicit layout block"
]
else forall a b. (a -> b) -> [a] -> [b]
map ([Token] -> Position -> Block -> Token
closingToken [Token]
ts (Token -> Position
tokenPosn Token
t0)) [Block]
imps forall a. [a] -> [a] -> [a]
++ Token
t0 forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
t0) [Block]
st' [Token]
ts
res Maybe Token
pt (b :: Block
b@(Implicit LayoutDelimiters
delim Status
status Line
col) : [Block]
bs) (Token
t0 : [Token]
ts)
| Token -> Bool
isStop Token
t0, Line
col forall a. Ord a => a -> a -> Bool
<= Line
1
= Token
t0 forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
t0) (Block
b forall a. a -> [a] -> [a]
: [Block]
bs) [Token]
ts
| Token -> Bool
isStop Token
t0
, let ([Block]
ebs, [Block]
st') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Token -> Line
column Token
t0 forall a. Ord a => a -> a -> Bool
<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Line
indentation) [Block]
bs
= forall a b. (a -> b) -> [a] -> [b]
map ([Token] -> Position -> Block -> Token
closingToken [Token]
ts (Maybe Token -> Position
afterPrev Maybe Token
pt)) (Block
b forall a. a -> [a] -> [a]
: [Block]
ebs) forall a. [a] -> [a] -> [a]
++ Token
t0 forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
t0) [Block]
st' [Token]
ts
| Maybe Token -> Token -> Bool
newLine Maybe Token
pt Token
t0
, Token -> Line
column Token
t0 forall a. Ord a => a -> a -> Bool
< Line
col
, let c :: Token
c = [Token] -> Position -> Block -> Token
closingToken [Token]
ts (Maybe Token -> Position
afterPrev Maybe Token
pt) Block
b
= Token
c forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
c) [Block]
bs (Token
t0 forall a. a -> [a] -> [a]
: [Token]
ts)
| Maybe Token -> Token -> Bool
newLine Maybe Token
pt Token
t0, Tentative{} <- Status
status
= Maybe Token -> [Block] -> [Token] -> [Token]
res Maybe Token
pt (LayoutDelimiters -> Status -> Line -> Block
Implicit LayoutDelimiters
delim Status
Definitive Line
col forall a. a -> [a] -> [a]
: Line -> [Block] -> [Block]
confirm Line
col [Block]
bs) (Token
t0 forall a. a -> [a] -> [a]
: [Token]
ts)
res Maybe Token
pt [Block]
st (Token
t0 : [Token]
ts)
| Just delim :: LayoutDelimiters
delim@(LayoutDelimiters TokSymbol
_ Maybe TokSymbol
mopen Maybe TokSymbol
_) <- Token -> Maybe LayoutDelimiters
isLayout Token
t0
= Maybe Token -> Token -> [Block] -> [Token] -> [Token]
maybeInsertSeparator Maybe Token
pt Token
t0 [Block]
st forall a b. (a -> b) -> a -> b
$
case [Token]
ts of
Token
t1 : [Token]
_ | Token -> Bool
isLayoutOpen Token
t1 ->
Token
t0 forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
t0) [Block]
st [Token]
ts
[Token]
_ ->
Token
t0 forall a. a -> [a] -> [a]
: Token
b forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
b) (LayoutDelimiters -> Position -> Position -> [Block] -> [Block]
addImplicit LayoutDelimiters
delim (Token -> Position
tokenPosn Token
t0) Position
pos [Block]
st) [Token]
ts
where
b :: Token
b = Position -> TokSymbol -> Token
sToken (Token -> Position
nextPos Token
t0) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
undefined Maybe TokSymbol
mopen
pos :: Position
pos = Token -> Position
tokenPosn forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Token
t0 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe [Token]
ts
| Bool
otherwise
= Maybe Token -> Token -> [Block] -> [Token] -> [Token]
maybeInsertSeparator Maybe Token
pt Token
t0 [Block]
st forall a b. (a -> b) -> a -> b
$
Token
t0 forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
t0) [Block]
st [Token]
ts
res (Just Token
_) [Block
Explicit] [] = []
res (Just Token
t) (Block
Explicit : [Block]
bs) [] = Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
t) [Block]
bs []
res (Just Token
t) [Implicit (LayoutDelimiters TokSymbol
sep Maybe TokSymbol
_ Maybe TokSymbol
_) Status
_ Line
_] []
| Token -> Bool
isLayoutSep Token
t = []
| Bool
otherwise = [Position -> TokSymbol -> Token
sToken (Token -> Position
nextPos Token
t) TokSymbol
sep]
res (Just Token
t) (Implicit (LayoutDelimiters TokSymbol
_ Maybe TokSymbol
_ (Just TokSymbol
close)) Status
_ Line
_ : [Block]
bs) []
= Token
b forall a. a -> [a] -> [a]
: Maybe Token -> [Block] -> [Token] -> [Token]
res (forall a. a -> Maybe a
Just Token
b) [Block]
bs []
where b :: Token
b = Position -> TokSymbol -> Token
sToken (Token -> Position
nextPos Token
t) TokSymbol
close
res Maybe Token
Nothing [Block]
_st []
= []
maybeInsertSeparator
:: Maybe Token
-> Token
-> [Block]
-> [Token]
-> [Token]
maybeInsertSeparator :: Maybe Token -> Token -> [Block] -> [Token] -> [Token]
maybeInsertSeparator Maybe Token
pt Token
t0 = \case
Implicit (LayoutDelimiters TokSymbol
sep Maybe TokSymbol
_ Maybe TokSymbol
_) Status
_ Line
n : [Block]
_
| Maybe Token -> Token -> Bool
newLine Maybe Token
pt Token
t0
, Token -> Line
column Token
t0 forall a. Eq a => a -> a -> Bool
== Line
n
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TokSymbol] -> Token -> Bool
isTokenIn ([TokSymbol]
layoutSep forall a. [a] -> [a] -> [a]
++ [TokSymbol]
layoutOpen)) Maybe Token
pt
-> (Position -> TokSymbol -> Token
sToken (Maybe Token -> Position
afterPrev Maybe Token
pt) TokSymbol
sep forall a. a -> [a] -> [a]
:)
[Block]
_ -> forall a. a -> a
id
closingToken :: [Token] -> Position -> Block -> Token
closingToken :: [Token] -> Position -> Block -> Token
closingToken [Token]
ts Position
pos = Position -> TokSymbol -> Token
sToken Position
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Implicit (LayoutDelimiters TokSymbol
_ Maybe TokSymbol
_ (Just TokSymbol
sy)) Status
_ Line
_ -> TokSymbol
sy
Block
_ -> forall a. [Token] -> String -> a
layoutError [Token]
ts String
"trying to close a top level block"
type Position = Posn
type Line = Int
type Column = Int
data Block
= Implicit LayoutDelimiters Status Column
| Explicit
indentation :: Block -> Column
indentation :: Block -> Line
indentation = \case
Implicit LayoutDelimiters
_ Status
_ Line
n -> Line
n
Block
Explicit -> Line
0
isImplicit :: Block -> Bool
isImplicit :: Block -> Bool
isImplicit = \case
Implicit{} -> Bool
True
Explicit{} -> Bool
False
data Status
= Tentative
| Definitive
addImplicit
:: LayoutDelimiters
-> Position
-> Position
-> [Block]
-> [Block]
addImplicit :: LayoutDelimiters -> Position -> Position -> [Block] -> [Block]
addImplicit LayoutDelimiters
delim (Pn Line
_ Line
l0 Line
_) (Pn Line
_ Line
l1 Line
c1) [Block]
st
| Line
l1 forall a. Ord a => a -> a -> Bool
> Line
l0 = LayoutDelimiters -> Status -> Line -> Block
Implicit LayoutDelimiters
delim Status
Definitive ([Block] -> Line
col [Block]
st') forall a. a -> [a] -> [a]
: [Block]
st'
| Bool
otherwise = LayoutDelimiters -> Status -> Line -> Block
Implicit LayoutDelimiters
delim Status
Tentative ([Block] -> Line
col [Block]
st) forall a. a -> [a] -> [a]
: [Block]
st
where
st' :: [Block]
st' = Line -> [Block] -> [Block]
confirm Line
c1 [Block]
st
col :: [Block] -> Line
col [Block]
bs = forall a. Ord a => a -> a -> a
max Line
c1 forall a b. (a -> b) -> a -> b
$ Line
1 forall a. Num a => a -> a -> a
+ [Block] -> Line
definiteIndentation [Block]
bs
definiteIndentation :: [Block] -> Int
definiteIndentation :: [Block] -> Line
definiteIndentation [Block]
bs =
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Block -> Bool
isTentative [Block]
bs of
Implicit LayoutDelimiters
_ Status
Definitive Line
n : [Block]
_ -> Line
n
[Block]
_ -> Line
0
isTentative :: Block -> Bool
isTentative :: Block -> Bool
isTentative = \case
Implicit LayoutDelimiters
_ Status
Tentative Line
_ -> Bool
True
Block
_ -> Bool
False
confirm :: Column -> [Block] -> [Block]
confirm :: Line -> [Block] -> [Block]
confirm Line
c0 = [Block] -> [Block]
loop
where
loop :: [Block] -> [Block]
loop = \case
Implicit LayoutDelimiters
delim Status
Tentative Line
c : [Block]
bs
| Line
c forall a. Ord a => a -> a -> Bool
<= Line
c0 -> LayoutDelimiters -> Status -> Line -> Block
Implicit LayoutDelimiters
delim Status
Definitive Line
c forall a. a -> [a] -> [a]
: [Block] -> [Block]
loop [Block]
bs
[Block]
bs -> [Block]
bs
afterPrev :: Maybe Token -> Position
afterPrev :: Maybe Token -> Position
afterPrev = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Line -> Line -> Line -> Position
Pn Line
0 Line
1 Line
1) Token -> Position
nextPos
nextPos :: Token -> Position
nextPos :: Token -> Position
nextPos Token
t = Line -> Line -> Line -> Position
Pn (Line
g forall a. Num a => a -> a -> a
+ Line
s) Line
l (Line
c forall a. Num a => a -> a -> a
+ Line
s forall a. Num a => a -> a -> a
+ Line
1)
where
Pn Line
g Line
l Line
c = Token -> Position
tokenPosn Token
t
s :: Line
s = Token -> Line
tokenLength Token
t
tokenLength :: Token -> Int
tokenLength :: Token -> Line
tokenLength = forall (t :: * -> *) a. Foldable t => t a -> Line
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> String
prToken
sToken :: Position -> TokSymbol -> Token
sToken :: Position -> TokSymbol -> Token
sToken Position
p TokSymbol
t = Position -> Tok -> Token
PT Position
p forall a b. (a -> b) -> a -> b
$ TokSymbol -> Tok
TK TokSymbol
t
line :: Token -> Line
line :: Token -> Line
line = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> (Line, Line)
tokenLineCol
column :: Token -> Column
column :: Token -> Line
column = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> (Line, Line)
tokenLineCol
newLine :: Maybe Token -> Token -> Bool
newLine :: Maybe Token -> Token -> Bool
newLine Maybe Token
pt Token
t0 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Token -> Line
line Token
t0 forall a. Ord a => a -> a -> Bool
>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Line
line) Maybe Token
pt
isLayout :: Token -> Maybe LayoutDelimiters
isLayout :: Token -> Maybe LayoutDelimiters
isLayout = \case
PT Position
_ (TK TokSymbol
t) -> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TokSymbol
t [(TokSymbol, LayoutDelimiters)]
layoutWords
Token
_ -> forall a. Maybe a
Nothing
isTokenIn :: [TokSymbol] -> Token -> Bool
isTokenIn :: [TokSymbol] -> Token -> Bool
isTokenIn [TokSymbol]
ts = \case
PT Position
_ (TK TokSymbol
t) -> TokSymbol
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TokSymbol]
ts
Token
_ -> Bool
False
isStop :: Token -> Bool
isStop :: Token -> Bool
isStop = [TokSymbol] -> Token -> Bool
isTokenIn [TokSymbol]
layoutStopWords
isLayoutOpen :: Token -> Bool
isLayoutOpen :: Token -> Bool
isLayoutOpen = [TokSymbol] -> Token -> Bool
isTokenIn [TokSymbol]
layoutOpen
isLayoutSep :: Token -> Bool
isLayoutSep :: Token -> Bool
isLayoutSep = [TokSymbol] -> Token -> Bool
isTokenIn [TokSymbol]
layoutSep
isLayoutClose :: Token -> Bool
isLayoutClose :: Token -> Bool
isLayoutClose = [TokSymbol] -> Token -> Bool
isTokenIn [TokSymbol]
layoutClose
isParenOpen :: Token -> Bool
isParenOpen :: Token -> Bool
isParenOpen = [TokSymbol] -> Token -> Bool
isTokenIn [TokSymbol]
parenOpen
isParenClose :: Token -> Bool
isParenClose :: Token -> Bool
isParenClose = [TokSymbol] -> Token -> Bool
isTokenIn [TokSymbol]
parenClose