path: root/interactive-edit-lens/src/Main.hs

{-# LANGUAGE OverloadedStrings
           , ExistentialQuantification
           , DeriveGeneric
  #-}

module Main where

import Interact
import Control.DFST.Lens
import Control.DFST

import Control.Arrow ((&&&))

import Data.Map (Map)
import qualified Data.Map as Map

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Sequence (Seq)
import qualified Data.Sequence as Seq

import Data.List ((\\), inits, tails)

import Data.Char

import System.Environment
import System.Exit

import Debug.Trace

import Data.Universe

import Control.DeepSeq
import GHC.Generics (Generic)

data SomeDFST = forall state. (Ord state, Show state, Finite state, NFData (DFSTComplement state Char Char)) => SomeDFST { someDFST :: DFST state Char Char }

data JsonContext = JCInDet | JCDict | JCDictKey | JCDictVal | JCArray | JCArrayVal | JCTop
  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)
instance Universe JsonContext
instance Finite JsonContext

instance NFData JsonContext

data JsonNewlState = JNElement JsonContext
                   | JNTrue String JsonContext | JNFalse String JsonContext | JNNull String JsonContext | JNLitEnd JsonContext
                   | JNString JsonContext | JNStringEsc Int JsonContext | JNStringEnd JsonContext
                   | JNNumberDigits Bool JsonContext | JNNumberDecimal JsonContext | JNNumberDecimalDigits Bool JsonContext | JNNumberExpSign JsonContext | JNNumberExpDigits Bool JsonContext | JNNumberEnd JsonContext
  deriving (Eq, Ord, Show, Read, Generic)
instance Universe JsonNewlState where
  universe = concat
    [ JNElement <$> universeF
    , JNTrue <$> inits' "true" <*> universeF
    , JNFalse <$> inits' "false" <*> universeF
    , JNNull <$> inits' "null" <*> universeF
    , JNLitEnd <$> universeF
    , JNString <$> universeF
    , JNStringEsc <$> [0..4] <*> universeF
    , JNStringEnd <$> universeF
    , JNNumberDigits <$> universeF <*> universeF
    , JNNumberDecimal <$> universeF
    , JNNumberDecimalDigits <$> universeF <*> universeF
    , JNNumberExpSign <$> universeF
    , JNNumberExpDigits <$> universeF <*> universeF
    , JNNumberEnd <$> universeF
    ]
    where
      inits' xs = inits xs \\ [""]
instance Finite JsonNewlState

instance NFData JsonNewlState

jsonStrEscapes :: [(Char, Seq Char)]
jsonStrEscapes = [ ('"', "\\\"")
                 , ('\\', "\\\\")
                 , ('/', "/")
                 , ('b', "\\b")
                 , ('f', "\\f")
                 , ('n', "\\n")
                 , ('r', "\\r")
                 , ('t', "\\t")
                 ]

hexDigits :: [Char]
hexDigits = ['0'..'9'] ++ ['a'..'f']

data LineBreakState = LineBreak Int
  deriving (Eq, Ord, Show, Read, Generic)
instance Universe LineBreakState where
  universe = [ LineBreak n | n <- [0..80] ]
instance Finite LineBreakState
instance NFData LineBreakState

