{-# LANGUAGE CPP #-}
module PGFService(cgiMain,cgiMain',getPath,
                  logFile,stderrToFile,
                  Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where

import PGF (PGF,Labels,CncLabels)
import GF.Text.Lexing
import qualified PGF
import Cache
import CGIUtils(outputJSONP,outputPlain,outputHTML,outputText,
                outputBinary,outputBinary',
                logError,handleCGIErrors,throwCGIError,stderrToFile)
import CGI(CGI,readInput,getInput,getVarWithDefault,
           CGIResult,requestAcceptLanguage,handleErrors,setHeader,
           Accept(..),Language(..),negotiate,liftIO)
import URLEncoding

#if C_RUNTIME
import qualified PGF2 as C
--import Data.Time.Clock(getCurrentTime,diffUTCTime)
#endif

import Data.Time.Clock(UTCTime)
import Data.Time.Format(formatTime)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
#else
import System.Locale(defaultTimeLocale,rfc822DateFormat)
#endif
import Text.JSON
import Text.PrettyPrint as PP(render, text, (<+>))
import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
import qualified Data.ByteString.Lazy as BS

import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.State(State,evalState,get,put)
import Control.Monad.Catch(bracket_)
import Data.Char
--import Data.Function (on)
import Data.List ({-sortBy,-}intersperse,mapAccumL,nub,isSuffixOf,nubBy,stripPrefix)
import qualified Data.Map as Map
import Data.Maybe
import System.Random
import System.Process
import System.Exit
import System.IO
import System.IO.Error(isDoesNotExistError)
import System.Directory(removeFile)
import System.FilePath(dropExtension,takeDirectory,(</>),(<.>))
import System.Mem(performGC)
import Fold(fold) -- transfer function for OpenMath LaTeX

catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
catchIOE :: IO a -> (IOException -> IO a) -> IO a
catchIOE = IO a -> (IOException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch

withQSem :: QSem -> m b -> m b
withQSem QSem
qsem = m () -> m () -> m b -> m b
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
waitQSem QSem
qsem) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
signalQSem QSem
qsem)

logFile :: FilePath
logFile :: FilePath
logFile = FilePath
"pgf-error.log"

#ifdef C_RUNTIME
data Caches = Caches { pgfCache::Cache PGF,
                       labelsCache::Cache Labels,
                       cncLabelsCache::Cache CncLabels,
                       cpgfCache::(Cache (C.PGF,({-MVar ParseCache-})),QSem) }
--type Caches = (Cache PGF,Cache (C.PGF,({-MVar ParseCache-})))
--type ParseCache = Map.Map (String,String) (ParseResult,UTCTime)
--type ParseResult = Either String [(C.Expr,Float)]

newPGFCache jobs = do pgfCache <- newCache' PGF.readPGF
                      lblCache <- newCache' (fmap PGF.getDepLabels . readFile)
                      clblCache <- newCache'(fmap PGF.getCncDepLabels .readFile)
                      let n = maybe 4 id jobs
                      qsem <- newQSem n
                      cCache <- newCache' $ \ path -> do pgf <- C.readPGF path
                                                       --pc <- newMVar Map.empty
                                                         return (pgf,({-pc-}))
                      return $ Caches pgfCache lblCache clblCache (cCache,qsem)
flushPGFCache c = do flushCache (pgfCache c)
                     flushCache (labelsCache c)
                     flushCache (fst (cpgfCache c))
listPGFCache c = (,) # listCache (pgfCache c) % listCache (fst (cpgfCache c))
#else
data Caches = Caches { Caches -> Cache PGF
pgfCache::Cache PGF,
                       Caches -> Cache Labels
labelsCache::Cache Labels,
                       Caches -> Cache CncLabels
cncLabelsCache::Cache CncLabels }
newPGFCache :: p -> IO Caches
newPGFCache p
_ = do Cache PGF
pgfCache <- (FilePath -> IO PGF) -> IO (Cache PGF)
forall c. (FilePath -> IO c) -> IO (Cache c)
newCache' FilePath -> IO PGF
PGF.readPGF
                   Cache Labels
lblCache <- (FilePath -> IO Labels) -> IO (Cache Labels)
forall c. (FilePath -> IO c) -> IO (Cache c)
newCache' ((FilePath -> Labels) -> IO FilePath -> IO Labels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Labels
PGF.getDepLabels (IO FilePath -> IO Labels)
-> (FilePath -> IO FilePath) -> FilePath -> IO Labels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
readFile)
                   Cache CncLabels
clblCache <- (FilePath -> IO CncLabels) -> IO (Cache CncLabels)
forall c. (FilePath -> IO c) -> IO (Cache c)
newCache'((FilePath -> CncLabels) -> IO FilePath -> IO CncLabels
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> CncLabels
PGF.getCncDepLabels (IO FilePath -> IO CncLabels)
-> (FilePath -> IO FilePath) -> FilePath -> IO CncLabels
forall b c a. (b -> c) -> (a -> b) -> a -> c
.FilePath -> IO FilePath
readFile)
                   Caches -> IO Caches
forall (m :: * -> *) a. Monad m => a -> m a
return (Caches -> IO Caches) -> Caches -> IO Caches
forall a b. (a -> b) -> a -> b
$ Cache PGF -> Cache Labels -> Cache CncLabels -> Caches
Caches Cache PGF
pgfCache Cache Labels
lblCache Cache CncLabels
clblCache
flushPGFCache :: Caches -> IO ()
flushPGFCache Caches
c = Cache PGF -> IO ()
forall a. Cache a -> IO ()
flushCache (Caches -> Cache PGF
pgfCache Caches
c)

listPGFCache :: Caches -> IO ([(FilePath,UTCTime)],[(FilePath,UTCTime)])
listPGFCache :: Caches -> IO ([(FilePath, UTCTime)], [(FilePath, UTCTime)])
listPGFCache Caches
c = (,) ([(FilePath, UTCTime)]
 -> [(FilePath, UTCTime)]
 -> ([(FilePath, UTCTime)], [(FilePath, UTCTime)]))
