{-# LANGUAGE PatternSynonyms, ViewPatterns #-}

module Edit(recordDotPreprocessor, recordDotPreprocessorOnFragment) where

import Lexer
import Paren
import Data.Maybe
import Data.Char
import Data.List.Extra
import Control.Monad.Extra

recordDotPreprocessor :: FilePath -> String -> String
recordDotPreprocessor :: String -> String -> String
recordDotPreprocessor String
original = Maybe String -> [Lexeme] -> String
unlexerFile (String -> Maybe String
forall a. a -> Maybe a
Just String
original) ([Lexeme] -> String) -> (String -> [Lexeme]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PL] -> [Lexeme]
forall a. [Paren a] -> [a]
unparens ([PL] -> [Lexeme]) -> (String -> [PL]) -> String -> [Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PL] -> [PL]
edit ([PL] -> [PL]) -> (String -> [PL]) -> String -> [PL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexeme] -> [PL]
parens ([Lexeme] -> [PL]) -> (String -> [Lexeme]) -> String -> [PL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Lexeme]
lexer
    where
        edit :: [PL] -> [PL]
        edit :: [PL] -> [PL]
edit = [PL] -> [PL]
editAddPreamble ([PL] -> [PL]) -> ([PL] -> [PL]) -> [PL] -> [PL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PL] -> [PL]
editAddInstances ([PL] -> [PL]) -> ([PL] -> [PL]) -> [PL] -> [PL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PL] -> [PL]
editLoop

recordDotPreprocessorOnFragment :: String -> String
recordDotPreprocessorOnFragment :: String -> String
recordDotPreprocessorOnFragment = Maybe String -> [Lexeme] -> String
unlexerFile Maybe String
forall a. Maybe a
Nothing ([Lexeme] -> String) -> (String -> [Lexeme]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PL] -> [Lexeme]
forall a. [Paren a] -> [a]
unparens ([PL] -> [Lexeme]) -> (String -> [PL]) -> String -> [Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PL] -> [PL]
editLoop ([PL] -> [PL]) -> (String -> [PL]) -> String -> [PL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexeme] -> [PL]
parens ([Lexeme] -> [PL]) -> (String -> [Lexeme]) -> String -> [PL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Lexeme]
lexer


---------------------------------------------------------------------
-- HELPERS

-- Projecting in on the 'lexeme' inside
type L = Lexeme
unL :: Lexeme -> String
unL = Lexeme -> String
lexeme
mkL :: String -> Lexeme
mkL String
x = Int -> Int -> String -> String -> Lexeme
Lexeme Int
0 Int
0 String
x String
""
pattern $mL :: forall {r}. Lexeme -> (String -> r) -> ((# #) -> r) -> r
L x <- (unL -> x)

-- Projecting in on the lexeme inside an Item
type PL = Paren L
unPL :: PL -> Maybe String
unPL (Item (L String
x)) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
unPL PL
_ = Maybe String
forall a. Maybe a
Nothing
isPL :: String -> PL -> Bool
isPL String
x PL
y = PL -> Maybe String
unPL PL
y Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
x
pattern $mPL :: forall {r}. PL -> (String -> r) -> ((# #) -> r) -> r
PL x <- (unPL -> Just x)
mkPL :: String -> PL
mkPL = Lexeme -> PL
forall a. a -> Paren a
Item (Lexeme -> PL) -> (String -> Lexeme) -> String -> PL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lexeme
mkL

-- Whitespace
pattern $mNoW :: forall {r}. PL -> (PL -> r) -> ((# #) -> r) -> r
NoW x <- (\PL
v -> if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ PL -> String
getWhite PL
v then PL -> Maybe PL
forall a. a -> Maybe a
Just PL
v else Maybe PL
forall a. Maybe a
Nothing -> Just x)


paren :: [PL] -> PL
paren [PL
x] = PL
x
paren [PL]
xs = case [PL] -> Maybe ([PL], PL)
forall a. [a] -> Maybe ([a], a)
unsnoc [PL]
xs of
    Just ([PL]
xs,PL
x) -> Lexeme -> [PL] -> Lexeme -> PL
forall a. a -> [Paren a] -> a -> Paren a
Paren (String -> Lexeme
mkL String
"(") ([PL]
xs [PL] -> PL -> [PL]
forall a. [a] -> a -> [a]
`snoc` String -> PL -> PL
setWhite String
"" PL
x) (String -> Lexeme
mkL String
")"){whitespace = getWhite x}
    Maybe ([PL], PL)
_ -> Lexeme -> [PL] -> Lexeme -> PL
forall a. a -> [Paren a] -> a -> Paren a
Paren (String -> Lexeme
mkL String
"(") [PL]
xs (String -> Lexeme
mkL String
")")

spc :: PL -> PL
spc = String -> PL -> PL
addWhite String
" "
nl :: PL -> PL
nl = String -> PL -> PL
addWhite String
"\n"

addWhite :: String -> PL -> PL
addWhite String
w PL
x = String -> PL -> PL
setWhite (PL -> String
getWhite PL
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
w) PL
x

getWhite :: PL -> String
getWhite (Item Lexeme
x) = Lexeme -> String
whitespace Lexeme
x
getWhite (Paren Lexeme
_ [PL]
_ Lexeme
x) = Lexeme -> String
whitespace Lexeme
x

setWhite :: String -> PL -> PL
setWhite String
w (Item Lexeme
x) = Lexeme -> PL
forall a. a -> Paren a
Item Lexeme
x{whitespace=w}
setWhite String
w (Paren Lexeme
x [PL]
y Lexeme
z) = Lexeme -> [PL] -> Lexeme -> PL
forall a. a -> [Paren a] -> a -> Paren a
Paren Lexeme
x [PL]
y Lexeme
z{whitespace=w}

isCtor :: PL -> Bool
isCtor (Item Lexeme
x) = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isUpper (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Lexeme -> String
lexeme Lexeme
x
isCtor PL
_ = Bool
False

-- | This test does not check that the @quoter@ name is a qualified identifier,
-- instead relying on lack of whitespace in the opener and existence of a paired
-- closed (@|]@)
isQuasiQuotation :: PL -> Bool
isQuasiQuotation :: PL -> Bool
isQuasiQuotation (Paren open :: Lexeme
open@(L String
"[") inner :: [PL]
inner@(PL
_:[PL]
_) (L String
"]"))
    | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> String
whitespace Lexeme
open)
    , [PL] -> Bool
qname [PL]
inner
    , Item close :: Lexeme
close@(L String
op) <- [PL] -> PL
forall a. HasCallStack => [a] -> a
last [PL]
inner
    , String
"|" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
op
    , String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> String
whitespace Lexeme
close)
    = Bool
True
    where
        -- a (potentially) qualified name with no whitespace near it, ending with |
        qname :: [PL] -> Bool
qname (Item a :: Lexeme
a@(L String
_) : Item b :: Lexeme
b@(L String
".") : [PL]
c) | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> String
whitespace Lexeme
a), String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> String
whitespace Lexeme
b) = [PL] -> Bool
qname [PL]
c
        qname (Item a :: Lexeme
a@(L String
_) : Item (L String
x):[PL]
_) = String
"|" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x
        qname [PL]
_ = Bool
False
isQuasiQuotation PL
_ = Bool
False

isField :: String -> Bool
isField (Char
x:String
_) = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char -> Bool
isLower Char
x
isField String
_ = Bool
False

makeField :: [String] -> String
makeField :: [String] -> String
makeField [String
x] = String
"@" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
x
makeField [String]
xs = String
"@'(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. Show a => a -> String
show [String]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"


---------------------------------------------------------------------
-- PREAMBLE

-- | Add the necessary extensions, imports and local definitions
editAddPreamble :: [PL] -> [PL]
editAddPreamble :: [PL] -> [PL]
editAddPreamble o :: [PL]
o@[PL]
xs
    | ([PL]
premodu, PL
modu:modname :: [PL]
modname@[PL]
xs) <- (PL -> Bool) -> [PL] -> ([PL], [PL])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> PL -> Bool
isPL String
"module") [PL]
xs
    , ([PL]
prewhr, PL
whr:[PL]
xs) <- (PL -> Bool) -> [PL] -> ([PL], [PL])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> PL -> Bool
isPL String
"where") [PL]
xs
    = PL -> PL
nl (String -> PL
mkPL String
prefix) PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL]
premodu [PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++ PL
modu PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL]
prewhr [PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++ PL
whr PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: PL -> PL
nl (String -> PL
mkPL String
"") PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: PL -> PL
nl (String -> PL
mkPL String
imports) PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL]
xs [PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++ [PL -> PL
nl (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL String
"", PL -> PL
nl (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL (String -> PL) -> String -> PL
forall a b. (a -> b) -> a -> b
$ [PL] -> String
trailing [PL]
modname]
    | Bool
otherwise = [PL]
blanks [PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++ PL -> PL
nl (String -> PL
mkPL String
prefix) PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: PL -> PL
nl (String -> PL
mkPL String
imports) PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL]
rest [PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++ [PL -> PL
nl (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL String
"", PL -> PL
nl (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL (String -> PL) -> String -> PL
forall a b. (a -> b) -> a -> b
$ [PL] -> String
trailing []]
    where
        ([PL]
blanks, [PL]
rest) = (PL -> Bool) -> [PL] -> ([PL], [PL])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (String -> PL -> Bool
isPL String
"") [PL]
o

        prefix :: String
prefix = String
"{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, TypeApplications, FlexibleContexts, MultiParamTypeClasses, TypeFamilies, TypeOperators, GADTs, UndecidableInstances #-}\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 -- it's too hard to avoid generating excessive brackets, so just ignore the code
                 -- only really applies to people using it through Haskell Language Server (see #37)
                 String
"{- HLINT ignore \"Redundant bracket\" -}"
        imports :: String
imports = String
"import qualified GHC.Records.Extra as Z"
        -- if you import two things that have preprocessor_unused, and export them as modules, you don't want them to clash
        trailing :: [PL] -> String
trailing [PL]
modName = String
"_recordDotPreprocessorUnused" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uniq String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: Z.HasField \"\" r a => r -> a;" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
"_recordDotPreprocessorUnused" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uniq String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = Z.getField @\"\""
            where uniq :: String
uniq = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlphaNum (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
19 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile String -> Bool
modPart ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Lexeme -> String) -> [Lexeme] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Lexeme -> String
lexeme ([Lexeme] -> [String]) -> [Lexeme] -> [String]
forall a b. (a -> b) -> a -> b
$ [PL] -> [Lexeme]
forall a. [Paren a] -> [a]
unparens [PL]
modName
        modPart :: String -> Bool
modPart String
x = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." Bool -> Bool -> Bool
|| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isUpper (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
x)


---------------------------------------------------------------------
-- SELECTORS

-- given .lbl1.lbl2 return ([lbl1,lbl2], whitespace, rest)
spanFields :: [PL] -> ([String], String, [PL])
spanFields :: [PL] -> ([String], String, [PL])
spanFields (NoW (PL String
"."):x :: PL
x@(PL String
fld):[PL]
xs) | String -> Bool
isField String
fld = (\([String]
a,String
b,[PL]
c) -> (String
fldString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
a,String
b,[PL]
c)) (([String], String, [PL]) -> ([String], String, [PL]))
-> ([String], String, [PL]) -> ([String], String, [PL])
forall a b. (a -> b) -> a -> b
$
    case PL
x of NoW{} -> [PL] -> ([String], String, [PL])
spanFields [PL]
xs; PL
_ -> ([], PL -> String
getWhite PL
x, [PL]
xs)
spanFields [PL]
xs = ([], String
"", [PL]
xs)


editLoop :: [PL] -> [PL]

--  Leave quasiquotations alone
editLoop :: [PL] -> [PL]
editLoop (PL
p : [PL]
ps) | PL -> Bool
isQuasiQuotation PL
p = PL
p PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL] -> [PL]
editLoop [PL]
ps

-- | a.b.c ==> getField @'(b,c) a
editLoop (NoW PL
e : ([PL] -> ([String], String, [PL])
spanFields -> (fields :: [String]
fields@(String
_:[String]
_), String
whitespace, [PL]
rest)))
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PL -> Bool
isCtor PL
e
    = [PL] -> [PL]
editLoop ([PL] -> [PL]) -> [PL] -> [PL]
forall a b. (a -> b) -> a -> b
$ String -> PL -> PL
addWhite String
whitespace ([PL] -> PL
paren [PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL String
"Z.getField", PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL (String -> PL) -> String -> PL
forall a b. (a -> b) -> a -> b
$ [String] -> String
makeField [String]
fields, PL
e]) PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL]
rest

-- (.a.b) ==> (getField @'(a,b))
editLoop (Paren start :: Lexeme
start@(L String
"(") ([PL] -> ([String], String, [PL])
spanFields -> (fields :: [String]
fields@(String
_:[String]
_), String
whitespace, [])) Lexeme
end:[PL]
xs)
    = [PL] -> [PL]
editLoop ([PL] -> [PL]) -> [PL] -> [PL]
forall a b. (a -> b) -> a -> b
$ Lexeme -> [PL] -> Lexeme -> PL
forall a. a -> [Paren a] -> a -> Paren a
Paren Lexeme
start [PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL String
"Z.getField", String -> PL -> PL
addWhite String
whitespace (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL (String -> PL) -> String -> PL
forall a b. (a -> b) -> a -> b
$ [String] -> String
makeField [String]
fields] Lexeme
end PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL]
xs

-- e{b.c=d, ...} ==> setField @'(b,c) d
editLoop (PL
e:Paren (L String
"{") [PL]
inner Lexeme
end:[PL]
xs)
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PL -> Bool
isCtor PL
e
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> PL -> Bool
isPL String
"::" PL
e
    , PL -> String
getWhite PL
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""
    , Just [([String], Maybe PL, Maybe PL)]
updates <- ([PL] -> Maybe ([String], Maybe PL, Maybe PL))
-> [[PL]] -> Maybe [([String], Maybe PL, Maybe PL)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [PL] -> Maybe ([String], Maybe PL, Maybe PL)
f ([[PL]] -> Maybe [([String], Maybe PL, Maybe PL)])
-> [[PL]] -> Maybe [([String], Maybe PL, Maybe PL)]
forall a b. (a -> b) -> a -> b
$ (PL -> Bool) -> [PL] -> [[PL]]
forall a. (a -> Bool) -> [a] -> [[a]]
split (String -> PL -> Bool
isPL String
",") [PL]
inner
    , let end2 :: [PL]
end2 = [Lexeme -> PL
forall a. a -> Paren a
Item Lexeme
end{lexeme=""} | Lexeme -> String
whitespace Lexeme
end String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""]
    = [PL] -> [PL]
editLoop ([PL] -> [PL]) -> [PL] -> [PL]
forall a b. (a -> b) -> a -> b
$ Update -> PL
renderUpdate (PL -> [([String], Maybe PL, Maybe PL)] -> Update
Update PL
e [([String], Maybe PL, Maybe PL)]
updates) PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL]
end2 [PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++ [PL]
xs
    where
        f :: [PL] -> Maybe ([String], Maybe PL, Maybe PL)
f (NoW (PL String
field1) : ([PL] -> ([String], String, [PL])
spanFields -> ([String]
fields, String
whitespace, [PL]
xs)))
            | String -> Bool
isField String
field1
            = [String] -> [PL] -> Maybe ([String], Maybe PL, Maybe PL)
forall {a}. a -> [PL] -> Maybe (a, Maybe PL, Maybe PL)
g (String
field1String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
fields) [PL]
xs
        f (x :: PL
x@(PL String
field1):[PL]
xs)
            | String -> Bool
isField String
field1
            = [String] -> [PL] -> Maybe ([String], Maybe PL, Maybe PL)
forall {a}. a -> [PL] -> Maybe (a, Maybe PL, Maybe PL)
g [String
field1] [PL]
xs
        f [PL]
_ = Maybe ([String], Maybe PL, Maybe PL)
forall a. Maybe a
Nothing

        g :: a -> [PL] -> Maybe (a, Maybe PL, Maybe PL)
g a
fields (PL
op:[PL]
xs) = (a, Maybe PL, Maybe PL) -> Maybe (a, Maybe PL, Maybe PL)
forall a. a -> Maybe a
Just (a
fields, if String -> PL -> Bool
isPL String
"=" PL
op then Maybe PL
forall a. Maybe a
Nothing else PL -> Maybe PL
forall a. a -> Maybe a
Just PL
op, PL -> Maybe PL
forall a. a -> Maybe a
Just (PL -> Maybe PL) -> PL -> Maybe PL
forall a b. (a -> b) -> a -> b
$ [PL] -> PL
paren [PL]
xs)
        g a
fields [] = (a, Maybe PL, Maybe PL) -> Maybe (a, Maybe PL, Maybe PL)
forall a. a -> Maybe a
Just (a
fields, Maybe PL
forall a. Maybe a
Nothing, Maybe PL
forall a. Maybe a
Nothing)


editLoop (Paren Lexeme
a [PL]
b Lexeme
c:[PL]
xs) = Lexeme -> [PL] -> Lexeme -> PL
forall a. a -> [Paren a] -> a -> Paren a
Paren Lexeme
a ([PL] -> [PL]
editLoop [PL]
b) Lexeme
c PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL] -> [PL]
editLoop [PL]
xs
editLoop (PL
x:[PL]
xs) = PL
x PL -> [PL] -> [PL]
forall a. a -> [a] -> [a]
: [PL] -> [PL]
editLoop [PL]
xs
editLoop [] = []


---------------------------------------------------------------------
-- UPDATES

data Update = Update
    PL -- The expression being updated
    [([String], Maybe PL, Maybe PL)] -- (fields, operator, body)

renderUpdate :: Update -> PL
renderUpdate :: Update -> PL
renderUpdate (Update PL
e [([String], Maybe PL, Maybe PL)]
upd) = case [([String], Maybe PL, Maybe PL)]
-> Maybe
     ([([String], Maybe PL, Maybe PL)], ([String], Maybe PL, Maybe PL))
forall a. [a] -> Maybe ([a], a)
unsnoc [([String], Maybe PL, Maybe PL)]
upd of
    Maybe
  ([([String], Maybe PL, Maybe PL)], ([String], Maybe PL, Maybe PL))
Nothing -> PL
e
    Just ([([String], Maybe PL, Maybe PL)]
rest, ([String]
field, Maybe PL
operator, Maybe PL
body)) -> [PL] -> PL
paren
        [PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL (String -> PL) -> String -> PL
forall a b. (a -> b) -> a -> b
$ if Maybe PL -> Bool
forall a. Maybe a -> Bool
isNothing Maybe PL
operator then String
"Z.setField" else String
"Z.modifyField"
        ,PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL (String -> PL) -> String -> PL
forall a b. (a -> b) -> a -> b
$ [String] -> String
makeField ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ if Maybe PL -> Bool
forall a. Maybe a -> Bool
isNothing Maybe PL
body then [[String] -> String
forall a. HasCallStack => [a] -> a
last [String]
field] else [String]
field
        ,PL -> PL
spc (Update -> PL
renderUpdate (PL -> [([String], Maybe PL, Maybe PL)] -> Update
Update PL
e [([String], Maybe PL, Maybe PL)]
rest))
        ,case (Maybe PL
operator, Maybe PL
body) of
            (Just PL
o, Just PL
b) -> [PL] -> PL
paren [PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ if String -> PL -> Bool
isPL String
"-" PL
o then String -> PL
mkPL String
"subtract" else PL
o, PL
b]
            (Maybe PL
Nothing, Just PL
b) -> PL
b
            (Maybe PL
Nothing, Maybe PL
Nothing)
                | [String
field] <- [String]
field -> String -> PL
mkPL String
field
                | String
f1:[String]
fs <- [String]
field -> [PL] -> PL
paren [PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL String
"Z.getField", PL -> PL
spc (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL (String -> PL) -> String -> PL
forall a b. (a -> b) -> a -> b
$ [String] -> String
makeField [String]
fs, String -> PL
mkPL String
f1]
            (Maybe PL, Maybe PL)
_ -> String -> PL
forall a. HasCallStack => String -> a
error String
"renderUpdate, internal error"
        ]


---------------------------------------------------------------------
-- INSTANCES

editAddInstances :: [PL] -> [PL]
editAddInstances :: [PL] -> [PL]
editAddInstances [PL]
xs = [PL]
xs [PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++ (String -> [PL]) -> [String] -> [PL]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
x -> [PL -> PL
nl (PL -> PL) -> PL -> PL
forall a b. (a -> b) -> a -> b
$ String -> PL
mkPL String
"", String -> PL
mkPL String
x])
    [ String
"instance (aplg ~ (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ftyp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")) => Z.HasField \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rtyp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" aplg " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"where hasField _r = (\\_x -> case _r of {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" ; "
        [ if String
fname String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
fields then
            String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                [String] -> String
unwords [if (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
field String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fname then String
"_" else String
"_x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i | (Integer
i, (String, String)
field) <- Integer -> [(String, String)] -> [(Integer, (String, String))]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Integer
1 [(String, String)]
fields] String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
") -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                [String] -> String
unwords [if (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
field String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fname then String
"_x" else String
"_x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i | (Integer
i, (String, String)
field) <- Integer -> [(String, String)] -> [(Integer, (String, String))]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Integer
1 [(String, String)]
fields]
          else
            String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"{} -> Prelude.error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (String
"Cannot update " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
msg String
cname)
        | Ctor String
cname [(String, String)]
fields <- [Ctor]
ctors] String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
"}, case _r of {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" ; "
        [ if String
fname String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> a
fst [(String, String)]
fields then
            String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                [String] -> String
unwords [if (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
field String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fname then String
"_x1" else String
"_" | (String, String)
field <- [(String, String)]
fields] String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
") -> _x1"
          else
            String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"{} -> Prelude.error " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (String
"Cannot get " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
msg String
cname)
        | Ctor String
cname [(String, String)]
fields <- [Ctor]
ctors] String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"})"
    | Record String
rname [String]
rargs [Ctor]
ctors <- [PL] -> [Record]
parseRecords [PL]
xs
    , let rtyp :: String
rtyp = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (String
rname String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rargs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    , (String
fname, String
ftyp) <- [(String, String)] -> [(String, String)]
forall a. Ord a => [a] -> [a]
nubOrd ([(String, String)] -> [(String, String)])
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Ctor -> [(String, String)]) -> [Ctor] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Ctor -> [(String, String)]
ctorFields [Ctor]
ctors
    , let msg :: a -> String
msg a
cname = String
"field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
rname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
cname
    ]

-- | Represent a record, ignoring constructors. For example:
--
-- > data Type a b = Ctor1 {field1 :: Int, field2 :: String} | Ctor2 {field1 :: Int, field3 :: [Bool]}
--
--   Gets parsed as:
--
-- > Record "Type" ["a","b"]
-- >   [Ctor "Ctor1" [("field1","Int"), ("field2","String")]
-- >   [Ctor "Ctor2" [("field1","Int"), ("field3","[Bool]")]
data Record = Record
    {Record -> String
recordName :: String -- Name of the type (not constructor)
    ,Record -> [String]
recordTyArgs :: [String] -- Type arguments
    ,Record -> [Ctor]
recordCtors :: [Ctor]
    }
    deriving Int -> Record -> String -> String
[Record] -> String -> String
Record -> String
(Int -> Record -> String -> String)
-> (Record -> String)
-> ([Record] -> String -> String)
-> Show Record
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Record -> String -> String
showsPrec :: Int -> Record -> String -> String
$cshow :: Record -> String
show :: Record -> String
$cshowList :: [Record] -> String -> String
showList :: [Record] -> String -> String
Show

data Ctor = Ctor
    {Ctor -> String
ctorName :: String -- Name of constructor
    ,Ctor -> [(String, String)]
ctorFields :: [(String, String)] -- (field, type)
    }
    deriving Int -> Ctor -> String -> String
[Ctor] -> String -> String
Ctor -> String
(Int -> Ctor -> String -> String)
-> (Ctor -> String) -> ([Ctor] -> String -> String) -> Show Ctor
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Ctor -> String -> String
showsPrec :: Int -> Ctor -> String -> String
$cshow :: Ctor -> String
show :: Ctor -> String
$cshowList :: [Ctor] -> String -> String
showList :: [Ctor] -> String -> String
Show



-- | Find all the records and parse them
parseRecords :: [PL] -> [Record]
parseRecords :: [PL] -> [Record]
parseRecords = ([PL] -> Maybe Record) -> [[PL]] -> [Record]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [PL] -> Maybe Record
whole ([[PL]] -> [Record]) -> ([PL] -> [[PL]]) -> [PL] -> [Record]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PL]] -> [[PL]]
forall a. [a] -> [a]
drop1 ([[PL]] -> [[PL]]) -> ([PL] -> [[PL]]) -> [PL] -> [[PL]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PL -> Bool) -> [PL] -> [[PL]]
forall a. (a -> Bool) -> [a] -> [[a]]
split (String -> PL -> Bool
isPL String
"data" (PL -> Bool) -> (PL -> Bool) -> PL -> Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
||^ String -> PL -> Bool
isPL String
"newtype")
    where
        whole :: [PL] -> Maybe Record
        whole :: [PL] -> Maybe Record
whole [PL]
xs
            | PL String
typeName : [PL]
xs <- [PL]
xs
            , ([PL]
typeArgs, PL
_:[PL]
xs) <- (PL -> Bool) -> [PL] -> ([PL], [PL])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> PL -> Bool
isPL String
"=" (PL -> Bool) -> (PL -> Bool) -> PL -> Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
||^ String -> PL -> Bool
isPL String
"where") [PL]
xs
            = Record -> Maybe Record
forall a. a -> Maybe a
Just (Record -> Maybe Record) -> Record -> Maybe Record
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [Ctor] -> Record
Record String
typeName ((PL -> Maybe String) -> [PL] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PL -> Maybe String
typeArg [PL]
typeArgs) ([Ctor] -> Record) -> [Ctor] -> Record
forall a b. (a -> b) -> a -> b
$ [PL] -> [Ctor]
ctor [PL]
xs
        whole [PL]
_ = Maybe Record
forall a. Maybe a
Nothing

        -- some types are raw, some are in brackets (with a kind signature)
        typeArg :: PL -> Maybe String
typeArg (PL String
x) = String -> Maybe String
forall a. a -> Maybe a
Just String
x
        typeArg (Paren Lexeme
_ (PL
x:[PL]
_) Lexeme
_) = PL -> Maybe String
typeArg PL
x
        typeArg PL
_ = Maybe String
forall a. Maybe a
Nothing

        ctor :: [PL] -> [Ctor]
ctor [PL]
xs
            | [PL]
xs <- [PL] -> [PL]
dropContext [PL]
xs
            , PL String
ctorName : [PL]
xs <- [PL]
xs
            , [PL]
xs <- (PL -> Bool) -> [PL] -> [PL]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> PL -> Bool
isPL String
"::") [PL]
xs
            , [PL]
xs <- [PL] -> [PL]
dropContext [PL]
xs
            , Paren (L String
"{") [PL]
inner Lexeme
_ : [PL]
xs <- [PL]
xs
            = String -> [(String, String)] -> Ctor
Ctor String
ctorName ([([PL], [PL])] -> [(String, String)]
fields ([([PL], [PL])] -> [(String, String)])
-> [([PL], [PL])] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ([PL] -> ([PL], [PL])) -> [[PL]] -> [([PL], [PL])]
forall a b. (a -> b) -> [a] -> [b]
map ((PL -> Bool) -> [PL] -> ([PL], [PL])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> PL -> Bool
isPL String
"::")) ([[PL]] -> [([PL], [PL])]) -> [[PL]] -> [([PL], [PL])]
forall a b. (a -> b) -> a -> b
$ (PL -> Bool) -> [PL] -> [[PL]]
forall a. (a -> Bool) -> [a] -> [[a]]
split (String -> PL -> Bool
isPL String
",") [PL]
inner) Ctor -> [Ctor] -> [Ctor]
forall a. a -> [a] -> [a]
:
              case [PL]
xs of
                PL String
"|":[PL]
xs -> [PL] -> [Ctor]
ctor [PL]
xs
                [PL]
_ -> []
        ctor [PL]
_ = []

        -- we don't use a full parser so dealing with context like
        --   Num a => V3 { xx, yy, zz :: a }
        -- is hard. Fake it as best we can
        dropContext :: [PL] -> [PL]
dropContext (Paren (L String
"(") [PL]
_ Lexeme
_ : PL String
"=>" : [PL]
xs) = [PL]
xs
        dropContext (PL
_ : PL
_  : PL String
"=>": [PL]
xs) = [PL]
xs
        dropContext [PL]
xs = [PL]
xs

        fields :: [([PL], [PL])] -> [(String, String)]
fields (([PL]
x,[]):([PL]
y,[PL]
z):[([PL], [PL])]
rest) = [([PL], [PL])] -> [(String, String)]
fields ([([PL], [PL])] -> [(String, String)])
-> [([PL], [PL])] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ([PL]
x[PL] -> [PL] -> [PL]
forall a. [a] -> [a] -> [a]
++[PL]
y,[PL]
z)([PL], [PL]) -> [([PL], [PL])] -> [([PL], [PL])]
forall a. a -> [a] -> [a]
:[([PL], [PL])]
rest
        fields (([PL]
names, PL
_:[PL]
typ):[([PL], [PL])]
rest) = [(String
name, (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
trim (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [Lexeme] -> String
unlexer ([Lexeme] -> String) -> [Lexeme] -> String
forall a b. (a -> b) -> a -> b
$ [PL] -> [Lexeme]
forall a. [Paren a] -> [a]
unparens [PL]
typ) | PL String
name <- [PL]
names] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [([PL], [PL])] -> [(String, String)]
fields [([PL], [PL])]
rest
        fields [([PL], [PL])]
_ = []

        -- if the user has a trailing comment want to rip it out so our brackets still work
        unlexer :: [Lexeme] -> String
unlexer = (Lexeme -> String) -> [Lexeme] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Lexeme -> String) -> [Lexeme] -> String)
-> (Lexeme -> String) -> [Lexeme] -> String
forall a b. (a -> b) -> a -> b
$ \Lexeme
x -> Lexeme -> String
lexeme Lexeme
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
' ' | Lexeme -> String
whitespace Lexeme
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""]