c pointer/struct syntax for haskell wip

main.hs

{-# LANGUAGE ViewPatterns, ApplicativeDo #-}
module Main (main) where
import Text.Regex.Applicative
import Data.List
import Control.Monad
import System.Exit
import System.Environment
import Data.Maybe
import Data.Char
import Data.IntMap (IntMap)
import Test.Hspec


main = do
  args@[originalName,input,output] <- getArgs
  when (length args /= 3) $ do
    putStrLn "Usage: arrowoppp originalName input output \
     \ {-# OPTIONS_GHC -F -pgmF arrowoppp -fplugin=MonadicBang #-}"
    exitFailure
  input <- readFile input
  let linePragma = "{-# LINE 1 " ++ show originalName ++ " #-}\n"
  writeFile output $ linePragma ++ input


test = hspec $ do
  let item input output = it input $ p input s0 `shouldBe` output
      itemId input = item input input
  describe "lowercase variables" $ do
    item "x * y" "x * y"
    item "x *y" "x !(readIORef y)"
    item "*x->y" "!(readIORef !(readIORef x).y)"
    item "*x" "!(readIORef x)"
    item "*x->y" "!(readIORef !(readIORef x).y)"
    item "x->y" "!(readIORef x).y"
    item "x->y->z" "!(readIORef !(readIORef x).y).z"
  describe "ignores sigs" $ do
    itemId "a :: x -> y"
    itemId "a :: x->y"
    itemId "a :: x -> y -> z"
    itemId "do x :: a -> b <- y"
  describe "qual" $ do
    item "X.e->Y.e" "!(readIORef X.e).Y.e"
    item "X.e->e" "!(readIORef X.e).e"
    item "e->Y.e" "!(readIORef e).Y.e"
  describe "ident" $ do
    it "stops" $ ident "X.y.e" `shouldBe` Just ("X.y", ".e")
    it "goes" $ ident "X.y" `shouldBe` Just ("X.y", "")
    it "caps" $ ident "X.Y" `shouldBe` Just ("X.Y", "")
  describe "assignment" $ do -- TODO. depends on pattern/expression tagging?
    item "do *a <- b" "do writeIORef a =<< b"
    item "let *a = b" "writeIORef a b"
    item "do *a->b <- c" "do writeIORef (!(readIORef a).b) =<< c"
    item "do a.b <- c" "a <- return a{ b = !c }" -- maybe?
    item "do a->b <- c" "do modifyIORef a (\\a -> a{ b = !c })" -- except effects have to be ordered
{-
lowercase variables
  x * y [✔]
  x *y [✔]
  *x->y [✔]
  *x [✔]
  *x->y [✔]
  x->y [✔]
  x->y->z [✔]
ignores sigs
  a :: x -> y [✔]
  a :: x->y [✔]
  a :: x -> y -> z [✔]
  do x :: a -> b <- y [✔]
assignment
  do *a <- b [✘]
  let *a = b [✘]
  do *a->b <- c [✘]
  do a.b <- c [✘]
  do a->b <- c [✘]
qual
  X.e->Y.e [✔]
  X.e->e [✔]
  e->Y.e [✔]
ident
  stops [✔]
  goes [✔]
  caps [✔]

Failures:

  main.hs:26:49: 
  1) assignment do *a <- b
       expected: "do writeIORef a =<< b"
        but got: "do !(readIORef a) <- b"

  To rerun use: --match "/assignment/do *a <- b/" --seed 1194112071

  main.hs:26:49: 
  2) assignment let *a = b
       expected: "writeIORef a b"
        but got: "let !(readIORef a) = b"

  To rerun use: --match "/assignment/let *a = b/" --seed 1194112071

  main.hs:26:49: 
  3) assignment do *a->b <- c
       expected: "do writeIORef (!(readIORef a).b) =<< c"
        but got: "do !(readIORef !(readIORef a).b) <- c"

  To rerun use: --match "/assignment/do *a->b <- c/" --seed 1194112071

  main.hs:26:49: 
  4) assignment do a.b <- c
       expected: "a <- return a{ b = !c }"
        but got: "do a.b <- c"

  To rerun use: --match "/assignment/do a.b <- c/" --seed 1194112071

  main.hs:26:49: 
  5) assignment do a->b <- c
       expected: "do modifyIORef a (\\a -> a{ b = !c })"
        but got: "do !(readIORef a).b <- c"

  To rerun use: --match "/assignment/do a->b <- c/" --seed 1194112071
