Link camligo grammar, get rid of personal loaders

tools/lsp/squirrel/package.yaml

@@ -63,6 +63,7 @@ library:
   c-sources:
     - vendor/pascaligo/parser.c
     - vendor/reasonligo/parser.c
+    - vendor/camligo/parser.c
 
 executables:
   squirrel:

tools/lsp/squirrel/src/AST/Camligo/Parser.hs

@@ -0,0 +1,16 @@
+
+module AST.Camligo.Parser where
+
+import Data.Maybe (isJust)
+
+import AST.Skeleton
+
+import Duplo.Error
+import Duplo.Tree
+import Duplo.Pretty
+
+import Product
+import Parser
+import ParseTree
+
+-- import Debug.Trace

tools/lsp/squirrel/src/AST/Parser.hs

@@ -4,24 +4,19 @@ module AST.Parser
   , parse
   ) where
 
-import Control.Monad.Catch
-
-import System.FilePath
-
 import qualified AST.Pascaligo.Parser as Pascal
 import qualified AST.Reasonligo.Parser as Reason
 import           AST.Skeleton
 
 import ParseTree
 import Parser
-
-data UnsupportedExtension = UnsupportedExtension String
-  deriving stock Show
-  deriving anyclass Exception
+import Extension
 
 parse :: Source -> IO (LIGO Info, [Msg])
 parse src = do
-  case takeExtension $ srcPath src of
-    "religo" -> mkRawTreeReason src >>= runParserM . Reason.recognise
-    "ligo"   -> mkRawTreePascal src >>= runParserM . Pascal.recognise
-    ext      -> throwM $ UnsupportedExtension ext
+  recogniser <- onExt ElimExt
+    { eePascal = Pascal.recognise
+    , eeCaml   = error "TODO: caml recogniser"
+    , eeReason = Reason.recognise
+    } (srcPath src)
+  toParseTree src >>= runParserM . recogniser

tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs

@@ -40,24 +40,24 @@ example = "../../../src/test/contracts/coase.ligo"
 
 sample' :: FilePath -> IO (LIGO Info)
 sample' f
-  =   mkRawTreePascal (Path f)
+  =   toParseTree (Path f)
   >>= runParserM . recognise
   >>= return . fst
 
 source' :: FilePath -> IO ()
 source' f
-  =   mkRawTreePascal (Path f)
+  =   toParseTree (Path f)
   >>= print . pp
 
 sample :: IO ()
 sample
-  =   mkRawTreePascal (Path example)
+  =   toParseTree (Path example)
   >>= runParserM . recognise
   >>= print . pp . fst
 
 source :: IO ()
 source
-  =   mkRawTreePascal (Path example)
+  =   toParseTree (Path example)
   >>= print . pp
 
 recognise :: RawTree -> ParserM (LIGO Info)

tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs

@@ -35,13 +35,13 @@ example = "./contracts/multisig.religo"
 -- example = "./contracts/letin.religo"
 
 raw :: IO ()
-raw = mkRawTreeReason (Path example)
-    >>= print . pp
+raw = toParseTree (Path example)
+  >>= print . pp
 
 sample :: IO ()
-sample = mkRawTreeReason (Path example)
-    >>= runParserM . recognise
-    >>= print . pp . fst
+sample = toParseTree (Path example)
+  >>= runParserM . recognise
+  >>= print . pp . fst
 
 recognise :: RawTree -> ParserM (LIGO Info)
 recognise = descent (\_ -> error . show . pp) $ map usingScope

tools/lsp/squirrel/src/Debouncer.hs

@@ -5,6 +5,8 @@ import Control.Monad.Catch
 import Control.Monad
 import Control.Concurrent
 
+import System.IO.Unsafe
+
 -- | Ensure the function is run in single thread, w/o overlapping.
 --
 --   If called concurently, everyone will get results of the winner.
@@ -13,8 +15,8 @@ import Control.Concurrent
 --
 --   If function throws an error, will rethrow it in caller thread.
 --
-debounced :: forall s r. (s -> IO r) -> IO (s -> IO r)
-debounced act = do
+debounced :: forall s r. (s -> IO r) -> (s -> IO r)
+debounced act = unsafePerformIO do
   i <- newEmptyMVar
   o <- newEmptyMVar
 
@@ -31,7 +33,7 @@ debounced act = do
     putMVar i i'
     readMVar o >>= either throwM return
 
-_test :: IO ([Int] -> IO Int)
+_test :: [Int] -> IO Int
 _test = debounced \s -> do
   threadDelay 2000000
   unless (odd (length s)) do

tools/lsp/squirrel/src/Extension.hs

@@ -0,0 +1,36 @@
+
+module Extension where
+
+import Control.Monad.Catch
+
+import System.FilePath
+
+data Ext
+  = Pascal
+  | Caml
+  | Reason
+
+data ElimExt a = ElimExt
+  { eePascal :: a
+  , eeCaml   :: a
+  , eeReason ::  a
+  }
+
+data UnsupportedExtension = UnsupportedExtension String
+  deriving stock Show
+  deriving anyclass Exception
+
+getExt :: MonadThrow m => FilePath -> m Ext
+getExt path = do
+  case takeExtension path of
+    "religo" -> return Reason
+    "ligo"   -> return Pascal
+    "mligo"  -> return Caml
+    ext      -> throwM $ UnsupportedExtension ext
+
+onExt :: ElimExt a -> FilePath -> IO a
+onExt ee path = do
+  getExt path >>= return . \case
+    Pascal -> eePascal ee
+    Caml   -> eeCaml   ee
+    Reason -> eeReason ee

tools/lsp/squirrel/src/ParseTree.hs

@@ -16,8 +16,6 @@ module ParseTree
 
     -- * Invoke the TreeSitter and get the tree it outputs
   , toParseTree
-  , mkRawTreePascal
-  , mkRawTreeReason
   )
   where
 
@@ -42,17 +40,17 @@ import           TreeSitter.Tree hiding (Tree)
 
 import           System.FilePath (takeFileName)
 
-import           System.IO.Unsafe (unsafePerformIO)
-
 import           Duplo.Pretty as PP
 import           Duplo.Tree
 
+import           Extension
 import           Debouncer
 import           Product
 import           Range
 
 foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
 foreign import ccall unsafe tree_sitter_ReasonLigo :: Ptr Language
+foreign import ccall unsafe tree_sitter_CamlLigo :: Ptr Language
 
 data Source
   = Path       { srcPath :: FilePath }
@@ -105,17 +103,17 @@ instance Pretty1 ParseTree where
         (pp forest)
       )
 
-mkRawTreePascal :: Source -> IO RawTree
-mkRawTreePascal = toParseTree tree_sitter_PascaLigo
-
-mkRawTreeReason :: Source -> IO RawTree
-mkRawTreeReason = toParseTree tree_sitter_ReasonLigo
-
 -- | Feed file contents into PascaLIGO grammar recogniser.
-toParseTree :: Ptr Language -> Source -> IO RawTree
-toParseTree language = unsafePerformIO $ debounced inner
+toParseTree :: Source -> IO RawTree
+toParseTree = debounced inner
   where
     inner fin = do
+      language <- onExt ElimExt
+        { eePascal = tree_sitter_PascaLigo
+        , eeCaml   = tree_sitter_CamlLigo
+        , eeReason = tree_sitter_ReasonLigo
+        } (srcPath fin)
+
       parser <- ts_parser_new
       -- True   <- ts_parser_set_language parser tree_sitter_PascaLigo
       True <- ts_parser_set_language parser language