dfstMap :: String -> Maybe SomeDFST
dfstMap "double" = Just . SomeDFST $ DFST
  { stInitial = ()
  , stTransition = mconcat
    [ Map.fromList 
        [(((), sym), ((), Seq.fromList [sym, sym])) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
    , Map.singleton ((), '\n') ((), Seq.singleton '\n')
    ]
  , stAccept = Set.singleton ()
  }
dfstMap "id" = Just . SomeDFST $ DFST
  { stInitial = ()
  , stTransition = Map.fromList 
      [(((), sym), ((), Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
  , stAccept = Set.singleton ()
  }
dfstMap "alternate" = Just . SomeDFST $ DFST
  { stInitial = False
  , stTransition = mconcat
    [ Map.fromList [((False, sym), (True, Seq.singleton sym)) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
    , Map.fromList [((True, sym), (False, Seq.fromList [toUpper sym, toUpper sym])) | sym <- ['a'..'z'] ++ ['A'..'Z'] ++ ['!', ' ']] -- sym <- [minBound..maxBound], isPrint sym]
    ]
  , stAccept = Set.fromList [False]
  }
dfstMap "json-newl" = Just . SomeDFST $ DFST
  { stInitial = JNElement JCTop
  , stTransition = mconcat
    [ Map.fromList [ ((st, sym), (st, Seq.empty))
                   | sym <- whitespace
                   , st <- [JNElement, JNStringEnd, JNNumberEnd, JNLitEnd] <*> universeF
                   ]
    , Map.fromList [ ((JNElement ctx, '{'), (JNElement JCDict, "{ ")) | ctx <- universeF ]
    , Map.fromList [ ((JNElement ctx, '}'), (JNElement JCInDet, "\n}\n")) | ctx <- [JCDict, JCInDet] ]
    , Map.fromList [ ((JNElement ctx, '['), (JNElement JCArray, "[ ")) | ctx <- universeF ]
    , Map.fromList [ ((JNElement ctx, ']'), (JNElement JCInDet, "\n]\n")) | ctx <- [JCArray, JCInDet] ]
    , Map.singleton (JNElement JCInDet, ',') (JNElement JCInDet, "\n, ")
    , Map.fromList [ ((JNElement ctx, '"'), (JNString ctx', "\"")) | (ctx, ctx') <- startElemCtxs ]
    , Map.fromList [ ((JNString ctx, c), (JNString ctx, Seq.singleton c)) | ctx <- universeF, c <- map toEnum [0..255], isPrint c, c /= '"', c /= '\\' ]
    , Map.fromList [ ((JNString ctx, '"'), (JNStringEnd ctx, "\"")) | ctx <- universeF ]
    , Map.fromList [ ((JNStringEnd ctx, ':'), (JNElement JCDictVal, " : ")) | ctx <- [JCDictKey, JCInDet] ]
    , Map.singleton (JNStringEnd JCArrayVal, ',') (JNElement JCArrayVal, "\n, ")
    , Map.singleton (JNStringEnd JCDictVal, ',') (JNElement JCDictKey, "\n, ")
    , Map.singleton (JNStringEnd JCInDet, ',') (JNElement JCInDet, "\n, ")
    , Map.fromList [ ((JNStringEnd ctx, '}'), (JNElement JCInDet, "\n}\n")) | ctx <- [JCDictVal, JCInDet] ]
    , Map.fromList [ ((JNStringEnd ctx, ']'), (JNElement JCInDet, "\n]\n")) | ctx <- [JCArrayVal, JCInDet] ]
    , Map.fromList [ ((JNString ctx, '\\'), (JNStringEsc 0 ctx, mempty)) | ctx <- universeF ]
    , Map.fromList [ ((JNStringEsc 0 ctx, c), (JNString ctx, res)) | ctx <- universeF, (c, res) <- jsonStrEscapes ]
    , Map.fromList [ ((JNStringEsc 0 ctx, 'u'), (JNStringEsc 1 ctx, "\\u")) | ctx <- universeF ]
    , Map.fromList [ ((JNStringEsc n ctx, c'), (JNStringEsc (succ n) ctx, Seq.singleton c)) | ctx <- universeF, c <- hexDigits, c' <- [toLower c, toUpper c], n <- [1..3] ]
    , Map.fromList [ ((JNStringEsc 4 ctx, c'), (JNString ctx, Seq.singleton c)) | ctx <- universeF, c <- hexDigits, c' <- [toLower c, toUpper c]]
    , mconcat $ do
        (lit@(l:_), st) <- literals
        id
          [ Map.fromList [ ((JNElement ctx, l'), (st (pure l) ctx', Seq.singleton l))
                         | l' <- [toLower l, toUpper l]
                         , (ctx, ctx') <- startElemCtxs
                         ]
          , Map.fromList [ ((st i ctx, r'), (st (i ++ [r]) ctx, Seq.singleton r))
                         | (i, t@(r:rs)) <- uncurry zip $ (inits &&& tails) lit
                         , i /= []
                         , r' <- [toLower r, toUpper r]
                         , ctx <- [JCInDet, JCDictKey, JCDictVal, JCArrayVal, JCTop]
                         ]
          , Map.fromList [ ((st lit ctx, ':'), (JNElement JCDictVal, " : "))
                         | ctx <- [JCDictKey, JCInDet]
                         ]
          , Map.fromList [ ((st lit ctx, ','), (JNElement JCArrayVal, "\n, "))
                         | ctx <- [JCArrayVal, JCInDet]
                         ]
          , Map.fromList [ ((st lit ctx, ','), (JNElement JCDictKey, "\n, "))
                        | ctx <- [JCDictVal, JCInDet]
                         ]
          , Map.singleton (st lit JCInDet, ',') (JNElement JCInDet, "\n, ")
          , Map.fromList [ ((st lit ctx, '}'), (JNElement JCInDet, "\n}\n")) | ctx <- [JCDictVal, JCInDet] ]
          , Map.fromList [ ((st lit ctx, ']'), (JNElement JCInDet, "\n]\n")) | ctx <- [JCArrayVal, JCInDet] ]
          , Map.fromList [ ((st lit ctx, sym), (JNLitEnd ctx, Seq.empty)) | ctx <- universeF, sym <- whitespace ]
          ]
    , Map.fromList [ ((JNLitEnd ctx, ':'), (JNElement JCDictVal, " : ")) | ctx <- [JCDictKey, JCInDet] ]
    , Map.fromList [ ((JNLitEnd ctx, ','), (JNElement JCArrayVal, "\n, ")) | ctx <- [JCArrayVal, JCInDet] ]
    , Map.fromList [ ((JNLitEnd ctx, ','), (JNElement JCDictKey, "\n, ")) | ctx <- [JCDictVal, JCInDet] ]
    , Map.fromList [ ((JNLitEnd ctx, '}'), (JNElement JCInDet, "\n}\n")) | ctx <- [JCDictVal, JCInDet] ]
    , Map.fromList [ ((JNLitEnd ctx, ']'), (JNElement JCInDet, "\n]\n")) | ctx <- [JCArrayVal, JCInDet] ]
    , Map.fromList [ ((JNElement ctx, '-'), (JNNumberDigits False ctx', "-")) | (ctx, ctx') <- startElemCtxs ]
    , Map.fromList [ ((JNElement ctx, '0'), (JNNumberDecimal ctx', "0")) | (ctx, ctx') <- startElemCtxs ]
    , Map.fromList [ ((JNElement ctx, dgt), (JNNumberDigits True ctx', Seq.singleton dgt)) | (ctx, ctx') <- startElemCtxs, dgt <- ['1'..'9'] ]
    , Map.fromList [ ((JNNumberDigits True ctx, '0'), (JNNumberDigits True ctx, "0")) | ctx <- universeF ]
    , Map.fromList [ ((JNNumberDigits b ctx, dgt), (JNNumberDigits True ctx, Seq.singleton dgt)) | ctx <- universeF, dgt <- ['1'..'9'], b <- universeF ]
    , Map.fromList [ ((JNNumberDigits True ctx, '.'), (JNNumberDecimalDigits False ctx, ".")) | ctx <- universeF ]
    , Map.fromList [ ((JNNumberDecimal ctx, '.'), (JNNumberDecimalDigits False ctx, ".")) | ctx <- universeF ]
    , Map.fromList [ ((JNNumberDecimalDigits b ctx, dgt), (JNNumberDecimalDigits True ctx, Seq.singleton dgt)) | ctx <- universeF, dgt <- ['0'..'9'], b <- universeF ]
    , Map.fromList [ ((JNNumberDecimalDigits True ctx, e), (JNNumberExpSign ctx, "e")) | ctx <- universeF, e <- "eE" ]
    , Map.fromList [ ((JNNumberDigits True ctx, e), (JNNumberExpSign ctx, "e")) | ctx <- universeF, e <- "eE" ]
    , Map.fromList [ ((JNNumberDecimal ctx, e), (JNNumberExpSign ctx, "e")) | ctx <- universeF, e <- "eE" ]
    , Map.fromList [ ((JNNumberExpSign ctx, sgn), (JNNumberExpDigits False ctx, Seq.singleton sgn)) | ctx <- universeF, sgn <- "+-" ]
    , Map.fromList [ ((JNNumberExpSign ctx, dgt), (JNNumberExpDigits True ctx, Seq.singleton dgt)) | ctx <- universeF, dgt <- ['0'..'9'] ]
    , Map.fromList [ ((JNNumberExpDigits b ctx, dgt), (JNNumberExpDigits True ctx, Seq.singleton dgt)) | ctx <- universeF, dgt <- ['0'..'9'], b <- universeF ]
    , mconcat $ do
        end <- [ JNNumberExpDigits True, JNNumberDecimal, JNNumberDigits True, JNNumberDecimalDigits True ]
        id
          [ Map.fromList [ ((end ctx, ':'), (JNElement JCDictVal, " : ")) | ctx <- [JCDictKey, JCInDet] ]
          , Map.singleton (end JCArrayVal, ',') (JNElement JCArrayVal, "\n, ")
          , Map.singleton (end JCDictVal, ',') (JNElement JCDictKey, "\n, ")
          , Map.singleton (end JCInDet, ',') (JNElement JCInDet, "\n, ")
          , Map.fromList [ ((end ctx, '}'), (JNElement JCInDet, "\n}\n")) | ctx <- [JCDictVal, JCInDet] ]
          , Map.fromList [ ((end ctx, ']'), (JNElement JCInDet, "\n]\n")) | ctx <- [JCArrayVal, JCInDet] ]
          , Map.fromList [ ((end ctx, sym), (JNNumberEnd ctx, Seq.empty)) | ctx <- universeF, sym <- whitespace ]
          ]
    , Map.fromList [ ((JNNumberEnd ctx, ':'), (JNElement JCDictVal, " : ")) | ctx <- [JCDictKey, JCInDet] ]
    , Map.singleton (JNNumberEnd JCArrayVal, ',') (JNElement JCArrayVal, "\n, ")
    , Map.singleton (JNNumberEnd JCDictVal, ',') (JNElement JCDictKey, "\n, ")
    , Map.singleton (JNNumberEnd JCInDet, ',') (JNElement JCInDet, "\n, ")
    , Map.fromList [ ((JNNumberEnd ctx, '}'), (JNElement JCInDet, "\n}\n")) | ctx <- [JCDictVal, JCInDet] ]
    , Map.fromList [ ((JNNumberEnd ctx, ']'), (JNElement JCInDet, "\n]\n")) | ctx <- [JCArrayVal, JCInDet] ]
    ]
  , stAccept = Set.fromList $ do
      end <- endStates
      ctx <- [JCTop, JCInDet]
      return $ end ctx
  }
  where
    startElemCtxs = map (\x -> (x, x)) [JCInDet, JCDictKey, JCDictVal, JCArrayVal, JCTop] ++ [(JCArray, JCArrayVal), (JCDict, JCDictKey)]
    literals = [ ("true", JNTrue), ("false", JNFalse), ("null", JNNull) ]
    whitespace = toEnum <$> [0x0020, 0x0009, 0x000a, 0x000d]

    endStates = [JNElement, JNStringEnd, JNNumberExpDigits True, JNNumberDecimal, JNNumberDigits True, JNNumberDecimalDigits True] ++ [ st lit | (lit, st) <- literals]
dfstMap "linebreak" = Just . SomeDFST $ DFST
  { stInitial = LineBreak 0
  , stTransition = mconcat
    [ Map.fromList [ ((LineBreak n, sym), (LineBreak $ succ n, Seq.singleton sym)) | n <- [0..79], sym <- map toEnum [0..255], isPrint sym, sym /= '\n' ]
    , Map.fromList [ ((LineBreak n, '\n'), (LineBreak $ succ n, Seq.singleton ' ')) | n <- [0..79] ]
    , Map.singleton (LineBreak 80, ' ') (LineBreak 0, Seq.singleton '\n')
    , Map.singleton (LineBreak 80, '\n') (LineBreak 0, Seq.singleton '\n')
    , Map.fromList [ ((LineBreak 80, sym), (LineBreak 80, Seq.singleton sym)) | sym <- map toEnum [0..255], isPrint sym, sym /= ' ', sym /= '\n' ]
    ]
  , stAccept = Set.fromList universeF
  }
dfstMap _ = Nothing

main :: IO ()
main = do
  args <- getArgs

  dfst <- case args of
    [name] | Just dfst <- dfstMap name
      -> return dfst
    _ -> exitWith $ ExitFailure 2

  interactiveEditLens' dfst

interactiveEditLens' :: SomeDFST -> IO ()
interactiveEditLens' (SomeDFST dfst)
  = interactiveEditLens id $ InteractConfig
      { icfgInitial = InitialEmpty
      , icfgLens = dfstLens dfst
      , icfgCompileError = Nothing
      }