-> IO [(FilePath, UTCTime)]
-> IO
     ([(FilePath, UTCTime)]
      -> ([(FilePath, UTCTime)], [(FilePath, UTCTime)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# Cache PGF -> IO [(FilePath, UTCTime)]
forall a. Cache a -> IO [(FilePath, UTCTime)]
listCache (Caches -> Cache PGF
pgfCache Caches
c) IO
  ([(FilePath, UTCTime)]
   -> ([(FilePath, UTCTime)], [(FilePath, UTCTime)]))
-> IO [(FilePath, UTCTime)]
-> IO ([(FilePath, UTCTime)], [(FilePath, UTCTime)])
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% [(FilePath, UTCTime)] -> IO [(FilePath, UTCTime)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
#endif

labelsCaches :: Caches -> (Cache Labels, Cache CncLabels)
labelsCaches Caches
c = (Caches -> Cache Labels
labelsCache Caches
c,Caches -> Cache CncLabels
cncLabelsCache Caches
c)

newCache' :: (FilePath -> IO c) -> IO (Cache c)
newCache' FilePath -> IO c
rd = do Cache c
c <- (FilePath -> IO c) -> IO (Cache c)
forall c. (FilePath -> IO c) -> IO (Cache c)
newCache FilePath -> IO c
rd
                  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Cache c -> IO ()
forall a. Cache a -> IO ()
clean Cache c
c
                  Cache c -> IO (Cache c)
forall (m :: * -> *) a. Monad m => a -> m a
return Cache c
c
  where
    clean :: Cache c -> IO ()
clean Cache c
c = do Int -> IO ()
threadDelay Int
2000000000 -- 2000 seconds, i.e. ~33 minutes
                 NominalDiffTime -> Cache c -> IO ()
forall c. NominalDiffTime -> Cache c -> IO ()
expireCache (NominalDiffTime
24NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*NominalDiffTime
60) Cache c
c -- 24 hours

getPath :: CGIT IO FilePath
getPath =
    do FilePath
path <- FilePath -> FilePath -> CGIT IO FilePath
forall (m :: * -> *).
MonadCGI m =>
FilePath -> FilePath -> m FilePath
getVarWithDefault FilePath
"PATH_TRANSLATED" FilePath
"" -- apache mod_fastcgi
       if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
path
          then FilePath -> FilePath -> CGIT IO FilePath
forall (m :: * -> *).
MonadCGI m =>
FilePath -> FilePath -> m FilePath
getVarWithDefault FilePath
"SCRIPT_FILENAME" FilePath
"" -- lighttpd
          else FilePath -> CGIT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path

cgiMain :: Caches -> CGI CGIResult
cgiMain :: Caches -> CGI CGIResult
cgiMain Caches
cache = CGI CGIResult -> CGI CGIResult
forall (m :: * -> *).
(MonadCGI m, MonadCatch m, MonadIO m) =>
m CGIResult -> m CGIResult
handleErrors (CGI CGIResult -> CGI CGIResult)
-> (CGI CGIResult -> CGI CGIResult)
-> CGI CGIResult
-> CGI CGIResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CGI CGIResult -> CGI CGIResult
handleCGIErrors (CGI CGIResult -> CGI CGIResult) -> CGI CGIResult -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$
                  Caches -> FilePath -> CGI CGIResult
cgiMain' Caches
cache (FilePath -> CGI CGIResult) -> CGIT IO FilePath -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CGIT IO FilePath
getPath

cgiMain' :: Caches -> FilePath -> CGI CGIResult
cgiMain' :: Caches -> FilePath -> CGI CGIResult
cgiMain' Caches
cache FilePath
path =
    do FilePath
command <- (Maybe FilePath -> FilePath)
-> CGIT IO (Maybe FilePath) -> CGIT IO FilePath
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"grammar" (FilePath -> FilePath
urlDecodeUnicode (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
UTF8.decodeString))
                        (FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"command")
       case FilePath
command of
         FilePath
"download" -> ByteString -> CGI CGIResult
outputBinary (ByteString -> CGI CGIResult)
-> CGIT IO ByteString -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FilePath -> IO ByteString) -> FilePath -> CGIT IO ByteString
forall b. (FilePath -> IO b) -> FilePath -> CGIT IO b
getFile FilePath -> IO ByteString
BS.readFile FilePath
path
         Char
'c':Char
'-':FilePath
_  -> Caches -> FilePath -> FilePath -> CGI CGIResult
forall p p p a. p -> p -> p -> CGI a
optionalCpgfMain Caches
cache FilePath
path FilePath
command
         FilePath
_ -> do (UTCTime, PGF)
tpgf <- (FilePath -> IO (UTCTime, PGF))
-> FilePath -> CGIT IO (UTCTime, PGF)
forall b. (FilePath -> IO b) -> FilePath -> CGIT IO b
getFile (Cache PGF -> FilePath -> IO (UTCTime, PGF)
forall a. Cache a -> FilePath -> IO (UTCTime, a)
readCache' (Caches -> Cache PGF
pgfCache Caches
cache)) FilePath
path
                 (Cache Labels, Cache CncLabels)
-> FilePath -> FilePath -> (UTCTime, PGF) -> CGI CGIResult
pgfMain (Caches -> (Cache Labels, Cache CncLabels)
labelsCaches Caches
cache) FilePath
path FilePath
command (UTCTime, PGF)
tpgf

optionalCpgfMain :: p -> p -> p -> CGI a
optionalCpgfMain p
cache p
path p
command =
#ifdef C_RUNTIME
    cpgfMain (snd (cpgfCache cache)) command
       =<< getFile (readCache' (fst (cpgfCache cache))) path
#else
    FilePath -> FilePath -> CGI a
forall a. FilePath -> FilePath -> CGI a
serverError FilePath
"Server configured without C run-time support" FilePath
""

serverError :: FilePath -> FilePath -> CGI a
serverError = Int -> FilePath -> FilePath -> CGI a
forall a. Int -> FilePath -> FilePath -> CGI a
throw Int
500

#endif

getFile :: (FilePath -> IO b) -> FilePath -> CGIT IO b
getFile FilePath -> IO b
get FilePath
path =
   (IOException -> CGIT IO b)
-> (b -> CGIT IO b) -> Either IOException b -> CGIT IO b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> CGIT IO b
forall a. IOException -> CGI a
failed b -> CGIT IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (Either IOException b -> CGIT IO b)
-> CGIT IO (Either IOException b) -> CGIT IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either IOException b) -> CGIT IO (Either IOException b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> IO (Either IOException b)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (FilePath -> IO b
get FilePath
path))
  where
    failed :: IOException -> CGI a
failed IOException
e = if IOException -> Bool
isDoesNotExistError IOException
e
               then FilePath -> CGI a
forall a. FilePath -> CGI a
notFound FilePath
path
               else IO a -> CGI a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> CGI a) -> IO a -> CGI a
forall a b. (a -> b) -> a -> b
$ IOException -> IO a
forall a. IOException -> IO a
ioError IOException
e

--------------------------------------------------------------------------------
-- * C run-time functionality

#ifdef C_RUNTIME
--cpgfMain :: String -> (C.PGF,MVar ParseCache) -> CGI CGIResult
cpgfMain qsem command (t,(pgf,pc)) =
  case command of
    "c-parse"       -> withQSem qsem $
                       out t=<< join (parse # input % cat % start % limit % treeopts)
    "c-parseToChart"-> withQSem qsem $
                       out t=<< join (parseToChart # input % cat % limit)
    "c-linearize"   -> out t=<< lin # tree % to
    "c-bracketedLinearize"
                    -> out t=<< bracketedLin # tree % to
    "c-linearizeAll"-> out t=<< linAll # tree % to
    "c-translate"   -> withQSem qsem $
                       out t=<<join(trans # input % cat % to % start % limit%treeopts)
    "c-lookupmorpho"-> out t=<< morpho # from1 % textInput
    "c-lookupcohorts"->out t=<< cohorts # from1 % getInput "filter" % textInput
    "c-flush"       -> out t=<< flush
    "c-grammar"     -> out t grammar
    "c-abstrtree"   -> outputGraphviz=<< C.graphvizAbstractTree pgf C.graphvizDefaults # tree
    "c-parsetree"   -> outputGraphviz=<< (\cnc -> C.graphvizParseTree cnc C.graphvizDefaults) . snd # from1 %tree
    "c-wordforword" -> out t =<< wordforword # input % cat % to
    _               -> badRequest "Unknown command" command
  where
    flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
                        performGC
                        return $ showJSON ()

    cat :: CGI C.Type
    cat =
       do mcat  <- getInput1 "cat"
          case mcat of
            Nothing -> return (C.startCat pgf)
            Just cat -> case C.readType cat of
                          Nothing  -> badRequest "Bad category" cat
                          Just typ -> return typ

    langs = C.languages pgf

    grammar = showJSON $ makeObj
                 ["name".=C.abstractName pgf,
                  "lastmodified".=show t,
                  "startcat".=C.showType [] (C.startCat pgf),
                  "languages".=languages]
      where
        languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]

    parse input@((from,_),_) cat start mlimit (trie,json) =
        do r <- parse' cat start mlimit input
           return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]

    jsonParseResult json = either bad good
      where
        bad err = ["parseFailed".=err]
        good trees = "trees".=map tp trees :[]  -- :addTrie trie trees
        tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])

    -- Without caching parse results:
    parse' cat start mlimit ((from,concr),input) =
        case C.parseWithHeuristics concr cat input (-1) callbacks of
          C.ParseOk ts        -> return (Right (maybe id take mlimit (drop start ts)))
          C.ParseFailed _ tok -> return (Left tok)
          C.ParseIncomplete   -> return (Left "")
      where
        callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
        cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]
{-
    -- Caching parse results:
    parse' start mlimit ((from,concr),input) = 
        liftIO $ do t <- getCurrentTime
                    fmap (maybe id take mlimit . drop start)
                      # modifyMVar pc (parse'' t)
      where
        key = (from,input)
        parse'' t pc = maybe new old $ Map.lookup key pc
          where
            new = return (update (res,t) pc,res)
              where res = C.parse concr cat input
            old (res,_) = return (update (res,t) pc,res)
            update r = Map.mapMaybe purge . Map.insert key r
            purge r@(_,t') = if diffUTCTime t t'<120 then Just r else Nothing
                             -- remove unused parse results after 2 minutes
-}

    parseToChart ((from,concr),input) cat mlimit =
      do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
                C.ParseOk chart     -> return (good chart)
                C.ParseFailed _ tok -> return (bad tok)
                C.ParseIncomplete   -> return (bad "")
         return $ showJSON [makeObj ("from".=from:r)]
      where
        callbacks = maybe [] cb $ lookup (C.abstractName pgf) C.literalCallbacks
        cb fs = [(cat,f pgf (from,concr) input)|(cat,f)<-fs]

        bad  err           = ["parseFailed".=err]
        good (roots,chart) = ["roots".=showJSON roots,
                              "chart".=makeObj [show fid .= mkChartObj inf | (fid,inf)<-Map.toList chart]]

        mkChartObj (brackets,prods,cat) =
          makeObj ["brackets".=map mkChartBracket brackets
                  ,"prods"   .=map mkChartProd prods
                  ,"cat"     .=cat
                  ]

        mkChartBracket (s,e,ann) =
          makeObj ["start".=s,"end".=e,"ann".=ann]

        mkChartProd (expr,args,prob) =
          makeObj ["tree".=expr,"args".=map mkChartPArg args,"prob".=prob]

        mkChartPArg (C.PArg _ fid) = showJSON fid

    linAll tree to = showJSON (linAll' tree to)
    linAll' tree (tos,unlex) =
        [makeObj ["to".=to,
                  "texts".=map unlex (C.linearizeAll c tree)]|(to,c)<-tos]

    lin tree to = showJSON (lin' tree to)
    lin' tree (tos,unlex) =
        [makeObj ["to".=to,"text".=unlex (C.linearize c tree)]|(to,c)<-tos]

    bracketedLin tree to = showJSON (bracketedLin' tree to)
    bracketedLin' tree (tos,unlex) =
        [makeObj ["to".=to,"brackets".=showJSON (C.bracketedLinearize c tree)]|(to,c)<-tos]

    trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
      do parses <- parse' cat start mlimit input
         return $
           showJSON [ makeObj ["from".=from,
                               "translations".= jsonParses parses]]
      where
        jsonParses = either bad good
          where
            bad err = [makeObj ["error".=err]]
            good parses = [makeObj (addTree jsontree tree++
                                    ["prob".=prob,
                                     "linearizations".=lin' tree to])
                                    | (tree,prob) <- parses]

    morpho (from,concr) input =
        showJSON [makeObj ["lemma".=l
                          ,"analysis".=a
                          ,"prob".=p]
                     | (l,a,p)<-C.lookupMorpho concr input]

    cohorts (from,concr) filter input =
      showJSON [makeObj ["start" .=showJSON s
                        ,"word"  .=showJSON w
                        ,"morpho".=showJSON [makeObj ["lemma".=l
                                                     ,"analysis".=a
                                                     ,"prob".=p] 
                                                | (l,a,p)<-ms]
                        ,"end"   .=showJSON e
                        ]
                   | (s,w,ms,e) <- (case filter of
                                      Just "longest" -> C.filterLongest
                                      Just "best"    -> C.filterBest
                                      _              -> id)
                                     (C.lookupCohorts concr input)]

    wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat

    jsonWFW from rs =
      showJSON
        [makeObj
          ["from".=from,
           "translations".=[makeObj ["linearizations".=
                                        [makeObj["to".=to,"text".=text]
                                         | (to,text)<-rs]]]]]

    wordforword' inp@((from,concr),input) cat (tos,unlex) =
        [(to,unlex . unwords $ map (lin_word' c) pws)
         |let pws=map parse_word' (words input),(to,c)<-tos]
      where
        lin_word' c = either id (lin1 c)

        lin1 c = dropq . C.linearize c
          where
            dropq (q:' ':s) | q `elem` "+*" = s
            dropq s = s

        parse_word' w = if all (\c->isSpace c||isPunctuation c) w
                        then Left w
                        else parse_word w


        parse_word w =
            maybe (Left ("["++w++"]")) Right $
            msum [parse1 w,parse1 ow,morph w,morph ow]
          where
            ow = case w of
                   c:cs | isLower c -> toUpper c : cs
                        | isUpper c -> toLower c : cs
                   s                -> s

            parse1 s = case C.parse concr cat s of
                         C.ParseOk ((t,_):ts) -> Just t
                         _                    -> Nothing
            morph w = listToMaybe
                        [t | (f,a,p)<-C.lookupMorpho concr w,
                             t<-maybeToList (C.readExpr f)]

    ---

    input = lexit # from % textInput
      where
        lexit (from,lex) input = (from,lex input)

        from = maybe (missing "from") getlexer =<< from'
          where
            getlexer f@(_,concr) = (,) f # c_lexer concr

    from1 = maybe (missing "from") return =<< from'
    from' = getLang "from"

    to = (,) # getLangs "to" % unlexerC (const False)

    getLangs = getLangs' readLang
    getLang = getLang' readLang

    readLang :: String -> CGI (String,C.Concr)
    readLang lang =
      case Map.lookup lang langs of
        Nothing -> badRequest "Bad language" lang
        Just c -> return (lang,c)

    tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
              let t = C.readExpr s
              maybe (badRequest "bad tree" s) return t

    c_lexer concr = lexer (not . null . C.lookupMorpho concr)

--------------------------------------------------------------------------------

{-
instance JSON C.CId where
    readJSON x = readJSON x >>= maybe (fail "Bad language.") return . C.readCId
    showJSON = showJSON . C.showCId
-}
instance JSON C.Expr where
    readJSON x = readJSON x >>= maybe (fail "Bad expression.") return . C.readExpr
    showJSON = showJSON . C.showExpr []


-- | Convert a 'Tree' to an 'ATree'
cToATree :: C.Expr -> PGF.ATree C.Expr
cToATree e = maybe (PGF.Other e) app (C.unApp e)
  where
    app (f,es) = PGF.App (read f) (map cToATree es)

instance ToATree C.Expr where
  showTree = show
  toATree = cToATree

#endif

--------------------------------------------------------------------------------
-- * Lexing

-- | Standard lexers
lexer :: (FilePath -> Bool) -> CGIT IO (FilePath -> FilePath)
lexer FilePath -> Bool
good = CGIT IO (FilePath -> FilePath)
-> (FilePath -> CGIT IO (FilePath -> FilePath))
-> Maybe FilePath
-> CGIT IO (FilePath -> FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((FilePath -> FilePath) -> CGIT IO (FilePath -> FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath -> FilePath
forall a. a -> a
id) FilePath -> CGIT IO (FilePath -> FilePath)
lexerfun (Maybe FilePath -> CGIT IO (FilePath -> FilePath))
-> CGIT IO (Maybe FilePath) -> CGIT IO (FilePath -> FilePath)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"lexer" 
  where
    lexerfun :: FilePath -> CGIT IO (FilePath -> FilePath)
lexerfun FilePath
name =
      case (FilePath -> Bool) -> FilePath -> Maybe (FilePath -> FilePath)
stringOp FilePath -> Bool
good (FilePath
"lex"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
name) of
        Just FilePath -> FilePath
fn -> (FilePath -> FilePath) -> CGIT IO (FilePath -> FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath -> FilePath
fn
        Maybe (FilePath -> FilePath)
Nothing -> FilePath -> FilePath -> CGIT IO (FilePath -> FilePath)
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Unknown lexer" FilePath
name


type Unlexer = String->String

-- | Unlexing for the C runtime system, &+ is already applied
unlexerC :: (String -> Bool) -> CGI Unlexer
unlexerC :: (FilePath -> Bool) -> CGIT IO (FilePath -> FilePath)
unlexerC = (FilePath -> FilePath)
-> (FilePath -> Bool) -> CGIT IO (FilePath -> FilePath)
unlexer' FilePath -> FilePath
forall a. a -> a
id

-- | Unlexing for the Haskell runtime system, the default is to just apply &+
unlexerH :: CGI Unlexer
unlexerH :: CGIT IO (FilePath -> FilePath)
unlexerH = (FilePath -> FilePath)
-> (FilePath -> Bool) -> CGIT IO (FilePath -> FilePath)
unlexer' ([FilePath] -> FilePath
unwords ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
bindTok ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
False)

unlexer' :: (FilePath -> FilePath)
-> (FilePath -> Bool) -> CGIT IO (FilePath -> FilePath)
unlexer' FilePath -> FilePath
defaultUnlexer FilePath -> Bool
good =
    CGIT IO (FilePath -> FilePath)
-> (FilePath -> CGIT IO (FilePath -> FilePath))
-> Maybe FilePath
-> CGIT IO (FilePath -> FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((FilePath -> FilePath) -> CGIT IO (FilePath -> FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath -> FilePath
defaultUnlexer) FilePath -> CGIT IO (FilePath -> FilePath)
unlexerfun (Maybe FilePath -> CGIT IO (FilePath -> FilePath))
-> CGIT IO (Maybe FilePath) -> CGIT IO (FilePath -> FilePath)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"unlexer"
  where
    unlexerfun :: FilePath -> CGIT IO (FilePath -> FilePath)
unlexerfun FilePath
name =
       case (FilePath -> Bool) -> FilePath -> Maybe (FilePath -> FilePath)
stringOp FilePath -> Bool
good (FilePath
"unlex"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
name) of
         Just FilePath -> FilePath
fn -> (FilePath -> FilePath) -> CGIT IO (FilePath -> FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath
fn (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
cleanMarker)
         Maybe (FilePath -> FilePath)
Nothing -> FilePath -> FilePath -> CGIT IO (FilePath -> FilePath)
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Unknown unlexer" FilePath
name
    
    cleanMarker :: FilePath -> FilePath
cleanMarker (Char
'+':FilePath
cs) = FilePath
cs
    cleanMarker (Char
'*':FilePath
cs) = FilePath
cs
    cleanMarker FilePath
cs       = FilePath
cs

--------------------------------------------------------------------------------
-- * Haskell run-time functionality

--pgfMain :: Cache Labels -> FilePath -> String -> PGF -> CGI CGIResult
pgfMain :: (Cache Labels, Cache CncLabels)
-> FilePath -> FilePath -> (UTCTime, PGF) -> CGI CGIResult
pgfMain lcs :: (Cache Labels, Cache CncLabels)
lcs@(Cache Labels
alc,Cache CncLabels
clc) FilePath
path FilePath
command tpgf :: (UTCTime, PGF)
tpgf@(UTCTime
t,PGF
pgf) =
    case FilePath
command of
      FilePath
"parse"          -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> From -> Maybe Type -> Maybe Int -> TreeOpts -> JSValue
doParse PGF
pgf (From -> Maybe Type -> Maybe Int -> TreeOpts -> JSValue)
-> CGIT IO From
-> CGIT IO (Maybe Type -> Maybe Int -> TreeOpts -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO From
input CGIT IO (Maybe Type -> Maybe Int -> TreeOpts -> JSValue)
-> CGIT IO (Maybe Type)
-> CGIT IO (Maybe Int -> TreeOpts -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Type)
cat CGIT IO (Maybe Int -> TreeOpts -> JSValue)
-> CGIT IO (Maybe Int) -> CGIT IO (TreeOpts -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Int)
limit CGIT IO (TreeOpts -> JSValue)
-> CGIT IO TreeOpts -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO TreeOpts
treeopts
      FilePath
"complete"       -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> From -> Maybe Type -> Maybe Int -> Bool -> JSValue
doComplete PGF
pgf (From -> Maybe Type -> Maybe Int -> Bool -> JSValue)
-> CGIT IO From
-> CGIT IO (Maybe Type -> Maybe Int -> Bool -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO From
input CGIT IO (Maybe Type -> Maybe Int -> Bool -> JSValue)
-> CGIT IO (Maybe Type) -> CGIT IO (Maybe Int -> Bool -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Type)
cat CGIT IO (Maybe Int -> Bool -> JSValue)
-> CGIT IO (Maybe Int) -> CGIT IO (Bool -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Int)
limit CGIT IO (Bool -> JSValue) -> CGIT IO Bool -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO Bool
full
      FilePath
"linearize"      -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> Tree -> To -> JSValue
doLinearize PGF
pgf (Tree -> To -> JSValue) -> CGIT IO Tree -> CGIT IO (To -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO Tree
tree CGIT IO (To -> JSValue) -> CGIT IO To -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO To
to
      FilePath
"linearizeAll"   -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> Tree -> To -> JSValue
doLinearizes PGF
pgf (Tree -> To -> JSValue) -> CGIT IO Tree -> CGIT IO (To -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO Tree
tree CGIT IO (To -> JSValue) -> CGIT IO To -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO To
to
      FilePath
"linearizeTable" -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> Tree -> To -> JSValue
doLinearizeTabular PGF
pgf (Tree -> To -> JSValue) -> CGIT IO Tree -> CGIT IO (To -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO Tree
tree CGIT IO (To -> JSValue) -> CGIT IO To -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO To
to
      FilePath
"random"         -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CGIT IO (CGIT IO JSValue) -> CGIT IO JSValue
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (PGF
-> Maybe Type -> Maybe Int -> Maybe Int -> To -> CGIT IO JSValue
doRandom PGF
pgf (Maybe Type -> Maybe Int -> Maybe Int -> To -> CGIT IO JSValue)
-> CGIT IO (Maybe Type)
-> CGIT IO (Maybe Int -> Maybe Int -> To -> CGIT IO JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO (Maybe Type)
cat CGIT IO (Maybe Int -> Maybe Int -> To -> CGIT IO JSValue)
-> CGIT IO (Maybe Int)
-> CGIT IO (Maybe Int -> To -> CGIT IO JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Int)
depth CGIT IO (Maybe Int -> To -> CGIT IO JSValue)
-> CGIT IO (Maybe Int) -> CGIT IO (To -> CGIT IO JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Int)
limit CGIT IO (To -> CGIT IO JSValue)
-> CGIT IO To -> CGIT IO (CGIT IO JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO To
to)
      FilePath
"generate"       -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> Maybe Type -> Maybe Int -> Maybe Int -> To -> JSValue
doGenerate PGF
pgf (Maybe Type -> Maybe Int -> Maybe Int -> To -> JSValue)
-> CGIT IO (Maybe Type)
-> CGIT IO (Maybe Int -> Maybe Int -> To -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO (Maybe Type)
cat CGIT IO (Maybe Int -> Maybe Int -> To -> JSValue)
-> CGIT IO (Maybe Int) -> CGIT IO (Maybe Int -> To -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Int)
depth CGIT IO (Maybe Int -> To -> JSValue)
-> CGIT IO (Maybe Int) -> CGIT IO (To -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Int)
limit CGIT IO (To -> JSValue) -> CGIT IO To -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO To
to
      FilePath
"translate"      -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> From -> Maybe Type -> To -> Maybe Int -> TreeOpts -> JSValue
doTranslate PGF
pgf (From -> Maybe Type -> To -> Maybe Int -> TreeOpts -> JSValue)
-> CGIT IO From
-> CGIT IO (Maybe Type -> To -> Maybe Int -> TreeOpts -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO From
input CGIT IO (Maybe Type -> To -> Maybe Int -> TreeOpts -> JSValue)
-> CGIT IO (Maybe Type)
-> CGIT IO (To -> Maybe Int -> TreeOpts -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Type)
cat CGIT IO (To -> Maybe Int -> TreeOpts -> JSValue)
-> CGIT IO To -> CGIT IO (Maybe Int -> TreeOpts -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
%CGIT IO To
toCGIT IO (Maybe Int -> TreeOpts -> JSValue)
-> CGIT IO (Maybe Int) -> CGIT IO (TreeOpts -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
%CGIT IO (Maybe Int)
limitCGIT IO (TreeOpts -> JSValue)
-> CGIT IO TreeOpts -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
%CGIT IO TreeOpts
treeopts
      FilePath
"translategroup" -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> From -> Maybe Type -> To -> Maybe Int -> JSValue
doTranslateGroup PGF
pgf (From -> Maybe Type -> To -> Maybe Int -> JSValue)
-> CGIT IO From
-> CGIT IO (Maybe Type -> To -> Maybe Int -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO From
input CGIT IO (Maybe Type -> To -> Maybe Int -> JSValue)
-> CGIT IO (Maybe Type) -> CGIT IO (To -> Maybe Int -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Type)
cat CGIT IO (To -> Maybe Int -> JSValue)
-> CGIT IO To -> CGIT IO (Maybe Int -> JSValue)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO To
to CGIT IO (Maybe Int -> JSValue)
-> CGIT IO (Maybe Int) -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe Int)
limit
      FilePath
"lookupmorpho"   -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult) -> CGIT IO JSValue -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> Language -> FilePath -> JSValue
doLookupMorpho PGF
pgf (Language -> FilePath -> JSValue)
-> CGIT IO Language -> CGIT IO (FilePath -> JSValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO Language
from1 CGIT IO (FilePath -> JSValue)
-> CGIT IO FilePath -> CGIT IO JSValue
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO FilePath
textInput
      FilePath
"grammar"        -> CGIT IO (CGI CGIResult) -> CGI CGIResult
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (CGIT IO (CGI CGIResult) -> CGI CGIResult)
-> CGIT IO (CGI CGIResult) -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$ (UTCTime, PGF)
-> Either IOException (UTCTime, Labels)
-> Maybe (Accept Language)
-> CGI CGIResult
forall l.
(UTCTime, PGF)
-> Either IOException (UTCTime, l)
-> Maybe (Accept Language)
-> CGI CGIResult
doGrammar (UTCTime, PGF)
tpgf
                                       # liftIO (E.try (getLabels alc path pgf))
                                       CGIT IO (Maybe (Accept Language) -> CGI CGIResult)
-> CGIT IO (Maybe (Accept Language)) -> CGIT IO (CGI CGIResult)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe (Accept Language))
forall (m :: * -> *). MonadCGI m => m (Maybe (Accept Language))
requestAcceptLanguage
      FilePath
"abstrtree"      -> FilePath -> CGI CGIResult
outputGraphviz (FilePath -> CGI CGIResult) -> CGIT IO FilePath -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> GraphvizOptions -> Tree -> FilePath
abstrTree PGF
pgf (GraphvizOptions -> Tree -> FilePath)
-> CGIT IO GraphvizOptions -> CGIT IO (Tree -> FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO GraphvizOptions
graphvizOptions CGIT IO (Tree -> FilePath) -> CGIT IO Tree -> CGIT IO FilePath
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO Tree
tree
      FilePath
"alignment"      -> FilePath -> CGI CGIResult
outputGraphviz (FilePath -> CGI CGIResult) -> CGIT IO FilePath -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> Tree -> To -> FilePath
forall b. PGF -> Tree -> ([Language], b) -> FilePath
alignment PGF
pgf (Tree -> To -> FilePath)
-> CGIT IO Tree -> CGIT IO (To -> FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO Tree
tree CGIT IO (To -> FilePath) -> CGIT IO To -> CGIT IO FilePath
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO To
to
      FilePath
"parsetree"      -> FilePath -> CGI CGIResult
outputGraphviz (FilePath -> CGI CGIResult) -> CGIT IO FilePath -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGF -> Language -> GraphvizOptions -> Tree -> FilePath
parseTree PGF
pgf (Language -> GraphvizOptions -> Tree -> FilePath)
-> CGIT IO Language
-> CGIT IO (GraphvizOptions -> Tree -> FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO Language
from1 CGIT IO (GraphvizOptions -> Tree -> FilePath)
-> CGIT IO GraphvizOptions -> CGIT IO (Tree -> FilePath)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO GraphvizOptions
graphvizOptions CGIT IO (Tree -> FilePath) -> CGIT IO Tree -> CGIT IO FilePath
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO Tree
tree
      FilePath
"deptree"        -> CGIT IO (CGI CGIResult) -> CGI CGIResult
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (CGIT IO (CGI CGIResult) -> CGI CGIResult)
-> CGIT IO (CGI CGIResult) -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$ (Cache Labels, Cache CncLabels)
-> FilePath -> PGF -> FilePath -> Language -> Tree -> CGI CGIResult
doDepTree (Cache Labels, Cache CncLabels)
lcs FilePath
path PGF
pgf (FilePath -> Language -> Tree -> CGI CGIResult)
-> CGIT IO FilePath -> CGIT IO (Language -> Tree -> CGI CGIResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
format FilePath
"dot" CGIT IO (Language -> Tree -> CGI CGIResult)
-> CGIT IO Language -> CGIT IO (Tree -> CGI CGIResult)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO Language
to1 CGIT IO (Tree -> CGI CGIResult)
-> CGIT IO Tree -> CGIT IO (CGI CGIResult)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO Tree
tree
      FilePath
"abstrjson"      -> JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
o (JSValue -> CGI CGIResult)
-> (Tree -> JSValue) -> Tree -> CGI CGIResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> JSValue
forall a. (JSON a, ToATree a) => a -> JSValue
jsonExpr (Tree -> CGI CGIResult) -> CGIT IO Tree -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CGIT IO Tree
tree
      FilePath
"browse"         -> CGIT IO (CGI CGIResult) -> CGI CGIResult
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (CGIT IO (CGI CGIResult) -> CGI CGIResult)
-> CGIT IO (CGI CGIResult) -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$ PGF
-> Maybe Language
-> Maybe FilePath
-> Maybe FilePath
-> FilePath
-> Bool
-> CGI CGIResult
doBrowse PGF
pgf (Maybe Language
 -> Maybe FilePath
 -> Maybe FilePath
 -> FilePath
 -> Bool
 -> CGI CGIResult)
-> CGIT IO (Maybe Language)
-> CGIT
     IO
     (Maybe FilePath
      -> Maybe FilePath -> FilePath -> Bool -> CGI CGIResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# CGIT IO (Maybe Language)
optId CGIT
  IO
  (Maybe FilePath
   -> Maybe FilePath -> FilePath -> Bool -> CGI CGIResult)
-> CGIT IO (Maybe FilePath)
-> CGIT IO (Maybe FilePath -> FilePath -> Bool -> CGI CGIResult)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe FilePath)
cssClass CGIT IO (Maybe FilePath -> FilePath -> Bool -> CGI CGIResult)
-> CGIT IO (Maybe FilePath)
-> CGIT IO (FilePath -> Bool -> CGI CGIResult)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (Maybe FilePath)
href CGIT IO (FilePath -> Bool -> CGI CGIResult)
-> CGIT IO FilePath -> CGIT IO (Bool -> CGI CGIResult)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
format FilePath
"html" CGIT IO (Bool -> CGI CGIResult)
-> CGIT IO Bool -> CGIT IO (CGI CGIResult)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO Bool
getIncludePrintNames
      FilePath
"external"       -> do Maybe FilePath
cmd <- FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"external"
                             Maybe FilePath -> FilePath -> CGI CGIResult
doExternal Maybe FilePath
cmd (FilePath -> CGI CGIResult) -> CGIT IO FilePath -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CGIT IO FilePath
textInput
      FilePath
_                -> FilePath -> FilePath -> CGI CGIResult
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Unknown command" FilePath
command
  where
    o :: a -> CGI CGIResult
o a
x = UTCTime -> a -> CGI CGIResult
forall a t. (JSON a, FormatTime t) => t -> a -> CGI CGIResult
out UTCTime
t a
x

    input :: CGIT IO From
input = do Maybe Language
fr <- CGIT IO (Maybe Language)
from
               FilePath -> FilePath
lex <- Maybe Language -> CGIT IO (FilePath -> FilePath)
mlexer Maybe Language
fr
               FilePath
inp <- CGIT IO FilePath
textInput
               From -> CGIT IO From
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Language
fr,FilePath -> FilePath
lex FilePath
inp)

    mlexer :: Maybe Language -> CGIT IO (FilePath -> FilePath)
mlexer Maybe Language
Nothing     = (FilePath -> Bool) -> CGIT IO (FilePath -> FilePath)
lexer (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
False)
    mlexer (Just Language
lang) = (FilePath -> Bool) -> CGIT IO (FilePath -> FilePath)
lexer (Morpho -> FilePath -> Bool
PGF.isInMorpho Morpho
morpho)
      where morpho :: Morpho
morpho = PGF -> Language -> Morpho
PGF.buildMorpho PGF
pgf Language
lang

    tree :: CGI PGF.Tree
    tree :: CGIT IO Tree
tree = do Maybe FilePath
ms <- FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"tree"
              FilePath
s <- CGIT IO FilePath
-> (FilePath -> CGIT IO FilePath)
-> Maybe FilePath
-> CGIT IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> FilePath -> CGIT IO FilePath
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"No tree given" FilePath
"") FilePath -> CGIT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
ms
              Tree
t <- CGIT IO Tree
-> (Tree -> CGIT IO Tree) -> Maybe Tree -> CGIT IO Tree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> FilePath -> CGIT IO Tree
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Bad tree" FilePath
s) Tree -> CGIT IO Tree
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe Tree
PGF.readExpr FilePath
s)
              Tree
t <- (TcError -> CGIT IO Tree)
-> ((Tree, Type) -> CGIT IO Tree)
-> Either TcError (Tree, Type)
-> CGIT IO Tree
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\TcError
err -> FilePath -> FilePath -> CGIT IO Tree
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Type incorrect tree"
                                              ([FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
                                              [[Language] -> Tree -> FilePath
PGF.showExpr [] Tree
t
                                              ,Doc -> FilePath
render (FilePath -> Doc
PP.text FilePath
"error:" Doc -> Doc -> Doc
<+> TcError -> Doc
PGF.ppTcError TcError
err)
                                              ]))
                          (Tree -> CGIT IO Tree
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree -> CGIT IO Tree)
-> ((Tree, Type) -> Tree) -> (Tree, Type) -> CGIT IO Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree, Type) -> Tree
forall a b. (a, b) -> a
fst)
                          (PGF -> Tree -> Either TcError (Tree, Type)
PGF.inferExpr PGF
pgf Tree
t)
              Tree -> CGIT IO Tree
forall (m :: * -> *) a. Monad m => a -> m a
return Tree
t

    cat :: CGI (Maybe PGF.Type)
    cat :: CGIT IO (Maybe Type)
cat =
       do Maybe FilePath
mcat  <- FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput1 FilePath
"cat"
          case Maybe FilePath
mcat of
            Maybe FilePath
Nothing -> Maybe Type -> CGIT IO (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
            Just FilePath
cat -> case FilePath -> Maybe Type
PGF.readType FilePath
cat of
                          Maybe Type
Nothing  -> FilePath -> FilePath -> CGIT IO (Maybe Type)
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Bad category" FilePath
cat
                          Just Type
typ -> Maybe Type -> CGIT IO (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type -> CGIT IO (Maybe Type))
-> Maybe Type -> CGIT IO (Maybe Type)
forall a b. (a -> b) -> a -> b
$ Type -> Maybe Type
forall a. a -> Maybe a
Just Type
typ  -- typecheck the category

    optId :: CGI (Maybe PGF.CId)
    optId :: CGIT IO (Maybe Language)
optId = CGIT IO (Maybe Language)
-> (FilePath -> CGIT IO (Maybe Language))
-> Maybe FilePath
-> CGIT IO (Maybe Language)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Language -> CGIT IO (Maybe Language)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Language
forall a. Maybe a
Nothing) FilePath -> CGIT IO (Maybe Language)
rd (Maybe FilePath -> CGIT IO (Maybe Language))
-> CGIT IO (Maybe FilePath) -> CGIT IO (Maybe Language)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"id"
      where
        rd :: FilePath -> CGIT IO (Maybe Language)
rd = CGIT IO (Maybe Language)
-> (Language -> CGIT IO (Maybe Language))
-> Maybe Language
-> CGIT IO (Maybe Language)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CGIT IO (Maybe Language)
forall a. CGI a
err (Maybe Language -> CGIT IO (Maybe Language)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Language -> CGIT IO (Maybe Language))
-> (Language -> Maybe Language)
-> Language
-> CGIT IO (Maybe Language)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Maybe Language
forall a. a -> Maybe a
Just) (Maybe Language -> CGIT IO (Maybe Language))
-> (FilePath -> Maybe Language)
-> FilePath
-> CGIT IO (Maybe Language)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Language
PGF.readCId
        err :: CGI a
err = FilePath -> FilePath -> CGI a
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Bad identifier" []

    cssClass, href :: CGI (Maybe String)
    cssClass :: CGIT IO (Maybe FilePath)
cssClass = FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"css-class"
    href :: CGIT IO (Maybe FilePath)
href = FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"href"
    
    getIncludePrintNames :: CGI Bool
    getIncludePrintNames :: CGIT IO Bool
getIncludePrintNames = Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
True) (Maybe FilePath -> Bool)
-> CGIT IO (Maybe FilePath) -> CGIT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"printnames"

    graphvizOptions :: CGIT IO GraphvizOptions
graphvizOptions =
        Bool
-> Bool
-> Bool
-> Bool
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> GraphvizOptions
PGF.GraphvizOptions (Bool
 -> Bool
 -> Bool
 -> Bool
 -> FilePath
 -> FilePath
 -> FilePath
 -> FilePath
 -> FilePath
 -> FilePath
 -> GraphvizOptions)
-> CGIT IO Bool
-> CGIT
     IO
     (Bool
      -> Bool
      -> Bool
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> GraphvizOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> CGIT IO Bool
forall (f :: * -> *). MonadCGI f => FilePath -> f Bool
bool FilePath
"noleaves"
                            CGIT
  IO
  (Bool
   -> Bool
   -> Bool
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> GraphvizOptions)
-> CGIT IO Bool
-> CGIT
     IO
     (Bool
      -> Bool
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO Bool
forall (f :: * -> *). MonadCGI f => FilePath -> f Bool
bool FilePath
"nofun"
                            CGIT
  IO
  (Bool
   -> Bool
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> GraphvizOptions)
-> CGIT IO Bool
-> CGIT
     IO
     (Bool
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO Bool
forall (f :: * -> *). MonadCGI f => FilePath -> f Bool
bool FilePath
"nocat"
                            CGIT
  IO
  (Bool
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> GraphvizOptions)
-> CGIT IO Bool
-> CGIT
     IO
     (FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> FilePath
      -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO Bool
forall (f :: * -> *). MonadCGI f => FilePath -> f Bool
bool FilePath
"nodep"
                            CGIT
  IO
  (FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> FilePath
   -> GraphvizOptions)
-> CGIT IO FilePath
-> CGIT
     IO
     (FilePath
      -> FilePath -> FilePath -> FilePath -> FilePath -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
string FilePath
"nodefont"
                            CGIT
  IO
  (FilePath
   -> FilePath -> FilePath -> FilePath -> FilePath -> GraphvizOptions)
-> CGIT IO FilePath
-> CGIT
     IO
     (FilePath -> FilePath -> FilePath -> FilePath -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
string FilePath
"leaffont"
                            CGIT
  IO
  (FilePath -> FilePath -> FilePath -> FilePath -> GraphvizOptions)
-> CGIT IO FilePath
-> CGIT IO (FilePath -> FilePath -> FilePath -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
string FilePath
"nodecolor"
                            CGIT IO (FilePath -> FilePath -> FilePath -> GraphvizOptions)
-> CGIT IO FilePath
-> CGIT IO (FilePath -> FilePath -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
string FilePath
"leafcolor"
                            CGIT IO (FilePath -> FilePath -> GraphvizOptions)
-> CGIT IO FilePath -> CGIT IO (FilePath -> GraphvizOptions)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
string FilePath
"nodeedgestyle"
                            CGIT IO (FilePath -> GraphvizOptions)
-> CGIT IO FilePath -> CGIT IO GraphvizOptions
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
string FilePath
"leafedgestyle"
      where
        string :: FilePath -> f FilePath
string FilePath
name = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" FilePath -> FilePath
forall a. a -> a
id (Maybe FilePath -> FilePath) -> f (Maybe FilePath) -> f FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> f (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
name
        bool :: FilePath -> f Bool
bool FilePath
name = Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FilePath -> Bool
toBool (Maybe FilePath -> Bool) -> f (Maybe FilePath) -> f Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> f (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
name

    from1 :: CGIT IO Language
from1 = CGIT IO Language
-> (Language -> CGIT IO Language)
-> Maybe Language
-> CGIT IO Language
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> CGIT IO Language
forall a. FilePath -> CGI a
missing FilePath
"from") Language -> CGIT IO Language
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Language -> CGIT IO Language)
-> CGIT IO (Maybe Language) -> CGIT IO Language
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CGIT IO (Maybe Language)
from
    from :: CGIT IO (Maybe Language)
from = FilePath -> CGIT IO (Maybe Language)
getLang FilePath
"from"

    to1 :: CGIT IO Language
to1 = CGIT IO Language
-> (Language -> CGIT IO Language)
-> Maybe Language
-> CGIT IO Language
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> CGIT IO Language
forall a. FilePath -> CGI a
missing FilePath
"to") Language -> CGIT IO Language
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Language -> CGIT IO Language)
-> CGIT IO (Maybe Language) -> CGIT IO Language
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> CGIT IO (Maybe Language)
getLang FilePath
"to"
    to :: CGIT IO To
to = (,) ([Language] -> (FilePath -> FilePath) -> To)
-> CGIT IO [Language] -> CGIT IO ((FilePath -> FilePath) -> To)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> CGIT IO [Language]
getLangs FilePath
"to" CGIT IO ((FilePath -> FilePath) -> To)
-> CGIT IO (FilePath -> FilePath) -> CGIT IO To
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% CGIT IO (FilePath -> FilePath)
unlexerH

    getLangs :: FilePath -> CGIT IO [Language]
getLangs = (FilePath -> CGIT IO Language) -> FilePath -> CGIT IO [Language]
forall (m :: * -> *) b.
MonadCGI m =>
(FilePath -> m b) -> FilePath -> m [b]
getLangs' FilePath -> CGIT IO Language
readLang
    getLang :: FilePath -> CGIT IO (Maybe Language)
getLang = (FilePath -> CGIT IO Language)
-> FilePath -> CGIT IO (Maybe Language)
forall (m :: * -> *) a.
MonadCGI m =>
(FilePath -> m a) -> FilePath -> m (Maybe a)
getLang' FilePath -> CGIT IO Language
readLang

    readLang :: String -> CGI PGF.Language
    readLang :: FilePath -> CGIT IO Language
readLang FilePath
l =
      case FilePath -> Maybe Language
PGF.readLanguage FilePath
l of
        Maybe Language
Nothing -> FilePath -> FilePath -> CGIT IO Language
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Bad language" FilePath
l
        Just Language
lang | Language
lang Language -> [Language] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PGF -> [Language]
PGF.languages PGF
pgf -> Language -> CGIT IO Language
forall (m :: * -> *) a. Monad m => a -> m a
return Language
lang
                  | Bool
otherwise -> FilePath -> FilePath -> CGIT IO Language
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Unknown language" FilePath
l

    full :: CGI Bool
    full :: CGIT IO Bool
full = Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FilePath -> Bool
toBool (Maybe FilePath -> Bool)
-> CGIT IO (Maybe FilePath) -> CGIT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"full"

-- * Request parameter access and related auxiliary functions

--out = outputJSONP
out :: t -> a -> CGI CGIResult
out t
t a
r = do let fmt :: FilePath
fmt = TimeLocale -> FilePath -> t -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
rfc822DateFormat t
t
             FilePath -> FilePath -> CGIT IO ()
forall (m :: * -> *). MonadCGI m => FilePath -> FilePath -> m ()
setHeader FilePath
"Last-Modified" FilePath
fmt
             a -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
outputJSONP a
r

getInput1 :: FilePath -> f (Maybe FilePath)
getInput1 FilePath
x = Maybe FilePath -> Maybe FilePath
nonEmpty (Maybe FilePath -> Maybe FilePath)
-> f (Maybe FilePath) -> f (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> f (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
x
nonEmpty :: Maybe FilePath -> Maybe FilePath
nonEmpty (Just FilePath
"") = Maybe FilePath
forall a. Maybe a
Nothing
nonEmpty Maybe FilePath
r = Maybe FilePath
r

textInput :: CGI String
textInput :: CGIT IO FilePath
textInput = (Maybe FilePath -> FilePath)
-> CGIT IO (Maybe FilePath) -> CGIT IO FilePath
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath -> FilePath
urlDecodeUnicode (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
UTF8.decodeString)) (CGIT IO (Maybe FilePath) -> CGIT IO FilePath)
-> CGIT IO (Maybe FilePath) -> CGIT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> CGIT IO (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"input"

getLangs' :: (FilePath -> m b) -> FilePath -> m [b]
getLangs' FilePath -> m b
readLang FilePath
i = (FilePath -> m b) -> [FilePath] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> m b
readLang ([FilePath] -> m [b])
-> (Maybe FilePath -> [FilePath]) -> Maybe FilePath -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] FilePath -> [FilePath]
words (Maybe FilePath -> m [b]) -> m (Maybe FilePath) -> m [b]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> m (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
i

getLang' :: (FilePath -> m a) -> FilePath -> m (Maybe a)
getLang' FilePath -> m a
readLang FilePath
i =
   do Maybe FilePath
mlang <- FilePath -> m (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
i
      case Maybe FilePath
mlang of
        Just l :: FilePath
l@(Char
_:FilePath
_) -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> m a
readLang FilePath
l
        Maybe FilePath
_            -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing


limit, depth :: CGI (Maybe Int)
limit :: CGIT IO (Maybe Int)
limit = FilePath -> CGIT IO (Maybe Int)
forall a (m :: * -> *).
(Read a, MonadCGI m) =>
FilePath -> m (Maybe a)
readInput FilePath
"limit"
depth :: CGIT IO (Maybe Int)
depth = FilePath -> CGIT IO (Maybe Int)
forall a (m :: * -> *).
(Read a, MonadCGI m) =>
FilePath -> m (Maybe a)
readInput FilePath
"depth"

start :: CGI Int
start :: CGI Int
start = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Int -> Int
forall a. a -> a
id (Maybe Int -> Int) -> CGIT IO (Maybe Int) -> CGI Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> CGIT IO (Maybe Int)
forall a (m :: * -> *).
(Read a, MonadCGI m) =>
FilePath -> m (Maybe a)
readInput FilePath
"start"

treeopts :: CGI TreeOpts
treeopts :: CGIT IO TreeOpts
treeopts = (,) (Bool -> Bool -> TreeOpts)
-> CGIT IO Bool -> CGIT IO (Bool -> TreeOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> CGIT IO Bool
forall (f :: * -> *). MonadCGI f => FilePath -> f Bool
getBool FilePath
"trie" CGIT IO (Bool -> TreeOpts) -> CGIT IO Bool -> CGIT IO TreeOpts
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
% FilePath -> CGIT IO Bool
forall (f :: * -> *). MonadCGI f => FilePath -> f Bool
getBool FilePath
"jsontree"

getBool :: FilePath -> f Bool
getBool FilePath
x = Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FilePath -> Bool
toBool (Maybe FilePath -> Bool) -> f (Maybe FilePath) -> f Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> f (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
x
toBool :: FilePath -> Bool
toBool FilePath
s = FilePath
s FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"",FilePath
"yes",FilePath
"true",FilePath
"True"]

missing :: FilePath -> CGI a
missing = FilePath -> FilePath -> CGI a
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Missing parameter"
errorMissingId :: CGI a
errorMissingId = FilePath -> FilePath -> CGI a
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Missing identifier" FilePath
""

notFound :: FilePath -> CGI a
notFound = Int -> FilePath -> FilePath -> CGI a
forall a. Int -> FilePath -> FilePath -> CGI a
throw Int
404 FilePath
"Not found"
badRequest :: FilePath -> FilePath -> CGI a
badRequest = Int -> FilePath -> FilePath -> CGI a
forall a. Int -> FilePath -> FilePath -> CGI a
throw Int
400

throw :: Int -> FilePath -> FilePath -> CGI a
throw Int
code FilePath
msg FilePath
extra =
    Int -> FilePath -> [FilePath] -> CGI a
forall a. Int -> FilePath -> [FilePath] -> CGI a
throwCGIError Int
code FilePath
msg [FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++(if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
extra then FilePath
"" else FilePath
": "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
extra)]

format :: FilePath -> f FilePath
format FilePath
def = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
def FilePath -> FilePath
forall a. a -> a
id (Maybe FilePath -> FilePath) -> f (Maybe FilePath) -> f FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
# FilePath -> f (Maybe FilePath)
forall (m :: * -> *). MonadCGI m => FilePath -> m (Maybe FilePath)
getInput FilePath
"format"

-- * Request implementations

-- Hook for simple extensions of the PGF service
doExternal :: Maybe FilePath -> FilePath -> CGI CGIResult
doExternal Maybe FilePath
Nothing FilePath
input = FilePath -> FilePath -> CGI CGIResult
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Unknown external command" FilePath
""
doExternal (Just FilePath
cmd) FilePath
input =
  do IO () -> CGIT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CGIT IO ()) -> IO () -> CGIT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
logError (FilePath
"External command: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
cmd)
     [FilePath]
cmds <- IO [FilePath] -> CGIT IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> CGIT IO [FilePath])
-> IO [FilePath] -> CGIT IO [FilePath]
forall a b. (a -> b) -> a -> b
$ ((FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
lines (IO FilePath -> IO [FilePath]) -> IO FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
"external_services")
                        IO [FilePath] -> (IOException -> IO [FilePath]) -> IO [FilePath]
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIOE` IO [FilePath] -> IOException -> IO [FilePath]
forall a b. a -> b -> a
const ([FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
     IO () -> CGIT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CGIT IO ()) -> IO () -> CGIT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
logError (FilePath
"External services: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
cmds)
     if FilePath
cmd FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
cmds then CGI CGIResult
ok else CGI CGIResult
forall a. CGI a
err
  where
    err :: CGI a
err = FilePath -> FilePath -> CGI a
forall a. FilePath -> FilePath -> CGI a
badRequest FilePath
"Unknown external command" FilePath
cmd
    ok :: CGI CGIResult
ok =
      do let tmpfile1 :: FilePath
tmpfile1 = FilePath
"external_input.txt"
             tmpfile2 :: FilePath
tmpfile2 = FilePath
"external_output.txt"
         IO () -> CGIT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CGIT IO ()) -> IO () -> CGIT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile FilePath
"external_input.txt" FilePath
input
         IO ExitCode -> CGIT IO ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> CGIT IO ExitCode)
-> IO ExitCode -> CGIT IO ExitCode
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ExitCode
system (FilePath -> IO ExitCode) -> FilePath -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tmpfile1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" > " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tmpfile2
         IO () -> CGIT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CGIT IO ()) -> IO () -> CGIT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
tmpfile1
         CGIResult
r <- FilePath -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
outputJSONP (FilePath -> CGI CGIResult) -> CGIT IO FilePath -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath -> CGIT IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO FilePath
readFile FilePath
tmpfile2)
         IO () -> CGIT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CGIT IO ()) -> IO () -> CGIT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
tmpfile2
         CGIResult -> CGI CGIResult
forall (m :: * -> *) a. Monad m => a -> m a
return CGIResult
r

doLookupMorpho :: PGF -> PGF.Language -> String -> JSValue
doLookupMorpho :: PGF -> Language -> FilePath -> JSValue
doLookupMorpho PGF
pgf Language
from FilePath
input =
    [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"lemma"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
l,FilePath
"analysis"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath
a]|(Language
l,FilePath
a)<-[(Language, FilePath)]
ms]
  where
    ms :: [(Language, FilePath)]
ms = Morpho -> FilePath -> [(Language, FilePath)]
PGF.lookupMorpho (PGF -> Language -> Morpho
PGF.buildMorpho PGF
pgf Language
from) FilePath
input


type From = (Maybe PGF.Language,String)
type To = ([PGF.Language],Unlexer)
type TreeOpts = (Bool,Bool) -- (trie,jsontree)

doTranslate :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> TreeOpts -> JSValue
doTranslate :: PGF -> From -> Maybe Type -> To -> Maybe Int -> TreeOpts -> JSValue
doTranslate PGF
pgf (Maybe Language
mfrom,FilePath
input) Maybe Type
mcat To
tos Maybe Int
mlimit (Bool
trie,Bool
jsontree) =
  [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON
     [[(FilePath, JSValue)] -> JSValue
makeObj (FilePath
"from"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
from (FilePath, JSValue)
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. a -> [a] -> [a]
: FilePath
"brackets"FilePath -> BracketedString -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=BracketedString
bs (FilePath, JSValue)
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. a -> [a] -> [a]
: ParseOutput -> [(FilePath, JSValue)]
jsonTranslateOutput ParseOutput
po)
          | (Language
from,ParseOutput
po,BracketedString
bs) <- PGF
-> FilePath
-> Maybe Type
-> Maybe Language
-> [(Language, ParseOutput, BracketedString)]
parse' PGF
pgf FilePath
input Maybe Type
mcat Maybe Language
mfrom]
  where
    jsonTranslateOutput :: ParseOutput -> [(FilePath, JSValue)]
jsonTranslateOutput ParseOutput
output =
      case ParseOutput
output of
        PGF.ParseOk [Tree]
trees ->
            Bool -> [Tree] -> [(FilePath, JSValue)]
addTrie Bool
trie [Tree]
trees[(FilePath, JSValue)]
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. [a] -> [a] -> [a]
++
            [FilePath
"translations"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=
              [[(FilePath, JSValue)] -> JSValue
makeObj (Bool -> Tree -> [(FilePath, JSValue)]
forall a. (ToATree a, JSON a) => Bool -> a -> [(FilePath, JSValue)]
addTree Bool
jsontree Tree
tree[(FilePath, JSValue)]
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. [a] -> [a] -> [a]
++
                       [FilePath
"linearizations"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=
                            [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"to"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
to, FilePath
"text"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath
text,
                                      FilePath
"brackets"FilePath -> [BracketedString] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[BracketedString]
bs]
                               | (Language
to,FilePath
text,[BracketedString]
bs)<- PGF -> To -> Tree -> [(Language, FilePath, [BracketedString])]
forall b.
PGF
-> ([Language], FilePath -> b)
-> Tree
-> [(Language, b, [BracketedString])]
linearizeAndUnlex PGF
pgf To
tos Tree
tree]])
                | Tree
tree <- ([Tree] -> [Tree])
-> (Int -> [Tree] -> [Tree]) -> Maybe Int -> [Tree] -> [Tree]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Tree] -> [Tree]
forall a. a -> a
id Int -> [Tree] -> [Tree]
forall a. Int -> [a] -> [a]
take Maybe Int
mlimit [Tree]
trees]]
        ParseOutput
PGF.ParseIncomplete -> [FilePath
"incomplete"FilePath -> Bool -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Bool
True]
        PGF.ParseFailed Int
n   -> [FilePath
"parseFailed"FilePath -> Int -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Int
n]
        PGF.TypeError [(Int, TcError)]
errs -> [(Int, TcError)] -> [(FilePath, JSValue)]
forall a. JSON a => [(a, TcError)] -> [(FilePath, JSValue)]
jsonTypeErrors [(Int, TcError)]
errs

jsonTypeErrors :: [(a, TcError)] -> [(FilePath, JSValue)]
jsonTypeErrors [(a, TcError)]
errs = 
    [FilePath
"typeErrors"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"fid"FilePath -> a -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=a
fid, FilePath
"msg"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Doc -> FilePath
forall a. Show a => a -> FilePath
show (TcError -> Doc
PGF.ppTcError TcError
err)]
                       | (a
fid,TcError
err) <- [(a, TcError)]
errs]]

-- used in phrasebook
doTranslateGroup :: PGF -> From -> Maybe PGF.Type -> To -> Maybe Int -> JSValue
doTranslateGroup :: PGF -> From -> Maybe Type -> To -> Maybe Int -> JSValue
doTranslateGroup PGF
pgf (Maybe Language
mfrom,FilePath
input) Maybe Type
mcat To
tos Maybe Int
mlimit =
  [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON
    [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"from"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath -> FilePath
forall a. [a] -> [a]
langOnly (Language -> FilePath
PGF.showLanguage Language
from),
              FilePath
"to"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath -> FilePath
forall a. [a] -> [a]
langOnly (Language -> FilePath
PGF.showLanguage Language
to),
              FilePath
"linearizations"FilePath -> [JSObject FilePath] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=
                 [[(FilePath, FilePath)] -> JSObject FilePath
forall a. [(FilePath, a)] -> JSObject a
toJSObject ((FilePath
"text",FilePath
alt) (FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
: Int -> Language -> [Tree] -> [(FilePath, FilePath)]
forall a.
(Ord a, Num a) =>
a -> Language -> [Tree] -> [(FilePath, FilePath)]
disamb Int
lg Language
from [Tree]
ts)
                    | let lg :: Int
lg = [([Tree], FilePath)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [([Tree], FilePath)]
output, ([Tree]
ts,FilePath
alt) <- [([Tree], FilePath)]
output]
              ]
       | 
         (Language
from,ParseOutput
po,BracketedString
bs) <- PGF
-> FilePath
-> Maybe Type
-> Maybe Language
-> [(Language, ParseOutput, BracketedString)]
parse' PGF
pgf FilePath
input Maybe Type
mcat Maybe Language
mfrom,
         (Language
to,[([Tree], FilePath)]
output)  <- [(Tree, [(Language, FilePath, [BracketedString])])]
-> [(Language, [([Tree], FilePath)])]
forall t c.
[(t, [(Language, FilePath, c)])] -> [(Language, [([t], FilePath)])]
groupResults [(Tree
t, PGF -> To -> Tree -> [(Language, FilePath, [BracketedString])]
forall b.
PGF
-> ([Language], FilePath -> b)
-> Tree
-> [(Language, b, [BracketedString])]
linearizeAndUnlex PGF
pgf To
tos Tree
t) | Tree
t <- case ParseOutput
po of {PGF.ParseOk [Tree]
ts -> ([Tree] -> [Tree])
-> (Int -> [Tree] -> [Tree]) -> Maybe Int -> [Tree] -> [Tree]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Tree] -> [Tree]
forall a. a -> a
id Int -> [Tree] -> [Tree]
forall a. Int -> [a] -> [a]
take Maybe Int
mlimit [Tree]
ts; ParseOutput
_ -> []}]
          ]
  where
   groupResults :: [(t, [(Language, FilePath, c)])] -> [(Language, [([t], FilePath)])]
groupResults = Map Language [([t], FilePath)] -> [(Language, [([t], FilePath)])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Language [([t], FilePath)] -> [(Language, [([t], FilePath)])])
-> ([(t, [(Language, FilePath, c)])]
    -> Map Language [([t], FilePath)])
-> [(t, [(Language, FilePath, c)])]
-> [(Language, [([t], FilePath)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Language, [([t], FilePath)])
 -> Map Language [([t], FilePath)]
 -> Map Language [([t], FilePath)])
-> Map Language [([t], FilePath)]
-> [(Language, [([t], FilePath)])]
-> Map Language [([t], FilePath)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Language, [([t], FilePath)])
-> Map Language [([t], FilePath)] -> Map Language [([t], FilePath)]
forall k t t.
(Ord k, Eq t) =>
(k, [([t], t)]) -> Map k [([t], t)] -> Map k [([t], t)]
more Map Language [([t], FilePath)]
forall k a. Map k a
Map.empty ([(Language, [([t], FilePath)])] -> Map Language [([t], FilePath)])
-> ([(t, [(Language, FilePath, c)])]
    -> [(Language, [([t], FilePath)])])
-> [(t, [(Language, FilePath, c)])]
-> Map Language [([t], FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(t, (Language, FilePath))] -> [(Language, [([t], FilePath)])]
forall a a b. [(a, (a, b))] -> [(a, [([a], b)])]
start ([(t, (Language, FilePath))] -> [(Language, [([t], FilePath)])])
-> ([(t, [(Language, FilePath, c)])]
    -> [(t, (Language, FilePath))])
-> [(t, [(Language, FilePath, c)])]
-> [(Language, [([t], FilePath)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(t, [(Language, FilePath, c)])] -> [(t, (Language, FilePath))]
forall a b c. [(a, [(Language, b, c)])] -> [(a, (Language, b))]
collect
     where
       collect :: [(a, [(Language, b, c)])] -> [(a, (Language, b))]
collect [(a, [(Language, b, c)])]
tls = [(a
t,(Language
l,b
s)) | (a
t,[(Language, b, c)]
ls) <- [(a, [(Language, b, c)])]
tls, (Language
l,b
s,c
_) <- [(Language, b, c)]
ls, Language -> Bool
notDisamb Language
l]
       start :: [(a, (a, b))] -> [(a, [([a], b)])]
start [(a, (a, b))]
ls = [(a
l,[([a
t],b
s)]) | (a
t,(a
l,b
s)) <- [(a, (a, b))]
ls]
       more :: (k, [([t], t)]) -> Map k [([t], t)] -> Map k [([t], t)]
more (k
l,[([t], t)]
s) = ([([t], t)] -> [([t], t)] -> [([t], t)])
-> k -> [([t], t)] -> Map k [([t], t)] -> Map k [([t], t)]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\ [([t
t],t
x)] [([t], t)]
xs -> t -> t -> [([t], t)] -> [([t], t)]
forall t t. Eq t => t -> t -> [([t], t)] -> [([t], t)]
insertAlt t
t t
x [([t], t)]
xs) k
l [([t], t)]
s

   insertAlt :: t -> t -> [([t], t)] -> [([t], t)]
insertAlt t
t t
x [([t], t)]
xs = case [([t], t)]
xs of
     ([t]
ts,t
y):[([t], t)]
xs2 -> if t
xt -> t -> Bool
forall a. Eq a => a -> a -> Bool
==t
y then (t
tt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
ts,t
y)([t], t) -> [([t], t)] -> [([t], t)]
forall a. a -> [a] -> [a]
:[([t], t)]
xs2 -- if string is there add only tree
                   else ([t]
ts,t
y) ([t], t) -> [([t], t)] -> [([t], t)]
forall a. a -> [a] -> [a]
: t -> t -> [([t], t)] -> [([t], t)]
insertAlt t
t t
x [([t], t)]
xs2
     [([t], t)]
_ -> [([t
t],t
x)]

   langOnly :: [a] -> [a]
langOnly = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
3 ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

   disamb :: a -> Language -> [Tree] -> [(FilePath, FilePath)]
disamb a
lg Language
from [Tree]
ts = 
     if a
lg a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
2 
       then [] 
       else [(FilePath
"tree", FilePath
"-- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
groupDisambs [Language -> Tree -> FilePath
disambLang Language
from Tree
t | Tree
t <- [Tree]
ts])]

   groupDisambs :: [FilePath] -> FilePath
groupDisambs = [FilePath] -> FilePath
unwords ([FilePath] -> FilePath)
-> ([FilePath] -> [FilePath]) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"/"

   disambLang :: Language -> Tree -> FilePath
disambLang Language
f Tree
t = 
     let 
       disfl :: FilePath -> Language
disfl FilePath
lang = FilePath -> Language
PGF.mkCId (FilePath
"Disamb" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
lang) 
       disf :: Language
disf       = FilePath -> Language
disfl (Language -> FilePath
PGF.showLanguage Language
f) 
       disfEng :: Language
disfEng    = FilePath -> Language
disfl (FilePath -> FilePath
forall a. [a] -> [a]
reverse (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
3 (FilePath -> FilePath
forall a. [a] -> [a]
reverse (Language -> FilePath
PGF.showLanguage Language
f))) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Eng") 
     in
       if Language -> [Language] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Language
disf (PGF -> [Language]
PGF.languages PGF
pgf)         -- if Disamb f exists use it
         then PGF -> Language -> Tree -> FilePath
PGF.linearize PGF
pgf Language
disf Tree
t          
       else if Language -> [Language] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Language
disfEng (PGF -> [Language]
PGF.languages PGF
pgf) -- else try DisambEng
         then PGF -> Language -> Tree -> FilePath
PGF.linearize PGF
pgf Language
disfEng Tree
t 
       else FilePath
"AST " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Language] -> Tree -> FilePath
PGF.showExpr [] Tree
t                   -- else show abstract tree

   notDisamb :: Language -> Bool
notDisamb = (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/=FilePath
"Disamb") (FilePath -> Bool) -> (Language -> FilePath) -> Language -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
6 (FilePath -> FilePath)
-> (Language -> FilePath) -> Language -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> FilePath
PGF.showLanguage

doParse :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> TreeOpts -> JSValue
doParse :: PGF -> From -> Maybe Type -> Maybe Int -> TreeOpts -> JSValue
doParse PGF
pgf (Maybe Language
mfrom,FilePath
input) Maybe Type
mcat Maybe Int
mlimit (Bool
trie,Bool
jsontree) = [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON ([JSValue] -> JSValue) -> [JSValue] -> JSValue
forall a b. (a -> b) -> a -> b
$ ([(FilePath, JSValue)] -> JSValue)
-> [[(FilePath, JSValue)]] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map [(FilePath, JSValue)] -> JSValue
makeObj
     [FilePath
"from"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
from (FilePath, JSValue)
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. a -> [a] -> [a]
: FilePath
"brackets"FilePath -> BracketedString -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=BracketedString
bs (FilePath, JSValue)
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. a -> [a] -> [a]
: ParseOutput -> [(FilePath, JSValue)]
jsonParseOutput ParseOutput
po
        | (Language
from,ParseOutput
po,BracketedString
bs) <- PGF
-> FilePath
-> Maybe Type
-> Maybe Language
-> [(Language, ParseOutput, BracketedString)]
parse' PGF
pgf FilePath
input Maybe Type
mcat Maybe Language
mfrom]
  where
    jsonParseOutput :: ParseOutput -> [(FilePath, JSValue)]
jsonParseOutput ParseOutput
output =
      case ParseOutput
output of
        PGF.ParseOk [Tree]
trees   -> [FilePath
"trees"FilePath -> [Tree] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[Tree]
trees']
                               [(FilePath, JSValue)]
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. [a] -> [a] -> [a]
++[FilePath
"jsontrees"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=(Tree -> JSValue) -> [Tree] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map Tree -> JSValue
forall a. (JSON a, ToATree a) => a -> JSValue
jsonExpr [Tree]
trees'|Bool
jsontree]
                               [(FilePath, JSValue)]
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. [a] -> [a] -> [a]
++Bool -> [Tree] -> [(FilePath, JSValue)]
addTrie Bool
trie [Tree]
trees
          where trees' :: [Tree]
trees' = ([Tree] -> [Tree])
-> (Int -> [Tree] -> [Tree]) -> Maybe Int -> [Tree] -> [Tree]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Tree] -> [Tree]
forall a. a -> a
id Int -> [Tree] -> [Tree]
forall a. Int -> [a] -> [a]
take Maybe Int
mlimit [Tree]
trees
        PGF.TypeError [(Int, TcError)]
errs  -> [(Int, TcError)] -> [(FilePath, JSValue)]
forall a. JSON a => [(a, TcError)] -> [(FilePath, JSValue)]
jsonTypeErrors [(Int, TcError)]
errs
        ParseOutput
PGF.ParseIncomplete -> [FilePath
"incomplete"FilePath -> Bool -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Bool
True]
        PGF.ParseFailed Int
n   -> [FilePath
"parseFailed"FilePath -> Int -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Int
n]

addTrie :: Bool -> [Tree] -> [(FilePath, JSValue)]
addTrie Bool
trie [Tree]
trees =
    [FilePath
"trie"FilePath -> [Trie] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=([Trie] -> Trie) -> [[Trie]] -> [Trie]
forall a b. (a -> b) -> [a] -> [b]
map [Trie] -> Trie
forall a. [a] -> a
head ([ATree Tree] -> [[Trie]]
PGF.toTrie ((Tree -> ATree Tree) -> [Tree] -> [ATree Tree]
forall a b. (a -> b) -> [a] -> [b]
map Tree -> ATree Tree
PGF.toATree [Tree]
trees))|Bool
trie]

addTree :: Bool -> a -> [(FilePath, JSValue)]
addTree Bool
json a
tree = FilePath
"tree"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=a -> FilePath
forall a. ToATree a => a -> FilePath
showTree a
tree(FilePath, JSValue)
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. a -> [a] -> [a]
:
                    [FilePath
"jsontree"FilePath -> JSValue -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= a -> JSValue
forall a. (JSON a, ToATree a) => a -> JSValue
jsonExpr a
tree | Bool
json]

doComplete :: PGF -> From -> Maybe PGF.Type -> Maybe Int -> Bool -> JSValue
doComplete :: PGF -> From -> Maybe Type -> Maybe Int -> Bool -> JSValue
doComplete PGF
pgf (Maybe Language
mfrom,FilePath
input) Maybe Type
mcat Maybe Int
mlimit Bool
full = [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON
    [[(FilePath, JSValue)] -> JSValue
makeObj (
        [FilePath
"from"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
from, FilePath
"brackets"FilePath -> BracketedString -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=BracketedString
bs, FilePath
"text"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath
s] [(FilePath, JSValue)]
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. [a] -> [a] -> [a]
++
        if Bool
full
          then [ FilePath
"completions" FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= Map FilePath JSValue -> [JSValue]
forall k a. Map k a -> [a]
Map.elems ((FilePath -> [Language] -> JSValue)
-> Map FilePath [Language] -> Map FilePath JSValue
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (PGF -> FilePath -> [Language] -> JSValue
completionInfo PGF
pgf) Map FilePath [Language]
cs) ]
          else [ FilePath
"completions" FilePath -> [FilePath] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= Map FilePath [Language] -> [FilePath]
forall k a. Map k a -> [k]
Map.keys Map FilePath [Language]
cs ]
        )
    | Language
from <- [Language]
froms, let (BracketedString
bs,FilePath
s,Map FilePath [Language]
cs) = PGF
-> Language
-> Type
-> Maybe Int
-> FilePath
-> (BracketedString, FilePath, Map FilePath [Language])
complete' PGF
pgf Language
from Type
cat Maybe Int
mlimit FilePath
input]
  where
    froms :: [Language]
froms = [Language]
-> (Language -> [Language]) -> Maybe Language -> [Language]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PGF -> [Language]
PGF.languages PGF
pgf) (Language -> [Language] -> [Language]
forall a. a -> [a] -> [a]
:[]) Maybe Language
mfrom
    cat :: Type
cat = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (PGF -> Type
PGF.startCat PGF
pgf) Maybe Type
mcat

completionInfo :: PGF -> PGF.Token -> [PGF.CId] -> JSValue
completionInfo :: PGF -> FilePath -> [Language] -> JSValue
completionInfo PGF
pgf FilePath
token [Language]
funs =
  [(FilePath, JSValue)] -> JSValue
makeObj
  [FilePath
"token"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= FilePath
token
  ,FilePath
"funs" FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= (Language -> JSValue) -> [Language] -> [JSValue]
forall a b. (a -> b) -> [a] -> [b]
map Language -> JSValue
mkFun ([Language] -> [Language]
forall a. Eq a => [a] -> [a]
nub [Language]
funs)
  ]
  where
    mkFun :: Language -> JSValue
mkFun Language
cid = case PGF -> Language -> Maybe Type
PGF.functionType PGF
pgf Language
cid of
      Just Type
typ ->
        [(FilePath, JSValue)] -> JSValue
makeObj [ {-"fid".=funid,-} FilePath
"fun"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
cid, FilePath
"hyps"FilePath -> [FilePath] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[FilePath]
hyps', FilePath
"cat"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
cat ]
        where
          ([Hypo]
hyps,Language
cat,[Tree]
_es) = Type -> ([Hypo], Language, [Tree])
PGF.unType Type
typ
          hyps' :: [FilePath]
hyps' = [ [Language] -> Type -> FilePath
PGF.showType [] Type
typ | (BindType
_,Language
_,Type
typ) <- [Hypo]
hyps ]
      Maybe Type
Nothing -> [(FilePath, JSValue)] -> JSValue
makeObj [ FilePath
"error"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=(FilePath
"Function "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Language -> FilePath
forall a. Show a => a -> FilePath
show Language
cidFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" not found") ] -- shouldn't happen

doLinearize :: PGF -> PGF.Tree -> To -> JSValue
doLinearize :: PGF -> Tree -> To -> JSValue
doLinearize PGF
pgf Tree
tree To
tos = [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON
    [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"to"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
to, FilePath
"text"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath
text,FilePath
"brackets"FilePath -> [BracketedString] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[BracketedString]
bs]
      | (Language
to,FilePath
text,[BracketedString]
bs) <- PGF -> To -> Tree -> [(Language, FilePath, [BracketedString])]
forall b.
PGF
-> ([Language], FilePath -> b)
-> Tree
-> [(Language, b, [BracketedString])]
linearizeAndUnlex PGF
pgf To
tos Tree
tree]

doLinearizes :: PGF -> PGF.Tree -> To -> JSValue
doLinearizes :: PGF -> Tree -> To -> JSValue
doLinearizes PGF
pgf Tree
tree ([Language]
tos,FilePath -> FilePath
unlex) = [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON
    [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"to"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
to, FilePath
"texts"FilePath -> [FilePath] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=(FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
unlex [FilePath]
texts]
       | (Language
to,[FilePath]
texts) <- PGF -> [Language] -> Tree -> [(Language, [FilePath])]
linearizes' PGF
pgf [Language]
tos Tree
tree]
  where
    linearizes' :: PGF -> [Language] -> Tree -> [(Language, [FilePath])]
linearizes' PGF
pgf [Language]
tos Tree
tree =
        [(Language
to,Language -> Tree -> [FilePath]
lins Language
to (Language -> Tree -> Tree
forall a. Show a => a -> Tree -> Tree
transfer Language
to Tree
tree)) | Language
to <- [Language]
langs]
      where
        langs :: [Language]
langs = if [Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Language]
tos then PGF -> [Language]
PGF.languages PGF
pgf else [Language]
tos
        lins :: Language -> Tree -> [FilePath]
lins Language
to = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> (Tree -> [FilePath]) -> Tree -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(FilePath, FilePath)] -> [FilePath])
-> [[(FilePath, FilePath)]] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd) ([[(FilePath, FilePath)]] -> [FilePath])
-> (Tree -> [[(FilePath, FilePath)]]) -> Tree -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGF -> Language -> Tree -> [[(FilePath, FilePath)]]
PGF.tabularLinearizes PGF
pgf Language
to

doLinearizeTabular :: PGF -> PGF.Tree -> To -> JSValue
doLinearizeTabular :: PGF -> Tree -> To -> JSValue
doLinearizeTabular PGF
pgf Tree
tree To
tos = [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON
    [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"to"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
to,
              FilePath
"table"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"params"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath
ps,FilePath
"texts"FilePath -> [FilePath] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[FilePath]
ts]
                         | (FilePath
ps,[FilePath]
ts)<-[(FilePath, [FilePath])]
texts]]
       | (Language
to,[(FilePath, [FilePath])]
texts) <- PGF -> To -> Tree -> [(Language, [(FilePath, [FilePath])])]
linearizeTabular PGF
pgf To
tos Tree
tree]

doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> CGI JSValue
doRandom :: PGF
-> Maybe Type -> Maybe Int -> Maybe Int -> To -> CGIT IO JSValue
doRandom PGF
pgf Maybe Type
mcat Maybe Int
mdepth Maybe Int
mlimit To
to =
  IO JSValue -> CGIT IO JSValue
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValue -> CGIT IO JSValue) -> IO JSValue -> CGIT IO JSValue
forall a b. (a -> b) -> a -> b
$
  do StdGen
g <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
     let trees :: [Tree]
trees = StdGen -> PGF -> Type -> Maybe Int -> [Tree]
forall g. RandomGen g => g -> PGF -> Type -> Maybe Int -> [Tree]
PGF.generateRandomDepth StdGen
g PGF
pgf Type
cat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
depth)
     JSValue -> IO JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> IO JSValue) -> JSValue -> IO JSValue
forall a b. (a -> b) -> a -> b
$ [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON
          [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"tree"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[Language] -> Tree -> FilePath
PGF.showExpr [] Tree
tree,
                    FilePath
"linearizations"FilePath -> JSValue -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= PGF -> Tree -> To -> JSValue
doLinearizes PGF
pgf Tree
tree To
to]
             | Tree
tree <- [Tree] -> [Tree]
forall a. [a] -> [a]
limit [Tree]
trees]
  where cat :: Type
cat = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (PGF -> Type
PGF.startCat PGF
pgf) Maybe Type
mcat
        limit :: [a] -> [a]
limit = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
mlimit)
        depth :: Int
depth = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
4 Maybe Int
mdepth

doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> To -> JSValue
doGenerate :: PGF -> Maybe Type -> Maybe Int -> Maybe Int -> To -> JSValue
doGenerate PGF
pgf Maybe Type
mcat Maybe Int
mdepth Maybe Int
mlimit To
tos =
    [JSValue] -> JSValue
forall a. JSON a => a -> JSValue
showJSON [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"tree"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[Language] -> Tree -> FilePath
PGF.showExpr [] Tree
tree,
                       FilePath
"linearizations"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=
                          [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"to"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
to, FilePath
"text"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath
text]
                             | (Language
to,FilePath
text,[BracketedString]
bs) <- PGF -> To -> Tree -> [(Language, FilePath, [BracketedString])]
forall b.
PGF
-> ([Language], FilePath -> b)
-> Tree
-> [(Language, b, [BracketedString])]
linearizeAndUnlex PGF
pgf To
tos Tree
tree]]
                | Tree
tree <- [Tree] -> [Tree]
forall a. [a] -> [a]
limit [Tree]
trees]
  where
    trees :: [Tree]
trees = PGF -> Type -> Maybe Int -> [Tree]
PGF.generateAllDepth PGF
pgf Type
cat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
depth)
    cat :: Type
cat = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (PGF -> Type
PGF.startCat PGF
pgf) Maybe Type
mcat
    limit :: [a] -> [a]
limit = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
1 Maybe Int
mlimit)
    depth :: Int
depth = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
4 Maybe Int
mdepth

doGrammar :: (UTCTime,PGF) -> Either IOError (UTCTime,l) -> Maybe (Accept Language) -> CGI CGIResult
doGrammar :: (UTCTime, PGF)
-> Either IOException (UTCTime, l)
-> Maybe (Accept Language)
-> CGI CGIResult
doGrammar (UTCTime
t1,PGF
pgf) Either IOException (UTCTime, l)
elbls Maybe (Accept Language)
macc = UTCTime -> JSValue -> CGI CGIResult
forall a t. (JSON a, FormatTime t) => t -> a -> CGI CGIResult
out UTCTime
t (JSValue -> CGI CGIResult) -> JSValue -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$ JSValue -> JSValue
forall a. JSON a => a -> JSValue
showJSON (JSValue -> JSValue) -> JSValue -> JSValue
forall a b. (a -> b) -> a -> b
$ [(FilePath, JSValue)] -> JSValue
makeObj
             [FilePath
"name"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=PGF -> Language
PGF.abstractName PGF
pgf,
              FilePath
"lastmodified"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
t,
              FilePath
"hasDependencyLabels"FilePath -> Bool -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=(IOException -> Bool)
-> ((UTCTime, l) -> Bool)
-> Either IOException (UTCTime, l)
-> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> IOException -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> (UTCTime, l) -> Bool
forall a b. a -> b -> a
const Bool
True) Either IOException (UTCTime, l)
elbls,
              FilePath
"userLanguage"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=PGF -> Maybe (Accept Language) -> Language
selectLanguage PGF
pgf Maybe (Accept Language)
macc,
              FilePath
"startcat"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[Language] -> Type -> FilePath
PGF.showType [] (PGF -> Type
PGF.startCat PGF
pgf),
              FilePath
"categories"FilePath -> [FilePath] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[FilePath]
categories,
              FilePath
"functions"FilePath -> [FilePath] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[FilePath]
functions,
              FilePath
"languages"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[JSValue]
languages]
  where
    t :: UTCTime
t = (IOException -> UTCTime)
-> ((UTCTime, l) -> UTCTime)
-> Either IOException (UTCTime, l)
-> UTCTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (UTCTime -> IOException -> UTCTime
forall a b. a -> b -> a
const UTCTime
t1) (UTCTime -> UTCTime -> UTCTime
forall a. Ord a => a -> a -> a
max UTCTime
t1 (UTCTime -> UTCTime)
-> ((UTCTime, l) -> UTCTime) -> (UTCTime, l) -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime, l) -> UTCTime
forall a b. (a, b) -> a
fst) Either IOException (UTCTime, l)
elbls
    languages :: [JSValue]
languages =
       [[(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"name"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= Language
l, 
                  FilePath
"languageCode"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.= FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"" (PGF -> Language -> Maybe FilePath
PGF.languageCode PGF
pgf Language
l)]
          | Language
l <- PGF -> [Language]
PGF.languages PGF
pgf]
    categories :: [FilePath]
categories = [Language -> FilePath
PGF.showCId Language
cat | Language
cat <- PGF -> [Language]
PGF.categories PGF
pgf]
    functions :: [FilePath]
functions  = [Language -> FilePath
PGF.showCId Language
fun | Language
fun <- PGF -> [Language]
PGF.functions PGF
pgf]

outputGraphviz :: FilePath -> CGI CGIResult
outputGraphviz FilePath
code =
  do FilePath
fmt <- FilePath -> CGIT IO FilePath
forall (f :: * -> *). MonadCGI f => FilePath -> f FilePath
format FilePath
"png"
     case FilePath
fmt of
       FilePath
"gv" -> FilePath -> CGI CGIResult
outputPlain FilePath
code
       FilePath
_ -> FilePath -> ByteString -> CGI CGIResult
outputFPS' FilePath
fmt (ByteString -> CGI CGIResult)
-> CGIT IO ByteString -> CGI CGIResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString -> CGIT IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> FilePath -> IO ByteString
pipeIt2graphviz FilePath
fmt FilePath
code)
  where
    outputFPS' :: FilePath -> ByteString -> CGI CGIResult
outputFPS' = FilePath -> ByteString -> CGI CGIResult
outputBinary' (FilePath -> ByteString -> CGI CGIResult)
-> (FilePath -> FilePath)
-> FilePath
-> ByteString
-> CGI CGIResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
mimeType

    mimeType :: FilePath -> FilePath
mimeType FilePath
fmt =
      case FilePath
fmt of
        FilePath
"png" -> FilePath
"image/png"
        FilePath
"gif" -> FilePath
"image/gif"
        FilePath
"svg" -> FilePath
"image/svg+xml"
    -- ...
        FilePath
_     -> FilePath
"application/binary"

abstrTree :: PGF -> GraphvizOptions -> Tree -> FilePath
abstrTree PGF
pgf      GraphvizOptions
opts Tree
tree = PGF -> TreeOpts -> Tree -> FilePath
PGF.graphvizAbstractTree PGF
pgf TreeOpts
opts' Tree
tree
  where opts' :: TreeOpts
opts' = (Bool -> Bool
not (GraphvizOptions -> Bool
PGF.noFun GraphvizOptions
opts),Bool -> Bool
not (GraphvizOptions -> Bool
PGF.noCat GraphvizOptions
opts))

parseTree :: PGF -> Language -> GraphvizOptions -> Tree -> FilePath
parseTree PGF
pgf Language
lang GraphvizOptions
opts Tree
tree = PGF -> Language -> GraphvizOptions -> Tree -> FilePath
PGF.graphvizParseTree PGF
pgf Language
lang GraphvizOptions
opts Tree
tree

doDepTree :: (Cache Labels, Cache CncLabels)
-> FilePath -> PGF -> FilePath -> Language -> Tree -> CGI CGIResult
doDepTree (Cache Labels
alc,Cache CncLabels
clc) FilePath
path PGF
pgf FilePath
fmt Language
lang Tree
tree =
  do (UTCTime
_,Labels
lbls) <- IO (UTCTime, Labels) -> CGIT IO (UTCTime, Labels)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, Labels) -> CGIT IO (UTCTime, Labels))
-> IO (UTCTime, Labels) -> CGIT IO (UTCTime, Labels)
forall a b. (a -> b) -> a -> b
$ Cache Labels -> FilePath -> PGF -> IO (UTCTime, Labels)
forall a. Cache a -> FilePath -> PGF -> IO (UTCTime, a)
getLabels Cache Labels
alc FilePath
path PGF
pgf
     Maybe CncLabels
clbls <- IO (Maybe CncLabels) -> CGIT IO (Maybe CncLabels)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CncLabels) -> CGIT IO (Maybe CncLabels))
-> IO (Maybe CncLabels) -> CGIT IO (Maybe CncLabels)
forall a b. (a -> b) -> a -> b
$ Cache CncLabels
-> FilePath -> PGF -> Language -> IO (Maybe CncLabels)
forall (t :: * -> *) a p.
Foldable t =>
Cache (t a) -> FilePath -> p -> Language -> IO (Maybe (t a))
getCncLabels Cache CncLabels
clc FilePath
path PGF
pgf Language
lang
     let vis :: FilePath
vis = FilePath
-> Bool
-> Maybe Labels
-> Maybe CncLabels
-> PGF
-> Language
-> Tree
-> FilePath
PGF.graphvizDependencyTree FilePath
fmt Bool
False (Labels -> Maybe Labels
forall a. a -> Maybe a
Just Labels
lbls) Maybe CncLabels
clbls PGF
pgf Language
lang Tree
tree
     if FilePath
fmt FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"png",FilePath
"gif",FilePath
"gv"]
       then FilePath -> CGI CGIResult
outputGraphviz FilePath
vis
       else if FilePath
fmtFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"svg"
            then FilePath -> FilePath -> CGI CGIResult
outputText FilePath
"image/svg+xml" FilePath
vis
            else FilePath -> CGI CGIResult
outputPlain FilePath
vis

getLabels :: Cache a -> FilePath -> PGF -> IO (UTCTime, a)
getLabels Cache a
lc FilePath
path PGF
pgf =
    [IO (UTCTime, a)] -> IO (UTCTime, a)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [Cache a -> FilePath -> IO (UTCTime, a)
forall a. Cache a -> FilePath -> IO (UTCTime, a)
readCache' Cache a
lc FilePath
path | FilePath
path<-[{-path1,-}FilePath
path2,FilePath
path3]]
  where
    dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
path
  --path1 = dir</> ...labels flag from abstract syntax...
    path2 :: FilePath
path2 = FilePath
dirFilePath -> FilePath -> FilePath
</>Language -> FilePath
PGF.showCId (PGF -> Language
PGF.abstractName PGF
pgf)FilePath -> FilePath -> FilePath
<.>FilePath
"labels"
    path3 :: FilePath
path3 = FilePath -> FilePath
dropExtension FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
"labels"

getCncLabels :: Cache (t a) -> FilePath -> p -> Language -> IO (Maybe (t a))
getCncLabels Cache (t a)
lc FilePath
path p
pgf Language
lang =
    (IOException -> IO (Maybe (t a)))
-> (t a -> IO (Maybe (t a)))
-> Either IOException (t a)
-> IO (Maybe (t a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IOException -> IO (Maybe (t a))
forall p a. p -> IO (Maybe a)
fail t a -> IO (Maybe (t a))
forall (t :: * -> *) a. Foldable t => t a -> IO (Maybe (t a))
ok (Either IOException (t a) -> IO (Maybe (t a)))
-> IO (Either IOException (t a)) -> IO (Maybe (t a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (t a) -> IO (Either IOException (t a))
forall a. IO a -> IO (Either IOException a)
tryIO (Cache (t a) -> FilePath -> IO (t a)
forall a. Cache a -> FilePath -> IO a
readCache Cache (t a)
lc FilePath
path2)
  where
    ok :: t a -> IO (Maybe (t a))
ok t a
ls  = do FilePath -> IO ()
logError (FilePath
"Found "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Int -> FilePath
forall a. Show a => a -> FilePath
show (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ls)FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" CncLabels for "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Language -> FilePath
forall a. Show a => a -> FilePath
show Language
langFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" in "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
path2)
                Maybe (t a) -> IO (Maybe (t a))
forall (m :: * -> *) a. Monad m => a -> m a
return (t a -> Maybe (t a)
forall a. a -> Maybe a
Just t a
ls)
    fail :: p -> IO (Maybe a)
fail p
_ = do FilePath -> IO ()
logError (FilePath
"No CncLabels for "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Language -> FilePath
forall a. Show a => a -> FilePath
show Language
langFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" in "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
path2)
                Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    dir :: FilePath
dir = FilePath -> FilePath
takeDirectory FilePath
path
  --path1 = dir</> ...labels flag from concrete syntax...
    path2 :: FilePath
path2 = FilePath
dirFilePath -> FilePath -> FilePath
</>Language -> FilePath
PGF.showCId Language
langFilePath -> FilePath -> FilePath
<.>FilePath
"labels"
  --path3 = ...

tryIO :: IO a -> IO (Either IOError a)
tryIO :: IO a -> IO (Either IOException a)
tryIO = IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try

alignment :: PGF -> Tree -> ([Language], b) -> FilePath
alignment PGF
pgf Tree
tree ([Language]
tos,b
unlex) = PGF -> [Language] -> Tree -> FilePath
PGF.graphvizAlignment PGF
pgf [Language]
tos' Tree
tree
  where tos' :: [Language]
tos' = if [Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Language]
tos then PGF -> [Language]
PGF.languages PGF
pgf else [Language]
tos

pipeIt2graphviz :: String -> String -> IO BS.ByteString
pipeIt2graphviz :: FilePath -> FilePath -> IO ByteString
pipeIt2graphviz FilePath
fmt FilePath
code = do
    (Just Handle
inh, Just Handle
outh, Maybe Handle
_, ProcessHandle
pid) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"dot" [FilePath
"-T",FilePath
fmt])
                      { std_in :: StdStream
std_in  = StdStream
CreatePipe,
                        std_out :: StdStream
std_out = StdStream
CreatePipe,
                        std_err :: StdStream
std_err = StdStream
Inherit }

    Handle -> Bool -> IO ()
hSetBinaryMode Handle
outh Bool
True
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
inh  TextEncoding
utf8

    -- fork off a thread to start consuming the output
    ByteString
output  <- Handle -> IO ByteString
BS.hGetContents Handle
outh
    MVar ()
outMVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int64 -> IO Int64
forall a. a -> IO a
E.evaluate (ByteString -> Int64
BS.length ByteString
output) IO Int64 -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
outMVar ()

    -- now write and flush any input
    Handle -> FilePath -> IO ()
hPutStr Handle
inh FilePath
code
    Handle -> IO ()
hFlush Handle
inh
    Handle -> IO ()
hClose Handle
inh -- done with stdin

    -- wait on the output
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
outMVar
    Handle -> IO ()
hClose Handle
outh

    -- wait on the process
    ExitCode
ex <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid

    case ExitCode
ex of
     ExitCode
ExitSuccess   -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
output
     ExitFailure Int
r -> FilePath -> IO ByteString
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath
"pipeIt2graphviz: (exit " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
r FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")")

browse1json :: PGF -> Language -> Bool -> JSValue
browse1json PGF
pgf Language
id Bool
pn = [(FilePath, JSValue)] -> JSValue
makeObj ([(FilePath, JSValue)] -> JSValue)
-> (Maybe (FilePath, [Language], [Language])
    -> [(FilePath, JSValue)])
-> Maybe (FilePath, [Language], [Language])
-> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, JSValue)]
-> ((FilePath, [Language], [Language]) -> [(FilePath, JSValue)])
-> Maybe (FilePath, [Language], [Language])
-> [(FilePath, JSValue)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (FilePath, [Language], [Language]) -> [(FilePath, JSValue)]
forall a b c.
(JSON a, JSON b, JSON c) =>
(a, b, c) -> [(FilePath, JSValue)]
obj (Maybe (FilePath, [Language], [Language]) -> JSValue)
-> Maybe (FilePath, [Language], [Language]) -> JSValue
forall a b. (a -> b) -> a -> b
$ PGF -> Language -> Maybe (FilePath, [Language], [Language])
PGF.browse PGF
pgf Language
id
  where
    obj :: (a, b, c) -> [(FilePath, JSValue)]
obj (a
def,b
ps,c
cs) = if Bool
pn then ([(FilePath, JSValue)]
baseobj [(FilePath, JSValue)]
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, JSValue)]
pnames) else [(FilePath, JSValue)]
baseobj
      where
        baseobj :: [(FilePath, JSValue)]
baseobj = [FilePath
"def"FilePath -> a -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=a
def, FilePath
"producers"FilePath -> b -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=b
ps, FilePath
"consumers"FilePath -> c -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=c
cs]
        pnames :: [(FilePath, JSValue)]
pnames = [FilePath
"printnames"FilePath -> JSValue -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[(FilePath, JSValue)] -> JSValue
makeObj [(Language -> FilePath
forall a. Show a => a -> FilePath
show Language
lang)FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=PGF -> Language -> Language -> FilePath
PGF.showPrintName PGF
pgf Language
lang Language
id | Language
lang <- PGF -> [Language]
PGF.languages PGF
pgf]]


doBrowse :: PGF
-> Maybe Language
-> Maybe FilePath
-> Maybe FilePath
-> FilePath
-> Bool
-> CGI CGIResult
doBrowse PGF
pgf (Just Language
id) Maybe FilePath
_ Maybe FilePath
_ FilePath
"json" Bool
pn = JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
outputJSONP (JSValue -> CGI CGIResult) -> JSValue -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$ PGF -> Language -> Bool -> JSValue
browse1json PGF
pgf Language
id Bool
pn
doBrowse PGF
pgf Maybe Language
Nothing   Maybe FilePath
_ Maybe FilePath
_ FilePath
"json" Bool
pn =
    JSValue -> CGI CGIResult
forall a. JSON a => a -> CGI CGIResult
outputJSONP (JSValue -> CGI CGIResult) -> JSValue -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$ [(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"cats"FilePath -> JSValue -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[Language] -> JSValue
all (PGF -> [Language]
PGF.categories PGF
pgf),
                           FilePath
"funs"FilePath -> JSValue -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[Language] -> JSValue
all (PGF -> [Language]
PGF.functions PGF
pgf)]
  where
    all :: [Language] -> JSValue
all = [(FilePath, JSValue)] -> JSValue
makeObj ([(FilePath, JSValue)] -> JSValue)
-> ([Language] -> [(FilePath, JSValue)]) -> [Language] -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Language -> (FilePath, JSValue))
-> [Language] -> [(FilePath, JSValue)]
forall a b. (a -> b) -> [a] -> [b]
map Language -> (FilePath, JSValue)
one
    one :: Language -> (FilePath, JSValue)
one Language
id = Language -> FilePath
PGF.showCId Language
idFilePath -> JSValue -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=PGF -> Language -> Bool -> JSValue
browse1json PGF
pgf Language
id Bool
pn

doBrowse PGF
pgf Maybe Language
Nothing Maybe FilePath
cssClass Maybe FilePath
href FilePath
_ Bool
pn = CGI CGIResult
forall a. CGI a
errorMissingId
doBrowse PGF
pgf (Just Language
id) Maybe FilePath
cssClass Maybe FilePath
href FilePath
_ Bool
pn = -- default to "html" format
  FilePath -> CGI CGIResult
outputHTML (FilePath -> CGI CGIResult) -> FilePath -> CGI CGIResult
forall a b. (a -> b) -> a -> b
$
  case PGF -> Language -> Maybe (FilePath, [Language], [Language])
PGF.browse PGF
pgf Language
id of
    Just (FilePath
def,[Language]
ps,[Language]
cs) -> FilePath
"<PRE>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath -> FilePath
annotate FilePath
defFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</PRE>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FilePath
syntaxFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        (if Bool -> Bool
not ([Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Language]
ps)
                           then FilePath
"<BR/>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"<H3>Producers</H3>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"<P>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[Language] -> FilePath
annotateCIds [Language]
psFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</P>\n"
                           else FilePath
"")FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        (if Bool -> Bool
not ([Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Language]
cs)
                           then FilePath
"<BR/>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"<H3>Consumers</H3>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"<P>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[Language] -> FilePath
annotateCIds [Language]
csFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</P>\n"
                           else FilePath
"")FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        (if Bool
pn
                           then FilePath
"<BR/>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"<H3>Print Names</H3>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                                FilePath
"<P>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
annotatePrintNamesFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</P>\n"
                           else FilePath
"")
    Maybe (FilePath, [Language], [Language])
Nothing          -> FilePath
""
  where
    syntax :: FilePath
syntax = 
      case PGF -> Language -> Maybe Type
PGF.functionType PGF
pgf Language
id of
        Just Type
ty -> let ([Hypo]
hypos,Language
_,[Tree]
_) = Type -> ([Hypo], Language, [Tree])
PGF.unType Type
ty
                       e :: Tree
e          = Language -> [Tree] -> Tree
PGF.mkApp Language
id (((Int, Int), [Tree]) -> [Tree]
forall a b. (a, b) -> b
snd (((Int, Int), [Tree]) -> [Tree]) -> ((Int, Int), [Tree]) -> [Tree]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Hypo -> ((Int, Int), Tree))
-> (Int, Int) -> [Hypo] -> ((Int, Int), [Tree])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Int, Int) -> Hypo -> ((Int, Int), Tree)
forall a b. (Int, Int) -> (a, b, Type) -> ((Int, Int), Tree)
mkArg (Int
1,Int
1) [Hypo]
hypos)
                       rows :: [FilePath]
rows = [FilePath
"<TR class=\"my-SyntaxRow\">"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                               FilePath
"<TD class=\"my-SyntaxLang\">"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Language -> FilePath
PGF.showCId Language
langFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</TD>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                               FilePath
"<TD class=\"my-SyntaxLin\">"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++PGF -> Language -> Tree -> FilePath
PGF.linearize PGF
pgf Language
lang Tree
eFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</TD>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                               FilePath
"</TR>"
                                            | Language
lang <- PGF -> [Language]
PGF.languages PGF
pgf]
                   in FilePath
"<BR/>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
"<H3>Syntax</H3>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
"<TABLE class=\"my-SyntaxTable\">\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
"<TR class=\"my-SyntaxRow\">"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
"<TD class=\"my-SyntaxLang\">"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Language -> FilePath
PGF.showCId (PGF -> Language
PGF.abstractName PGF
pgf)FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</TD>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
"<TD class=\"my-SyntaxLin\">"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++[Language] -> Tree -> FilePath
PGF.showExpr [] Tree
eFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</TD>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      FilePath
"</TR>\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                      [FilePath] -> FilePath
unlines [FilePath]
rowsFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\n</TABLE>"
        Maybe Type
Nothing -> FilePath
""

    mkArg :: (Int, Int) -> (a, b, Type) -> ((Int, Int), Tree)
mkArg (Int
i,Int
j) (a
_,b
_,Type
ty) = ((Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+[Hypo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hypo]
hypos),Tree
e)
      where
        e :: Tree
e = ((Int, Hypo) -> Tree -> Tree) -> Tree -> [(Int, Hypo)] -> Tree
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
j,(BindType
bt,Language
_,Type
_)) -> BindType -> Language -> Tree -> Tree
PGF.mkAbs BindType
bt (FilePath -> Language
PGF.mkCId (Char
'X'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Int -> FilePath
forall a. Show a => a -> FilePath
show Int
j))) (Int -> Tree
PGF.mkMeta Int
i) ([Int] -> [Hypo] -> [(Int, Hypo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
j..] [Hypo]
hypos)
        ([Hypo]
hypos,Language
_,[Tree]
_) = Type -> ([Hypo], Language, [Tree])
PGF.unType Type
ty

    identifiers :: [Language]
identifiers = PGF -> [Language]
PGF.functions PGF
pgf [Language] -> [Language] -> [Language]
forall a. [a] -> [a] -> [a]
++ PGF -> [Language]
PGF.categories PGF
pgf

    annotate :: FilePath -> FilePath
annotate []          = []
    annotate (Char
c:FilePath
cs)
      | Char -> Bool
isIdentInitial Char
c = let (FilePath
id,FilePath
cs') = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isIdentChar) (Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
cs)
                           in (if FilePath -> Language
PGF.mkCId FilePath
id Language -> [Language] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Language]
identifiers
                                 then FilePath -> FilePath
mkLink FilePath
id
                                 else if FilePath
id FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"fun" Bool -> Bool -> Bool
|| FilePath
id FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"data" Bool -> Bool -> Bool
|| FilePath
id FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"cat" Bool -> Bool -> Bool
|| FilePath
id FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"def"
                                        then FilePath
"<B>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
idFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</B>"
                                        else FilePath
id) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                              FilePath -> FilePath
annotate FilePath
cs'
      | Bool
otherwise        = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath
annotate FilePath
cs

    annotateCIds :: [Language] -> FilePath
annotateCIds [Language]
ids = [FilePath] -> FilePath
unwords ((Language -> FilePath) -> [Language] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
mkLink (FilePath -> FilePath)
-> (Language -> FilePath) -> Language -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> FilePath
PGF.showCId) [Language]
ids)
    
    isIdentInitial :: Char -> Bool
isIdentInitial Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
    isIdentChar :: Char -> Bool
isIdentChar    Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

    hrefAttr :: FilePath -> FilePath
hrefAttr FilePath
id =
      case Maybe FilePath
href of
        Maybe FilePath
Nothing -> FilePath
""
        Just s  -> FilePath
"href=\""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath -> FilePath -> FilePath
substId FilePath
id FilePath
sFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\""

    substId :: FilePath -> FilePath -> FilePath
substId FilePath
id [] = []
    substId FilePath
id (Char
'$':Char
'I':Char
'D':FilePath
cs) = FilePath
id FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cs
    substId FilePath
id (Char
c:FilePath
cs) = Char
c Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath -> FilePath -> FilePath
substId FilePath
id FilePath
cs

    classAttr :: FilePath
classAttr =
      case Maybe FilePath
cssClass of
        Maybe FilePath
Nothing -> FilePath
""
        Just s  -> FilePath
"class=\""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
sFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\""

    mkLink :: FilePath -> FilePath
mkLink FilePath
s = FilePath
"<A "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath -> FilePath
hrefAttr FilePath
sFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
classAttrFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
">"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
sFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</A>"
    
    annotatePrintNames :: FilePath
annotatePrintNames = FilePath
"<DL>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++([FilePath] -> FilePath
unwords [FilePath]
pns)FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</DL>"
      where pns :: [FilePath]
pns = [FilePath
"<DT>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++(Language -> FilePath
forall a. Show a => a -> FilePath
show Language
lang)FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</DT><DD>"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++(PGF -> Language -> Language -> FilePath
PGF.showPrintName PGF
pgf Language
lang Language
id)FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"</DD>" | Language
lang <- PGF -> [Language]
PGF.languages PGF
pgf ]

class ToATree a where 
  showTree :: a -> String
  toATree :: a -> PGF.ATree a

instance ToATree PGF.Expr where
  showTree :: Tree -> FilePath
showTree = [Language] -> Tree -> FilePath
PGF.showExpr []
  toATree :: Tree -> ATree Tree
toATree = Tree -> ATree Tree
PGF.toATree

-- | Render trees as JSON with numbered functions
jsonExpr :: a -> JSValue
jsonExpr a
e = State Int JSValue -> Int -> JSValue
forall s a. State s a -> s -> a
evalState (ATree a -> State Int JSValue
forall a. JSON a => ATree a -> State Int JSValue
expr (a -> ATree a
forall a. ToATree a => a -> ATree a
toATree a
e)) Int
0
  where
    expr :: ATree a -> State Int JSValue
expr ATree a
e =
      case ATree a
e of
        PGF.Other a
e -> JSValue -> State Int JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"other"FilePath -> a -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=a
e])
        PGF.App Language
f [ATree a]
es ->
                do [JSValue]
js <- (ATree a -> State Int JSValue)
-> [ATree a] -> StateT Int Identity [JSValue]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ATree a -> State Int JSValue
expr [ATree a]
es
                   let children :: [(FilePath, JSValue)]
children=[FilePath
"children"FilePath -> [JSValue] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[JSValue]
js | Bool -> Bool
not ([JSValue] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JSValue]
js)]
                   Int
i<-State Int Int
inc
                   JSValue -> State Int JSValue
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> State Int JSValue) -> JSValue -> State Int JSValue
forall a b. (a -> b) -> a -> b
$ [(FilePath, JSValue)] -> JSValue
makeObj ([FilePath
"fun"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
f,FilePath
"fid"FilePath -> Int -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Int
i][(FilePath, JSValue)]
-> [(FilePath, JSValue)] -> [(FilePath, JSValue)]
forall a. [a] -> [a] -> [a]
++[(FilePath, JSValue)]
children)

    inc :: State Int Int
    inc :: State Int Int
inc = do Int
i <- State Int Int
forall s (m :: * -> *). MonadState s m => m s
get; Int -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1); Int -> State Int Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i

instance JSON PGF.Trie where
    showJSON :: Trie -> JSValue
showJSON (PGF.Oth Tree
e) = [(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"other"FilePath -> Tree -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Tree
e]
    showJSON (PGF.Ap Language
f [[]]) = [(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"fun"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
f] -- leaf
--  showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
    showJSON (PGF.Ap Language
f [[Trie]]
alts) = [(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"fun"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
f,FilePath
"alts"FilePath -> [[Trie]] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[[Trie]]
alts]
    readJSON :: JSValue -> Result Trie
readJSON = FilePath -> JSValue -> Result Trie
forall a. HasCallStack => FilePath -> a
error FilePath
"PGF.Trie.readJSON intentionally not defined"

instance JSON PGF.CId where
    readJSON :: JSValue -> Result Language
readJSON JSValue
x = JSValue -> Result FilePath
forall a. JSON a => JSValue -> Result a
readJSON JSValue
x Result FilePath -> (FilePath -> Result Language) -> Result Language
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result Language
-> (Language -> Result Language)
-> Maybe Language
-> Result Language
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Result Language
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Bad language.") Language -> Result Language
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Language -> Result Language)
-> (FilePath -> Maybe Language) -> FilePath -> Result Language
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Language
PGF.readLanguage
    showJSON :: Language -> JSValue
showJSON = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON (FilePath -> JSValue)
-> (Language -> FilePath) -> Language -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> FilePath
PGF.showLanguage

instance JSON PGF.Expr where
    readJSON :: JSValue -> Result Tree
readJSON JSValue
x = JSValue -> Result FilePath
forall a. JSON a => JSValue -> Result a
readJSON JSValue
x Result FilePath -> (FilePath -> Result Tree) -> Result Tree
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result Tree -> (Tree -> Result Tree) -> Maybe Tree -> Result Tree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> Result Tree
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Bad expression.") Tree -> Result Tree
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Tree -> Result Tree)
-> (FilePath -> Maybe Tree) -> FilePath -> Result Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Tree
PGF.readExpr
    showJSON :: Tree -> JSValue
showJSON = FilePath -> JSValue
forall a. JSON a => a -> JSValue
showJSON (FilePath -> JSValue) -> (Tree -> FilePath) -> Tree -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Language] -> Tree -> FilePath
PGF.showExpr []

instance JSON PGF.BracketedString where
    readJSON :: JSValue -> Result BracketedString
readJSON JSValue
x = BracketedString -> Result BracketedString
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> BracketedString
PGF.Leaf FilePath
"")
    showJSON :: BracketedString -> JSValue
showJSON (PGF.Bracket Language
cat Int
fid Int
_ Int
index Language
fun [Tree]
_ [BracketedString]
bs) =
        [(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"cat"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
cat, FilePath
"fid"FilePath -> Int -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Int
fid, FilePath
"index"FilePath -> Int -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Int
index, FilePath
"fun"FilePath -> Language -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=Language
fun, FilePath
"children"FilePath -> [BracketedString] -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=[BracketedString]
bs]
    showJSON (PGF.Leaf FilePath
s) = [(FilePath, JSValue)] -> JSValue
makeObj [FilePath
"token"FilePath -> FilePath -> (FilePath, JSValue)
forall a a. JSON a => a -> a -> (a, JSValue)
.=FilePath
s]

#if C_RUNTIME
instance JSON C.BracketedString where
    readJSON x = return (C.Leaf "")
    showJSON (C.Bracket cat fid index fun bs) =
        makeObj ["cat".=cat, "fid".=fid, "index".=index, "fun".=fun, "children".=bs]
    showJSON C.BIND     = makeObj ["bind".=True]
    showJSON (C.Leaf s) = makeObj ["token".=s]
#endif

-- * PGF utilities
{-
cat :: PGF -> Maybe PGF.Type -> PGF.Type
cat pgf mcat = fromMaybe (PGF.startCat pgf) mcat
-}
parse' :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> [(PGF.Language,PGF.ParseOutput,PGF.BracketedString)]
parse' :: PGF
-> FilePath
-> Maybe Type
-> Maybe Language
-> [(Language, ParseOutput, BracketedString)]
parse' PGF
pgf FilePath
input Maybe Type
mcat Maybe Language
mfrom = 
   [(Language
from,ParseOutput
po,BracketedString
bs) | Language
from <- [Language]
froms, (ParseOutput
po,BracketedString
bs) <- [PGF
-> Language
-> Type
-> Maybe Int
-> FilePath
-> (ParseOutput, BracketedString)
PGF.parse_ PGF
pgf Language
from Type
cat Maybe Int
forall a. Maybe a
Nothing FilePath
input]]
  where froms :: [Language]
froms = [Language]
-> (Language -> [Language]) -> Maybe Language -> [Language]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PGF -> [Language]
PGF.languages PGF
pgf) (Language -> [Language] -> [Language]
forall a. a -> [a] -> [a]
:[]) Maybe Language
mfrom
        cat :: Type
cat = Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe (PGF -> Type
PGF.startCat PGF
pgf) Maybe Type
mcat

complete' :: PGF -> PGF.Language -> PGF.Type -> Maybe Int -> String
         -> (PGF.BracketedString, String, Map.Map PGF.Token [PGF.CId])
complete' :: PGF
-> Language
-> Type
-> Maybe Int
-> FilePath
-> (BracketedString, FilePath, Map FilePath [Language])
complete' PGF
pgf Language
from Type
typ Maybe Int
mlimit FilePath
input =
  let ([FilePath]
ws,FilePath
prefix) = FilePath -> ([FilePath], FilePath)
tokensAndPrefix FilePath
input
  in PGF
-> Language
-> Type
-> FilePath
-> FilePath
-> (BracketedString, FilePath, Map FilePath [Language])
PGF.complete PGF
pgf Language
from Type
typ ([FilePath] -> FilePath
unwords [FilePath]
ws) FilePath
prefix
  where
    tokensAndPrefix :: String -> ([String],String)
    tokensAndPrefix :: FilePath -> ([FilePath], FilePath)
tokensAndPrefix FilePath
s | Bool -> Bool
not (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s) Bool -> Bool -> Bool
&& Char -> Bool
isSpace (FilePath -> Char
forall a. [a] -> a
last FilePath
s) = ([FilePath]
ws, FilePath
"")
                      | [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
ws = ([],FilePath
"")
                      | Bool
otherwise = ([FilePath] -> [FilePath]
forall a. [a] -> [a]
init [FilePath]
ws, [FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
ws)
        where ws :: [FilePath]
ws = FilePath -> [FilePath]
words FilePath
s


transfer :: a -> Tree -> Tree
transfer a
lang = if FilePath
"LaTeX" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` a -> FilePath
forall a. Show a => a -> FilePath
show a
lang
                then Tree -> Tree
fold -- OpenMath LaTeX transfer
                else Tree -> Tree
forall a. a -> a
id

-- | tabulate all variants and their forms
linearizeTabular
  :: PGF -> To -> PGF.Tree -> [(PGF.Language,[(String,[String])])]
linearizeTabular :: PGF -> To -> Tree -> [(Language, [(FilePath, [FilePath])])]
linearizeTabular PGF
pgf ([Language]
tos,FilePath -> FilePath
unlex) Tree
tree =
    [(Language
to,Language -> Tree -> [(FilePath, [FilePath])]
lintab Language
to (Language -> Tree -> Tree
forall a. Show a => a -> Tree -> Tree
transfer Language
to Tree
tree)) | Language
to <- [Language]
langs]
  where
    langs :: [Language]
langs = if [Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Language]
tos then PGF -> [Language]
PGF.languages PGF
pgf else [Language]
tos
    lintab :: Language -> Tree -> [(FilePath, [FilePath])]
lintab Language
to Tree
t = [(FilePath
p,(FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
unlex ([FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub [FilePath
t|(FilePath
p',FilePath
t)<-[(FilePath, FilePath)]
vs,FilePath
p'FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
p]))|FilePath
p<-[FilePath]
ps]
      where
        ps :: [FilePath]
ps = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub (((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)]
vs)
        vs :: [(FilePath, FilePath)]
vs = [[(FilePath, FilePath)]] -> [(FilePath, FilePath)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (PGF -> Language -> Tree -> [[(FilePath, FilePath)]]
PGF.tabularLinearizes PGF
pgf Language
to Tree
t)

linearizeAndUnlex :: PGF
-> ([Language], FilePath -> b)
-> Tree
-> [(Language, b, [BracketedString])]
linearizeAndUnlex PGF
pgf ([Language]
mto,FilePath -> b
unlex) Tree
tree =
    [(Language
to,b
s,[BracketedString]
bss) | Language
to<-[Language]
langs,
                 let bss :: [BracketedString]
bss = PGF -> Language -> Tree -> [BracketedString]
PGF.bracketedLinearize PGF
pgf Language
to (Language -> Tree -> Tree
forall a. Show a => a -> Tree -> Tree
transfer Language
to Tree
tree)
                     s :: b
s   = FilePath -> b
unlex (FilePath -> b) -> ([FilePath] -> FilePath) -> [FilePath] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords ([FilePath] -> b) -> [FilePath] -> b
forall a b. (a -> b) -> a -> b
$ (BracketedString -> [FilePath]) -> [BracketedString] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BracketedString -> [FilePath]
PGF.flattenBracketedString [BracketedString]
bss]
  where
    langs :: [Language]
langs = if [Language] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Language]
mto then PGF -> [Language]
PGF.languages PGF
pgf else [Language]
mto

selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
selectLanguage :: PGF -> Maybe (Accept Language) -> Language
selectLanguage PGF
pgf Maybe (Accept Language)
macc =
    case [Language]
acceptable of
      []  -> case PGF -> [Language]
PGF.languages PGF
pgf of
               []  -> FilePath -> Language
forall a. HasCallStack => FilePath -> a
error FilePath
"No concrete syntaxes in PGF grammar."
               ls :: [Language]
ls@(Language
l1:[Language]
_) -> case [Language
l | Language
l<-[Language]
ls, PGF -> Language -> Maybe FilePath
langPart PGF
pgf Language
lMaybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"Eng"] of
                              Language
eng:[Language]
_ -> Language
eng
                              [Language]
_ -> Language
l1
      Language FilePath
c:[Language]
_ -> Maybe Language -> Language
forall a. HasCallStack => Maybe a -> a
fromJust (PGF -> FilePath -> Maybe Language
langCodeLanguage PGF
pgf FilePath
c)
  where langCodes :: [FilePath]
langCodes = (Language -> Maybe FilePath) -> [Language] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PGF -> Language -> Maybe FilePath
PGF.languageCode PGF
pgf) (PGF -> [Language]
PGF.languages PGF
pgf)
        acceptable :: [Language]
acceptable = [Language] -> Maybe (Accept Language) -> [Language]
forall a. Acceptable a => [a] -> Maybe (Accept a) -> [a]
negotiate ((FilePath -> Language) -> [FilePath] -> [Language]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Language
Language [FilePath]
langCodes) Maybe (Accept Language)
macc

langCodeLanguage :: PGF -> String -> Maybe PGF.Language
langCodeLanguage :: PGF -> FilePath -> Maybe Language
langCodeLanguage PGF
pgf FilePath
code =
  [Language] -> Maybe Language
forall a. [a] -> Maybe a
listToMaybe [Language
l | Language
l <- PGF -> [Language]
PGF.languages PGF
pgf, PGF -> Language -> Maybe FilePath
PGF.languageCode PGF
pgf Language
l Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
code]

langPart :: PGF -> Language -> Maybe FilePath
langPart PGF
pgf Language
lang =
  FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (Language -> FilePath
PGF.showCId (PGF -> Language
PGF.abstractName PGF
pgf)) (Language -> FilePath
PGF.showCId Language
lang)

-- * General utilities

infixl 2 #,%

a
f .= :: a -> a -> (a, JSValue)
.= a
v = (a
f,a -> JSValue
forall a. JSON a => a -> JSValue
showJSON a
v)
a -> b
f # :: (a -> b) -> f a -> f b
# f a
x = (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x
m (a -> b)
f % :: m (a -> b) -> m a -> m b
% m a
x = m (a -> b) -> m a -> m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap m (a -> b)
f m a
x

--cleanFilePath :: FilePath -> FilePath
--cleanFilePath = takeFileName