lispgraph.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}

module Main where

import Data.AttoLisp
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Data.GraphViz
import Control.Monad.State
import Lens.Micro
import Lens.Micro.Mtl
import Data.Maybe

import Data.Attoparsec.ByteString as Atto

import qualified Data.Text                  as T
import qualified Data.ByteString            as B
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Text.Lazy.IO          as TL

type GState = (Count, IDS, NS, ES)
type Count  = Int
type IDS    = [(T.Text, Int)]
type NS     = [(Int, T.Text)]
type ES     = [(Int, Int, T.Text)]

type App = State GState
type App' = App (Maybe Int)

program1 :: B.ByteString
program1 = "(let (x 5) (a x) (b x) (baz (foo \"bar\" a b)))"

program2 :: B.ByteString
program2 = "(first 1000 (shuffle (outer-join-on-images (select-classes (animals cat dog) (project A)) (select-classes (classes person quadbike) (project B)))))"

main :: IO ()
main = do
  go program1
  go program2

go :: B.ByteString -> IO ()
go prog = do
  BL.putStrLn ""
  BL.putStrLn "Program:"
  let g = Atto.parse lisp prog
  print g
  case g of
    Done _i r -> do
      BL.putStrLn ""
      TL.putStrLn $ printDotGraph $ graphToDot quickParams $ graphpack' r
    x -> do
      putStrLn "Error parsing expression"
      print x

graphpack :: Graph g => Lisp -> g T.Text T.Text
graphpack l = mkGraph ns es where (_, _, ns, es) = execState (drafter l) (0,[],[],[])

graphpack' :: Lisp -> Gr String String
graphpack' = nemap T.unpack T.unpack . graphpack

drafter :: Lisp -> App'
drafter = \case
  (Symbol     t)              -> Just <$> respondSymbol t
  (String     t)              -> Just <$> respondSymbol t
  (Number     n)              -> Just <$> respondSymbol (T.pack (show n))
  (List      [])              -> return Nothing
  (List  (Symbol "let" : ts)) -> respondLet ts
  (List  (Symbol x     : ts)) -> respondCall x ts
  (List     [h])              -> drafter h
  (List  (h:ts))              -> respondList h ts
  (DotList ls d)              -> drafter (List (ls ++ [d]))

respondList :: Lisp -> [Lisp] -> App'
respondList h ts = do
  hi  <- drafter h
  tsi <- catMaybes <$> mapM drafter ts
  forOf_ _Just hi $ forM_ tsi . createEdgeTo
  return hi

respondCall :: T.Text -> [Lisp] -> App'
respondCall h ts = do
  hi  <- respondNewSymbol h
  tsi <- catMaybes <$> mapM drafter ts
  mapM_ (createEdgeTo hi) tsi
  return (Just hi)

respondLet :: [Lisp] -> App'
respondLet [] = return Nothing
respondLet [t] = drafter t
respondLet (h:ts) = drafter h >> respondLet ts

createEdgeTo :: Int -> Int -> App ()
createEdgeTo t f = do
  _4 %= prepend (f, t, " ")
  return ()

respondNewSymbol :: T.Text -> App Int
respondNewSymbol t = do
  i <- newSym t
  _3 %= prepend (i, t)
  return i

respondSymbol :: T.Text -> App Int
respondSymbol t = do
  i <- getSym t
  _3 %= prepend (i, t)
  return i

newSym :: T.Text -> App Int
newSym t = do
  i <- _1 <<%= succ
  _2 %= prepend (t, i)
  return i

getSym :: T.Text -> App Int
getSym t = zoom _2 (gets (lookup t)) >>= maybe (newSym t) return

prepend :: a -> [a] -> [a]
prepend = (:)

Done "" (let (x 5) (a x) (b x) (baz (foo "bar" a b)))

digraph {
    0 [label=x];
    1 [label=5];
    2 [label=a];
    3 [label=b];
    4 [label=baz];
    5 [label=foo];
    6 [label=bar];
    0 -> 2 [label=" "];
    0 -> 3 [label=" "];
    1 -> 0 [label=" "];
    2 -> 5 [label=" "];
    3 -> 5 [label=" "];
    5 -> 4 [label=" "];
    6 -> 5 [label=" "];
}

Done "" (first 1000 (shuffle (outer-join-on-images (select-classes (animals cat dog) (project A)) (select-classes (classes person quadbike) (project B)))))

digraph {
    0 [label=first];
    1 [label=1000];
    2 [label=shuffle];
    3 [label="outer-join-on-images"];
    4 [label="select-classes"];
    5 [label=animals];
    6 [label=cat];
    7 [label=dog];
    8 [label=project];
    9 [label=A];
    10 [label="select-classes"];
    11 [label=classes];
    12 [label=person];
    13 [label=quadbike];
    14 [label=project];
    15 [label=B];
    1 -> 0 [label=" "];
    2 -> 0 [label=" "];
    3 -> 2 [label=" "];
    4 -> 3 [label=" "];
    5 -> 4 [label=" "];
    6 -> 5 [label=" "];
    7 -> 5 [label=" "];
    8 -> 4 [label=" "];
    9 -> 8 [label=" "];
    10 -> 3 [label=" "];
    11 -> 10 [label=" "];
    12 -> 11 [label=" "];
    13 -> 11 [label=" "];
    14 -> 10 [label=" "];
    15 -> 14 [label=" "];
}