-- Copyright 2017 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | A library to collect definitions from haskell source and collect them
-- into an output source file.
module Util.ExtractHs where
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified System.Directory as Directory
import qualified System.Environment
import qualified System.Exit
import qualified System.FilePath as FilePath
import qualified System.IO as IO

import           Global


type Error = Text
type Warning = Text

-- | Extract from haskell source files, and generate output based on it.
process :: [String] -> (Text -> a)
    -> (FilePath -> Map FilePath a -> Either Error ([Warning], Text))
    -> IO ()
process :: forall a.
[String]
-> (Text -> a)
-> (String -> Map String a -> Either Text ([Text], Text))
-> IO ()
process [String]
args Text -> a
extract String -> Map String a -> Either Text ([Text], Text)
generate = do
    String
progName <- IO String
System.Environment.getProgName
    (String
outFname, [String]
inFnames) <- case [String]
args of
        String
outFname : [String]
inFnames -> forall (m :: * -> *) a. Monad m => a -> m a
return (String
outFname, [String]
inFnames)
        [String]
_ -> forall a. Text -> IO a
die forall a b. (a -> b) -> a -> b
$ Text
"usage: " forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
progName
            forall a. Semigroup a => a -> a -> a
<> Text
" output.hs input1.hs input2.hs ..."
    Map String a
extracted <- forall a. (Text -> a) -> [String] -> IO (Map String a)
extractFiles Text -> a
extract [String]
inFnames
    case String -> Map String a -> Either Text ([Text], Text)
generate String
outFname Map String a
extracted of
        Left Text
err -> forall a. Text -> IO a
die Text
err
        Right ([Text]
warnings, Text
output) -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
IO.stderr) [Text]
warnings
            Bool -> String -> IO ()
Directory.createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$
                String -> String
FilePath.takeDirectory String
outFname
            String -> Text -> IO ()
Text.IO.writeFile String
outFname forall a b. (a -> b) -> a -> b
$ String -> Text
header String
progName forall a. Semigroup a => a -> a -> a
<> Text
output

header :: String -> Text
header :: String -> Text
header String
program =
    Text
"-- Copyright 2017 Evan Laforge\n\
    \-- This program is distributed under the terms of the GNU General Public\n\
    \-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt\n\
    \\n\
    \-- automatically generated by " forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
program forall a. Semigroup a => a -> a -> a
<> Text
"\n"

extractFiles :: (Text -> a) -> [FilePath] -> IO (Map FilePath a)
extractFiles :: forall a. (Text -> a) -> [String] -> IO (Map String a)
extractFiles Text -> a
extract =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
fn -> (String
fn,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> a
extract forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
Text.IO.readFile String
fn)

-- * extract

-- | This is just barely enough of a parser to work for my purposes.
typeDeclarations :: Text -> [(Int, (Text, Text))]
typeDeclarations :: Text -> [(Int, (Text, Text))]
typeDeclarations = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (a, Text) -> [(a, (Text, Text))]
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
    where
    parse :: (a, Text) -> [(a, (Text, Text))]
parse (a
lineno, Text
line)
        | Text
line forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
Char.isLower (HasCallStack => Text -> Char
Text.head Text
line)) = []
        | Bool
otherwise = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Text
"::") (Text -> [Text]
Text.words Text
line) of
            ([Text]
pre, Text
"::" : [Text]
typ) ->
                [(a
lineno, (Text -> Text
strip Text
sym, [Text] -> Text
Text.unwords [Text]
typ)) | Text
sym <- [Text]
pre]
            ([Text], [Text])
_ -> []
    strip :: Text -> Text
strip Text
t = forall a. a -> Maybe a -> a
fromMaybe Text
t forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
Text.stripSuffix Text
"," Text
t

-- | This will be fooled by a {- or -} inside a string.  I don't strip --
-- comments because the extract functions look for left justified text.
stripComments :: Text -> Text
stripComments :: Text -> Text
stripComments = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Ord a, Num a) => a -> Text -> [Text]
go Integer
0
    where
    go :: a -> Text -> [Text]
go a
nesting Text
text
        | Text -> Bool
Text.null Text
post = [Text
text]
        | Text
"{-" Text -> Text -> Bool
`Text.isPrefixOf` Text
post =
            (if a
nesting forall a. Ord a => a -> a -> Bool
> a
0 then Text -> Text
strip Text
pre else Text
pre)
                forall a. a -> [a] -> [a]
: a -> Text -> [Text]
go (a
nestingforall a. Num a => a -> a -> a
+a
1) (Int -> Text -> Text
Text.drop Int
2 Text
post)
        | Bool
otherwise =
            (if a
nesting forall a. Eq a => a -> a -> Bool
== a
0 then Text
pre forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.take Int
2 Text
post else Text -> Text
strip Text
pre)
                forall a. a -> [a] -> [a]
: a -> Text -> [Text]
go (forall a. Ord a => a -> a -> a
max a
0 (a
nestingforall a. Num a => a -> a -> a
-a
1)) (Int -> Text -> Text
Text.drop Int
2 Text
post)
        where
        (Text
pre, Text
post) = Text -> Text -> Text -> (Text, Text)
breakOnFirst Text
"{-" Text
"-}" Text
text
        strip :: Text -> Text
strip = (Char -> Bool) -> Text -> Text
Text.filter (forall a. Eq a => a -> a -> Bool
==Char
'\n')

-- | Like 'Text.breakOn', but break either of two things.
breakOnFirst :: Text -> Text -> Text -> (Text, Text)
breakOnFirst :: Text -> Text -> Text -> (Text, Text)
breakOnFirst Text
a Text
b Text
text
    | Text -> Int
Text.length Text
aPre forall a. Ord a => a -> a -> Bool
<= Text -> Int
Text.length Text
bPre = (Text
aPre, Text
aPost)
    | Bool
otherwise = (Text
bPre, Text
bPost)
    where
    (Text
aPre, Text
aPost) = HasCallStack => Text -> Text -> (Text, Text)
Text.breakOn Text
a Text
text
    (Text
bPre, Text
bPost) = HasCallStack => Text -> Text -> (Text, Text)
Text.breakOn Text
b Text
text

-- * generate

moduleDeclaration :: FilePath -> Text
moduleDeclaration :: String -> Text
moduleDeclaration String
fname = Text
"module " forall a. Semigroup a => a -> a -> a
<> String -> Text
pathToModule String
fname forall a. Semigroup a => a -> a -> a
<> Text
" where"

makeImport :: FilePath -> Text
makeImport :: String -> Text
makeImport String
fname = Text
"import qualified " forall a. Semigroup a => a -> a -> a
<> String -> Text
pathToModule String
fname

pathToModule :: FilePath -> Text
pathToModule :: String -> Text
pathToModule =
    (Char -> Char) -> Text -> Text
Text.map Char -> Char
dot forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.dropExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
FilePath.normalise
    where dot :: Char -> Char
dot Char
c = if Char
c forall a. Eq a => a -> a -> Bool
== Char
'/' then Char
'.' else Char
c

-- * util

die :: Text -> IO a
die :: forall a. Text -> IO a
die Text
msg = do
    Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
IO.stderr Text
msg
    forall a. IO a
System.Exit.exitFailure