module GF.Compile.Multi (readMulti) where

import Data.List
import Data.Char

-- AR 29 November 2010
-- quick way of writing a multilingual lexicon and (with some more work) a grammar
-- also several modules in one file
-- file suffix .gfm (GF Multi)


{-
-- This multi-line comment is a possible file in the format.
-- comments are as in GF, one-liners

-- always start by declaring lang names as follows
> langs Eng Fin Swe

-- baseline rules: semicolon-separated line-by-line entries update abs and cncs, adding to S
cheers ; skål ; terveydeksi

-- alternatives within a language are comma-separated
cheers ; skål ; terveydeksi, kippis

-- more advanced: verbatim abstract rules prefixed by "> abs"
> abs cat Drink ;
> abs fun drink : Drink -> S ;

-- verbatim concrete rules prefixed by ">" and comma-separated language list
> Eng,Swe lin Gin = "gin" ; 

-- multiple modules: modules as usual. Each module has to start from a new line.
-- Should be UTF-8 encoded.

-}

{-
main = do
  xx <- getArgs
  if null xx then putStrLn usage else do 
    let (opts,file) = (init xx, last xx)
    (absn,cncns) <- readMulti opts file
    if elem "-pgf" xx 
      then do
         system ("gf -make -s -optimize-pgf " ++ unwords (map gfFile cncns))
         putStrLn $ "wrote " ++ absn ++ ".pgf"
      else return ()
-}

readMulti :: FilePath -> IO (FilePath,[FilePath])
readMulti :: FilePath -> IO (FilePath, [FilePath])
readMulti FilePath
file = do
  FilePath
src <- FilePath -> IO FilePath
readFile FilePath
file
  let multi :: Multi
multi = FilePath -> FilePath -> Multi
getMulti ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'.') FilePath
file) FilePath
src
      absn :: FilePath
absn  = Multi -> FilePath
absName Multi
multi
      cncns :: [FilePath]
cncns = Multi -> [FilePath]
cncNames Multi
multi
      raws :: [(FilePath, FilePath)]
raws  = Multi -> [(FilePath, FilePath)]
rawModules Multi
multi
  FilePath -> FilePath -> IO ()
writeFile (FilePath -> FilePath
gfFile FilePath
absn) (Multi -> FilePath
absCode Multi
multi)
  ((FilePath, FilePath) -> IO ()) -> [(FilePath, FilePath)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FilePath -> FilePath -> IO ()) -> (FilePath, FilePath) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> FilePath -> IO ()
writeFile) 
        [(FilePath -> FilePath
gfFile FilePath
cncn, FilePath -> FilePath -> [FilePath] -> FilePath
cncCode FilePath
absn FilePath
cncn [FilePath]
cod) | 
          FilePath
cncn <- Multi -> [FilePath]
cncNames Multi
multi, let cod :: [FilePath]
cod = [FilePath
r | (FilePath
la,FilePath
r) <- Multi -> [(FilePath, FilePath)]
cncRules Multi
multi, FilePath
la FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
cncn]]
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"wrote " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
gfFile (FilePath
absnFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
cncns))
  ((FilePath, FilePath) -> IO ()) -> [(FilePath, FilePath)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FilePath -> FilePath -> IO ()) -> (FilePath, FilePath) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> FilePath -> IO ()
writeFile) [(FilePath -> FilePath
gfFile FilePath
n,FilePath
s) | (FilePath
n,FilePath
s) <- [(FilePath, FilePath)]
raws] --- overwrites those above
  (FilePath, [FilePath]) -> IO (FilePath, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath
gfFile FilePath
absn, (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
gfFile [FilePath]
cncns)

data Multi = Multi {
  Multi -> [(FilePath, FilePath)]
rawModules :: [(String,String)],
  Multi -> FilePath
absName  :: String,
  Multi -> [FilePath]
cncNames :: [String],
  Multi -> FilePath
startCat :: String,
  Multi -> [FilePath]
absRules :: [String],
  Multi -> [(FilePath, FilePath)]
cncRules :: [(String,String)] -- lang,lin
  }

emptyMulti :: Multi 
emptyMulti :: Multi
emptyMulti = Multi :: [(FilePath, FilePath)]
-> FilePath
-> [FilePath]
-> FilePath
-> [FilePath]
-> [(FilePath, FilePath)]
-> Multi
Multi {
  rawModules :: [(FilePath, FilePath)]
rawModules = [],
  absName :: FilePath
absName  = FilePath
"Abs",
  cncNames :: [FilePath]
cncNames = [],
  startCat :: FilePath
startCat = FilePath
"S",
  absRules :: [FilePath]
absRules = [],
  cncRules :: [(FilePath, FilePath)]
cncRules = []
  }

absCode :: Multi -> String
absCode :: Multi -> FilePath
absCode Multi
multi = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
header FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
start [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse (Multi -> [FilePath]
absRules Multi
multi)) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"}"] where
  header :: FilePath