-}

s0 = S 0 0 [] []

-- parser state
data S = S { paren, blockComment :: !Int,
        sig :: [Int],-- ^ value of `paren` when starting a ::
                     -- does it play nicely with kind signatures?
                     -- x::y::z doesn't happen, it's always e :: (t :: k)
                     --
                     -- but there is a problem with PatternSignatures
                     --
                     -- p::t <- expression
                     --
                     -- so <- can end a type signature
                     -- can <- be in a type signature?
        lastExpr :: [String]
                -- ^ a stack of expressions because x->y->z
                -- turns into !(readIORef !(readIORef x).y).z,
                -- so the number of readIORef to produce cannot be decided
                -- until the last -> is found
        }

incSig, tryDecSig, incParen, decParen, incBC, decBC :: S -> S
incSig s = s{ sig = paren s : sig s }
tryDecSig s = fromMaybe s (decSig s)
incParen s = s{ paren = paren s +1 }
decParen s = s{ paren = paren s -1 }
incBC s = s{ blockComment = blockComment s +1 }
decBC s = s{ blockComment = blockComment s -1 }

decSig :: S -> Maybe S
decSig s@S{ sig = x:xs, paren = (x<=) -> True } =
  Just s{ sig = xs }
decSig _ = Nothing


p (stripPrefix "-}" -> Just x) s = "-}" ++ p x (decBC s)
p (stripPrefix "{-" -> Just x) s = "{-" ++ p x (incBC s)
p (x:xs) s | blockComment s > 0 = x : p xs s
p (stripPrefix "*" -> Just (ident -> Just (x, y))) s@S{ lastExpr = [] }
        = "!(readIORef " ++ p y s{ lastExpr = [x, ")"] }
p (stripPrefix "->" -> Just (ident -> Just (y, z))) s@S{ lastExpr = x:xs, sig = [] }
        = p z s{ lastExpr = ( "!(readIORef " ++ x  ++ ")" ++ "." ++ y ) : xs }
p x s@S{ lastExpr = e:es } = e ++ p x s{ lastExpr = es }
p (ident -> Just (x, y)) s | "->" `isPrefixOf` y, null (sig s) = p y s{ lastExpr = [x] }
p (stripPrefix "::" -> Just x) s = "::" ++ p x (incSig s)
p (stripPrefix "--" -> Just (break (=='\n') -> (x,y))) s = "--" ++ x ++ p y s
p (stripPrefix "<-" -> Just x) s = "<-" ++ p x (tryDecSig s) -- end of Pat
p ('\n' :xs) (decSig -> Just s) = '\n' : p xs s
p ('(' : xs) s = '(' : p xs (incParen s)
p (')' : xs) s = ')' : p xs (tryDecSig (decParen s))
p (x:xs) s = x : p xs s
p [] _ = []

ident x = findLongestPrefix qualIdent x

-- from HListPP
-- "ModuleName."
modNameDot = do
    m <- psym isUpper
    odName <- many (psym isAlpha <|> psym isDigit)
    dot <- sym '.'
    pure $ m:odName ++ [dot]

-- "M.Od.Ule.Name.something"
qualIdent = do
    modNames <- many modNameDot
    end <- identSym <|> identAlpha
    pure $ concat (modNames ++ [end])
 where identSym = some (psym (\x -> x /= '`' && isSymbol x))

identAlpha = do
    c <- psym isAlpha
    cs <- many (psym isAlphaNum <|> sym '\'')
    pure $ c:cs

-- incomplete
data Cxt = Exp | Typ | Pat

tagCxt :: Cxt -> String -> [Cxt]
tagCxt p (stripPrefix "of" -> Just x) = [Pat,Pat] ++ tagCxt Pat x
tagCxt Pat (stripPrefix "->" -> Just x) = [Exp,Exp] ++ tagCxt Exp x
tagCxt _ (stripPrefix "::" -> Just x) = [Typ,Typ] ++ tagCxt Typ x
tagCxt a (x:xs) = a : tagCxt a xs
tagCxt _ [] = []
-- now I need the same paren as below