diff --git a/CirruParser.cabal b/CirruParser.cabal new file mode 100644 --- /dev/null +++ b/CirruParser.cabal @@ -0,0 +1,29 @@ + +name: CirruParser +version: 0.0.1 +cabal-version: >= 1.22 +license: MIT +license-file: README.md +description: Cirru Parser in Haskell +author: JiyinYiyong +maintainer: jiyiyiyiony@gmail.com +homepage: https://github.com/Cirru/parser.hs +category: Text +synopsis: Cirru Parser in Haskell + +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: git://github.com/Cirru/parser.hs.git + +library + hs-source-dirs: src/ + build-depends: + base >= 4 && < 5, + text, + vector, + aeson + default-language: Haskell2010 + exposed-modules: CirruParser, Cirru diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ + +Cirru Parser in Haskell +---- + +Reimplement Cirru Parser in Haskell. + +Code is now OK, but I have to make it a package... + +Test: + +```bash +runghc main.hs +``` + +### License + +MIT diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runghc + +import Distribution.Simple + +main = defaultMain diff --git a/src/Cirru.hs b/src/Cirru.hs new file mode 100644 --- /dev/null +++ b/src/Cirru.hs @@ -0,0 +1,144 @@ + +module Cirru +( CirruValue(..) +, CirruState(..) +, CrValue(..) +, CirruBuffer(..) +, createNesting +, appendItem +, resolveDollar +, resolveComma +) where + +import Data.Text (pack, unpack) +import Data.Aeson.Types (Array) +import Data.List +import qualified Data.Vector as V +import Debug.Trace +import Data.Aeson +import Data.Traversable (traverse) +import Data.Foldable (toList) +import Control.Applicative + +-- Buffer + +data CirruBuffer = CirruBuffer { bText :: String + , bX :: Integer + , bY :: Integer + } + +instance Show CirruBuffer where + show (CirruBuffer text _ _) = text + +-- Short Value + +data CrValue = CrList [CrValue] | CrString String + +instance Show CrValue where + show (CrString a) = a + show (CrList a) = "[" ++ (intercalate "," (map show a)) ++"]" + +instance FromJSON CrValue where + parseJSON v = + withText "CrString" (pure . CrString . unpack) v + <|> withArray "CrList" (\a -> CrList . toList <$> traverse parseJSON a) v + +instance ToJSON CrValue where + toJSON (CrString text) = String $ pack text + toJSON (CrList list) = Array $ V.fromList (map toJSON list) + +-- Value + +data CirruValue = CirruList [CirruValue] | CirruToken { tText :: String + , tX :: Integer + , tY :: Integer + , tEx :: Integer + , tEy :: Integer + , tPath :: String + } + +instance Show CirruValue where + show (CirruToken text _ _ _ _ _) = text + show (CirruList a) = "{" ++ (intercalate "," (map show a)) ++ "}" + +instance ToJSON CirruValue where + toJSON (CirruToken text _ _ _ _ _) = String (pack text) + toJSON (CirruList list) = Array $ V.fromList (map toJSON list) + +-- State + +data CirruState = CirruState { sName :: String + , sX :: Integer + , sY :: Integer + , sLevel :: Integer + , sIndent :: Integer + , sIndented :: Integer + , sNest :: Integer + , sPath :: String + } + +instance Show CirruState where + show (CirruState name x y level indent indented nest path) = + name ++ " l:" ++ (show level) ++ " i:" ++ (show indent) ++ "," ++ (show indented) ++ " " ++ (show nest) + +-- Manipulations + +appendItem :: CirruValue -> Integer -> CirruValue -> CirruValue +appendItem (CirruToken _ _ _ _ _ _) _ _ = error "can not append to token" +appendItem (CirruList xs) 0 x = CirruList (xs ++ [x]) +appendItem (CirruList xs) n x = + CirruList (before ++ after2) + where + before = init xs + lastItem = last xs + (CirruList after) = appendItem lastItem (n - 1) x + after2 = [CirruList after] + +createNesting :: Integer -> CirruValue +createNesting 1 = CirruList [] +createNesting n = CirruList [(createNesting (n - 1))] + +repeatDollar :: CirruValue -> CirruValue -> CirruValue +repeatDollar (CirruList xs) (CirruList []) = (CirruList xs) +repeatDollar (CirruList before) (CirruList after) = + if (length after) == 0 + then CirruList before + else case (head after) of + (CirruList cursor) -> + repeatDollar (CirruList (before ++ [CirruList newCursor])) (CirruList (tail after)) + where (CirruList newCursor) = resolveDollar (CirruList cursor) + (CirruToken "$" _ _ _ _ _) -> + CirruList (before ++ [CirruList newAfter]) + where (CirruList newAfter) = resolveDollar (CirruList (tail after)) + (CirruToken s _ _ _ _ _) -> + repeatDollar (CirruList (before ++ [head after])) (CirruList (tail after)) + +resolveDollar :: CirruValue -> CirruValue +resolveDollar (CirruList []) = (CirruList []) +resolveDollar (CirruList xs) = repeatDollar (CirruList []) (CirruList xs) + +repeatComma :: CirruValue -> CirruValue -> CirruValue +repeatComma (CirruList xs) (CirruList []) = (CirruList xs) +repeatComma (CirruList before) (CirruList after) = + if (length after) == 0 + then CirruList before + else case (head after) of + (CirruToken _ _ _ _ _ _) -> + repeatComma (CirruList (before ++ [head after])) (CirruList (tail after)) + (CirruList cursor) -> + if (length cursor) == 0 + then repeatComma (CirruList (before ++ [head after])) (CirruList (tail after)) + else case (head cursor) of + (CirruList _) -> + repeatComma (CirruList (before ++ [CirruList newCursor])) (CirruList (tail after)) + where (CirruList newCursor) = resolveComma (CirruList cursor) + (CirruToken "," _ _ _ _ _) -> + repeatComma (CirruList before) (CirruList (newCursor ++ (tail after))) + where (CirruList newCursor) = resolveComma (CirruList (tail cursor)) + (CirruToken _ _ _ _ _ _) -> + repeatComma (CirruList (before ++ [CirruList newCursor])) (CirruList (tail after)) + where (CirruList newCursor) = resolveComma (CirruList cursor) + +resolveComma :: CirruValue -> CirruValue +resolveComma (CirruList []) = (CirruList []) +resolveComma (CirruList xs) = repeatComma (CirruList []) (CirruList xs) diff --git a/src/CirruParser.hs b/src/CirruParser.hs new file mode 100644 --- /dev/null +++ b/src/CirruParser.hs @@ -0,0 +1,225 @@ + +module CirruParser +( parse +, pare +) where + +import Cirru +import Debug.Trace + +isEmpty :: String -> Bool +isEmpty [] = True +isEmpty _ = False + +emptyList = CirruList [] + +parse :: String -> String -> CirruValue +parse code filename = + parseState emptyList buffer startState code + where + buffer = CirruBuffer "" 1 1 + startState = CirruState "indent" 1 1 1 0 0 0 filename + + +cr :: CirruValue -> CrValue +cr (CirruToken x _ _ _ _ _) = CrString x +cr (CirruList xs) = CrList (map cr xs) + +pare :: String -> String -> CrValue +pare code filename = cr (parse code filename) + +newState x = x + +log2 :: CirruValue -> CirruBuffer -> CirruState -> String -> String +log2 xs buffer state code = "\nstate:\t" ++ (show state) ++ "\ncode:\t" ++ (show code) + ++ "\nxs:\t" ++ (show xs) ++ "\nbuffer:\t" ++ (show buffer) + +parseState2 :: CirruValue -> CirruBuffer -> CirruState -> String -> CirruValue +parseState2 xs buffer state code = trace (log2 xs buffer state code) $ parseState xs buffer state code + +parseState :: CirruValue -> CirruBuffer -> CirruState -> String -> CirruValue +parseState xs buffer state code = + if (isEmpty code) + then case (sName state) of + ("escape") -> escapeEof xs buffer state code + ("string") -> stringEof xs buffer state code + ("space") -> spaceEof xs buffer state code + ("token") -> tokenEof xs buffer state code + ("indent") -> indentEof xs buffer state code + else case (sName state) of + ("escape") -> + case (head code) of + ('\n') -> escapeNewline xs buffer state code + ('n') -> escapeN xs buffer state code + ('t') -> escapeT xs buffer state code + _ -> escapeElse xs buffer state code + ("string") -> + case (head code) of + ('\\') -> stringBackslash xs buffer state code + ('\n') -> stringNewline xs buffer state code + ('\"') -> stringQuote xs buffer state code + _ -> stringElse xs buffer state code + ("space") -> + case (head code) of + (' ') -> spaceSpace xs buffer state code + ('\n') -> spaceNewline xs buffer state code + ('(') -> spaceOpen xs buffer state code + (')') -> spaceClose xs buffer state code + ('"') -> spaceQuote xs buffer state code + _ -> spaceElse xs buffer state code + ("token") -> + case (head code) of + (' ') -> tokenSpace xs buffer state code + ('\n') -> tokenNewline xs buffer state code + ('(') -> tokenOpen xs buffer state code + (')') -> tokenClose xs buffer state code + ('"') -> tokenQuote xs buffer state code + _ -> tokenElse xs buffer state code + ("indent") -> + case (head code) of + (' ') -> indentSpace xs buffer state code + ('\n') -> indentNewline xs buffer state code + (')') -> indentClose xs buffer state code + _ -> indentElse xs buffer state code + _ -> error ("unknown state: " ++ (sName state)) + +escapeEof xs buffer state code = error "EOF in escape state" + +stringEof xs buffer state code = error "EOF in string state" + +spaceEof xs buffer state code = xs + +tokenEof xs b s code = + let newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s) + newXs = appendItem xs (sLevel s) newToken + in newXs + +indentEof xs buffer state code = xs + + +escapeNewline xs buffer state code = error "new line while escape" + +escapeN :: CirruValue -> CirruBuffer -> CirruState -> String -> CirruValue +escapeN xs b s code = + let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newBuffer = CirruBuffer ((bText b) ++ "\n") (bX b) (bY b) + in parseState xs newBuffer newState (tail code) + +escapeT xs b s code = + let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newBuffer = CirruBuffer ((bText b) ++ "\t") (bX b) (bY b) + in parseState xs newBuffer newState (tail code) + +escapeElse xs b s code = + let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newBuffer = CirruBuffer ((bText b) ++ [head code]) (bX b) (bY b) + in parseState xs newBuffer newState (tail code) + +stringBackslash xs b s code = + let newState = CirruState "escape" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + in parseState xs b newState (tail code) + +stringNewline xs buffer state code = error "newline in a string" + +stringQuote xs b s code = + let newState = CirruState "token" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + in parseState xs b newState (tail code) + +stringElse xs b s code = + let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newBuffer = CirruBuffer ((bText b) ++ [head code]) (bX b) (bY b) + in parseState xs newBuffer newState (tail code) + +spaceSpace xs b s code = + let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + in parseState xs b newState (tail code) + +spaceNewline xs b s code = + if (mod (sNest s) 2) == 1 + then error "incorrect nesting" + else + let newState = CirruState "indent" 1 ((sY s)+1) (sLevel s) (sIndent s) 0 (sNest s) (sPath s) + in parseState xs b newState (tail code) + +spaceOpen xs b s code = + let nesting = createNesting 1 + newXs = appendItem xs (sLevel s) nesting + newState = CirruState (sName s) ((sX s)+1) (sY s) ((sLevel s)+1) (sIndent s) (sIndented s) ((sNest s)+1) (sPath s) + in parseState newXs b newState (tail code) + +spaceClose xs b s code = + if ((sNest s) < 1) + then error "close at space" + else + let newState = CirruState (sName s) ((sX s)+1) (sY s) ((sLevel s)-1) (sIndent s) (sIndented s) ((sNest s)-1) (sPath s) + in parseState xs b newState (tail code) + +spaceQuote xs b s code = + let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newBuffer = CirruBuffer "" (sX s) (sY s) + in parseState xs newBuffer newState (tail code) + +spaceElse xs b s code = + let newState = CirruState "token" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newBuffer = CirruBuffer [head code] (sX s) (sY s) + in parseState xs newBuffer newState (tail code) + +tokenSpace xs b s code = + let newState = CirruState "space" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s) + newXs = appendItem xs (sLevel s) newToken + in parseState newXs b newState (tail code) + +tokenNewline xs b s code = + let newState = CirruState "indent" 1 ((sY s)+1) (sLevel s) (sIndent s) 0 (sNest s) (sPath s) + newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s) + newXs = appendItem xs (sLevel s) newToken + in parseState newXs b newState (tail code) + +tokenOpen xs buffer state code = error "open parenthesis in token" + +tokenClose xs b s code = + let newState = CirruState "space" (sX s) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newToken = CirruToken (bText b) (bX b) (bY b) (sX s) (sY s) (sPath s) + newXs = appendItem xs (sLevel s) newToken + in parseState newXs b newState code + +tokenQuote xs b s code = + let newState = CirruState "string" ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + in parseState xs b newState (tail code) + +tokenElse xs b s code = + let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) (sIndented s) (sNest s) (sPath s) + newBuffer = CirruBuffer ((bText b) ++ [head code]) ((sX s)+1) (sY s) + in parseState xs newBuffer newState (tail code) + +indentSpace xs b s code = + let newState = CirruState (sName s) ((sX s)+1) (sY s) (sLevel s) (sIndent s) ((sIndented s)+1) (sNest s) (sPath s) + in parseState xs b newState (tail code) + +indentNewline xs b s code = + let newState = CirruState (sName s) 1 ((sY s)+1) (sLevel s) (sIndent s) 0 (sNest s) (sPath s) + in parseState xs b newState (tail code) + +indentClose xs buffer state code = error "close parenthesis at indent" + +indentElse xs b s code = + if (mod (sIndented s) 2) == 1 + then error ("odd indentation: " ++ (show (sIndented s))) + else + let indented = div (sIndented s) 2 + diff = indented - (sIndent s) + nesting = createNesting 1 + newState = CirruState "space" (sX s) (sY s) ((sLevel s)+diff) indented (sIndented s) (sNest s) (sPath s) + in + if diff <= 0 + then + let newXs = appendItem xs ((sLevel s) + diff - 1) nesting + in parseState newXs b newState code + else + if diff > 0 + then + let newXs = appendItem xs (sLevel s) nesting + in parseState newXs b newState code + else + parseState xs b newState code