header = FilePath
"abstract " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Multi -> FilePath
absName Multi
multi FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" = {"
  start :: [FilePath]
start  = [FilePath
"flags startcat = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" ;", FilePath
"cat " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" ;"]
  cat :: FilePath
cat = Multi -> FilePath
startCat Multi
multi

cncCode :: String -> String -> [String] -> String
cncCode :: FilePath -> FilePath -> [FilePath] -> FilePath
cncCode FilePath
ab FilePath
cnc [FilePath]
rules = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
header FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
rules [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"}"]) where
  header :: FilePath
header = FilePath
"concrete " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cnc FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ab FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" = {"

getMulti :: String -> String -> Multi
getMulti :: FilePath -> FilePath -> Multi
getMulti FilePath
m FilePath
s = (Multi -> FilePath -> Multi) -> Multi -> [FilePath] -> Multi
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((FilePath -> Multi -> Multi) -> Multi -> FilePath -> Multi
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> Multi -> Multi
addMulti) (Multi
emptyMulti{absName :: FilePath
absName = FilePath
m}) ([FilePath] -> [FilePath]
modlines (FilePath -> [FilePath]
lines FilePath
s))

addMulti :: String -> Multi -> Multi
addMulti :: FilePath -> Multi -> Multi
addMulti FilePath
line Multi
multi = case FilePath
line of
  Char
'-':Char
'-':FilePath
_ -> Multi
multi
  FilePath
_ | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace FilePath
line -> Multi
multi
  Char
'>':FilePath
s -> case FilePath -> [FilePath]
words FilePath
s of
     FilePath
"langs":[FilePath]
ws -> let las :: [FilePath]
las = [Multi -> FilePath
absName Multi
multi FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
w | FilePath
w <- [FilePath]
ws] in Multi
multi {
       cncNames :: [FilePath]
cncNames = [FilePath]
las, 
       cncRules :: [(FilePath, FilePath)]
cncRules = [[(FilePath, FilePath)]] -> [(FilePath, FilePath)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(FilePath
la,FilePath
"lincat " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Multi -> FilePath
startCat Multi
multi FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" = Str ;"),
                           (FilePath
la,FilePath
"flags coding = utf8 ;")] | FilePath
la <- [FilePath]
las]
       }
     FilePath
"startcat":FilePath
c:[FilePath]
ws -> Multi
multi {startCat :: FilePath
startCat = FilePath
c}
     FilePath
"abs":[FilePath]
ws   -> Multi
multi {
       absRules :: [FilePath]
absRules = [FilePath] -> FilePath
unwords [FilePath]
ws FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Multi -> [FilePath]
absRules Multi
multi
       }
     FilePath
langs:[FilePath]
ws   -> Multi
multi {
       cncRules :: [(FilePath, FilePath)]
cncRules = [(Multi -> FilePath
absName Multi
multi FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
la, [FilePath] -> FilePath
unwords [FilePath]
ws) | FilePath
la <- Char -> FilePath -> [FilePath]
forall c. Eq c => c -> [c] -> [[c]]
chop Char
',' FilePath
langs] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ Multi -> [(FilePath, FilePath)]
cncRules Multi
multi
       }
  FilePath
_ -> case FilePath -> [FilePath]
words FilePath
line of
        FilePath
