{-# 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 :: FilePath -> FilePath -> FilePath
recordDotPreprocessor FilePath
original = Maybe FilePath -> [Lexeme] -> FilePath
unlexerFile (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
original) ([Lexeme] -> FilePath)
-> (FilePath -> [Lexeme]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paren Lexeme] -> [Lexeme]
forall a. [Paren a] -> [a]
unparens ([Paren Lexeme] -> [Lexeme])
-> (FilePath -> [Paren Lexeme]) -> FilePath -> [Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paren Lexeme] -> [Paren Lexeme]
edit ([Paren Lexeme] -> [Paren Lexeme])
-> (FilePath -> [Paren Lexeme]) -> FilePath -> [Paren Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexeme] -> [Paren Lexeme]
parens ([Lexeme] -> [Paren Lexeme])
-> (FilePath -> [Lexeme]) -> FilePath -> [Paren Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [Lexeme]
lexer
    where
        edit :: [PL] -> [PL]
        edit :: [Paren Lexeme] -> [Paren Lexeme]
edit = [Paren Lexeme] -> [Paren Lexeme]
editAddPreamble ([Paren Lexeme] -> [Paren Lexeme])
-> ([Paren Lexeme] -> [Paren Lexeme])
-> [Paren Lexeme]
-> [Paren Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paren Lexeme] -> [Paren Lexeme]
editAddInstances ([Paren Lexeme] -> [Paren Lexeme])
-> ([Paren Lexeme] -> [Paren Lexeme])
-> [Paren Lexeme]
-> [Paren Lexeme]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paren Lexeme] -> [Paren Lexeme]
editLoop

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


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

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

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

-- Whitespace
pattern $mNoW :: forall r. Paren Lexeme -> (Paren Lexeme -> r) -> (Void# -> r) -> r
NoW x <- (\v -> if null $ getWhite v then Just v else Nothing -> Just x)


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

spc :: Paren Lexeme -> Paren Lexeme
spc = FilePath -> Paren Lexeme -> Paren Lexeme
addWhite FilePath
" "
nl :: Paren Lexeme -> Paren Lexeme
nl = FilePath -> Paren Lexeme -> Paren Lexeme
addWhite FilePath
"\n"

addWhite :: FilePath -> Paren Lexeme -> Paren Lexeme
addWhite FilePath
w Paren Lexeme
x = FilePath -> Paren Lexeme -> Paren Lexeme
setWhite (Paren Lexeme -> FilePath
getWhite Paren Lexeme
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
w) Paren Lexeme
x

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

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

isCtor :: Paren Lexeme -> Bool
isCtor (Item Lexeme
x) = (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isUpper (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
1 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Lexeme -> FilePath
lexeme Lexeme
x
isCtor Paren Lexeme
_ = 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 :: Paren Lexeme -> Bool
isQuasiQuotation (Paren open :: Lexeme
open@(L FilePath
"[") inner :: [Paren Lexeme]
inner@(Paren Lexeme
_:[Paren Lexeme]
_) (L FilePath
"]"))
    | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> FilePath
whitespace Lexeme
open)
    , [Paren Lexeme] -> Bool
qname [Paren Lexeme]
inner
    , Item close :: Lexeme
close@(L FilePath
op) <- [Paren Lexeme] -> Paren Lexeme
forall a. [a] -> a
last [Paren Lexeme]
inner
    , FilePath
"|" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
op
    , FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> FilePath
whitespace Lexeme
close)
    = Bool
True
    where
        -- a (potentially) qualified name with no whitespace near it, ending with |
        qname :: [Paren Lexeme] -> Bool
qname (Item a :: Lexeme
a@(L FilePath
_) : Item b :: Lexeme
b@(L FilePath
".") : [Paren Lexeme]
c) | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> FilePath
whitespace Lexeme
a), FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lexeme -> FilePath
whitespace Lexeme
b) = [Paren Lexeme] -> Bool
qname [Paren Lexeme]
c
        qname (Item a :: Lexeme
a@(L FilePath
_) : Item (L FilePath
x):[Paren Lexeme]
_) = FilePath
"|" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
x
        qname [Paren Lexeme]
_ = Bool
False
isQuasiQuotation Paren Lexeme
_ = Bool
False

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

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


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

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

        prefix :: FilePath
prefix = FilePath
"{-# LANGUAGE DuplicateRecordFields, DataKinds, FlexibleInstances, TypeApplications, FlexibleContexts, MultiParamTypeClasses, TypeFamilies, TypeOperators, GADTs, UndecidableInstances #-}\n" FilePath -> FilePath -> FilePath
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)
                 FilePath
"{- HLINT ignore \"Redundant bracket\" -}"
        imports :: FilePath
imports = FilePath
"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 :: [Paren Lexeme] -> FilePath
trailing [Paren Lexeme]
modName = FilePath
"_recordDotPreprocessorUnused" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
uniq FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" :: Z.HasField \"\" r a => r -> a;" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                           FilePath
"_recordDotPreprocessorUnused" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
uniq FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" = Z.getField @\"\""
            where uniq :: FilePath
uniq = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAlphaNum (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
19 ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile FilePath -> Bool
modPart ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (Lexeme -> FilePath) -> [Lexeme] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Lexeme -> FilePath
lexeme ([Lexeme] -> [FilePath]) -> [Lexeme] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [Paren Lexeme] -> [Lexeme]
forall a. [Paren a] -> [a]
unparens [Paren Lexeme]
modName
        modPart :: FilePath -> Bool
modPart FilePath
x = FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." Bool -> Bool -> Bool
|| (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isUpper (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
1 FilePath
x)


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

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


editLoop :: [PL] -> [PL]

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

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

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

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

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


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


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

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

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


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

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

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



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

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

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

        -- 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 :: [Paren Lexeme] -> [Paren Lexeme]
dropContext (Paren (L FilePath
"(") [Paren Lexeme]
_ Lexeme
_ : PL FilePath
"=>" : [Paren Lexeme]
xs) = [Paren Lexeme]
xs
        dropContext (Paren Lexeme
_ : Paren Lexeme
_  : PL FilePath
"=>": [Paren Lexeme]
xs) = [Paren Lexeme]
xs
        dropContext [Paren Lexeme]
xs = [Paren Lexeme]
xs

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

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