m:FilePath
name:[FilePath]
_ | FilePath -> Bool
isModule FilePath
m -> Multi
multi {
          rawModules :: [(FilePath, FilePath)]
rawModules = (FilePath
name,FilePath
line)(FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
:Multi -> [(FilePath, FilePath)]
rawModules Multi
multi
          } 
        [FilePath]
_ -> let (FilePath
cat,FilePath
fun,[FilePath]
lins) = FilePath -> FilePath -> (FilePath, FilePath, [FilePath])
getRules (Multi -> FilePath
startCat Multi
multi) FilePath
line in 
              Multi
multi {
               absRules :: [FilePath]
absRules = (FilePath
"fun " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fun FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" : " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" ;") FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Multi -> [FilePath]
absRules Multi
multi,
               cncRules :: [(FilePath, FilePath)]
cncRules = [FilePath] -> [FilePath] -> [(FilePath, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Multi -> [FilePath]
cncNames Multi
multi) [FilePath]
lins [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ Multi -> [(FilePath, FilePath)]
cncRules Multi
multi
               }

getRules :: String -> String -> (String,String,[String])
getRules :: FilePath -> FilePath -> (FilePath, FilePath, [FilePath])
getRules FilePath
cat FilePath
line = (FilePath
cat, FilePath
fun, ([FilePath] -> FilePath) -> [[FilePath]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map [FilePath] -> FilePath
lin [[FilePath]]
rss) where
  rss :: [[FilePath]]
rss = (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
unspace ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FilePath -> [FilePath]
forall c. Eq c => c -> [c] -> [[c]]
chop Char
',') ([FilePath] -> [[FilePath]]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> a -> b
$ Char -> FilePath -> [FilePath]
forall c. Eq c => c -> [c] -> [[c]]
chop Char
';' FilePath
line
  fun :: FilePath
fun = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
idChar ([FilePath] -> FilePath
forall a. [a] -> a
head ([[FilePath]] -> [FilePath]
forall a. [a] -> a
head [[FilePath]]
rss)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cat
  lin :: [FilePath] -> FilePath
lin [FilePath]
rs = FilePath
"lin " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fun FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords (FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"|" ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
quote [FilePath]
rs)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" ;"

chop :: Eq c => c -> [c] -> [[c]]
chop :: c -> [c] -> [[c]]
chop c
c [c]
cs = case (c -> Bool) -> [c] -> ([c], [c])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (c -> c -> Bool
forall a. Eq a => a -> a -> Bool
==c
c) [c]
cs of
  ([c]
w,c
_:[c]
cs2) -> [c]
w [c] -> [[c]] -> [[c]]
forall a. a -> [a] -> [a]
: c -> [c] -> [[c]]
forall c. Eq c => c -> [c] -> [[c]]
chop c
c [c]
cs2
  ([],[])   -> []
  ([c]
w,[c]
_)     -> [[c]
w]

-- remove spaces from beginning and end, leave them in the middle
unspace :: String -> String
unspace :: FilePath -> FilePath
unspace = [FilePath] -> FilePath
unwords ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words

quote :: String -> String
quote :: FilePath -> FilePath
quote FilePath
r = FilePath
"\"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
r FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\""

-- to guarantee that the char can be used in an ident
idChar :: Char -> Char
idChar :: Char -> Char
idChar Char
c = 
  if (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
47 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
58) Bool -> Bool -> Bool
|| (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
64 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
91) Bool -> Bool -> Bool
|| (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
96 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
123) 
  then Char
c
  else Char
'_'
 where n :: Int
n = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c


gfFile :: FilePath -> FilePath
gfFile :: FilePath -> FilePath
gfFile FilePath
f = FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".gf"

isModule :: String -> Bool
isModule :: FilePath -> Bool
isModule = (FilePath -> [FilePath] -> Bool) -> [FilePath] -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem 
  [FilePath
"abstract",FilePath
"concrete",FilePath
"incomplete",FilePath
"instance",FilePath
"interface",FilePath
"resource"]

modlines :: [String] -> [String]
modlines :: [FilePath] -> [FilePath]
modlines [FilePath]
ss = case [FilePath]
ss of
  FilePath
l:[FilePath]
ls -> case FilePath -> [FilePath]
words FilePath
l of
    FilePath
w:[FilePath]
_ | FilePath -> Bool
isModule FilePath
w -> case (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (FilePath -> Bool
isModule (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
take Int
1 ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) [FilePath]
ls of
      ([FilePath]
ms,[FilePath]
rest) -> [FilePath] -> FilePath
unlines (FilePath
lFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
ms) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath] -> [FilePath]
modlines [FilePath]
rest
    [FilePath]
_ -> FilePath
l FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath] -> [FilePath]
modlines [FilePath]
ls
  [FilePath]
_ -> []