demo srid/haskell-flake#212 (comment)

cabal.project

@@ -1,7 +1,7 @@
 packages:
-  .
+  ./haskell/
 
--- source-repository-package
---   type: git
---   location: https://github.com/eskimor/purescript-bridge.git
---   tag: 793cd8206ae777dd8f77245c1c8dbeb597c7828f 
+source-repository-package
+  type: git
+  location: https://github.com/eskimor/purescript-bridge.git
+  tag: 793cd8206ae777dd8f77245c1c8dbeb597c7828f 

haskell/src/Bridge.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE KindSignatures     #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE TypeOperators      #-}
+
+module Bridge where
+
+import Data.Proxy (Proxy (..))
+import GHC.Generics (Generic)
+import Language.PureScript.Bridge
+    (BridgePart, Language (Haskell), SumType, defaultBridge, mkSumType)
+import Language.PureScript.Bridge.PSTypes ()
+
+import Game.Chess (Color (..), PieceType (..), Ply (..), Position (..), Sq (..))
+
+import Game.Chess.Board (Board)
+import Game.Chess.Move (Move)
+
+myBridge :: BridgePart
+myBridge = defaultBridge
+
+myTypes :: [SumType 'Haskell]
+myTypes =
+  [ mkSumType (Proxy :: Proxy Color)
+  , mkSumType (Proxy :: Proxy Sq)
+  , mkSumType (Proxy :: Proxy PieceType)
+  , mkSumType (Proxy :: Proxy Board)
+  , mkSumType (Proxy :: Proxy Move)
+  -- , mkSumType (Proxy :: Proxy Ply)
+  -- , mkSumType (Proxy :: Proxy Position)
+  ]

haskell/src/Game/Chess/Board.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE ViewPatterns        #-}
+
+module Game.Chess.Board where
+
+import Prelude
+
+import qualified Control.Exception as Exc
+import Control.Monad (forM)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Aeson
+import Data.Bits (Bits (unsafeShiftL, (.|.)))
+import GHC.Generics
+
+import Game.Chess
+    (IsSquare (toIndex), Ply (..), Position, Sq (..), doPly, fromFEN,
+    legalPlies, toFEN, unsafeDoPly)
+import Game.Chess.Move (Move (Move))
+import Game.Chess.Orphans ()
+
+newtype Board = Board [Sq]
+
+allPieces :: Board
+allPieces = Board $ enumFrom minBound
+
+deriving instance Generic Board
+
+deriving instance ToJSON Board
+deriving instance FromJSON Board
+
+-- copied from https://github.com/peterbecich/chessIO/blob/0d61d8352096e4f893c13a8ff7b275b9a76d2de9/src/Game/Chess/Internal.hs#L237-L239
+move :: (IsSquare from, IsSquare to) => from -> to -> Ply
+move (toIndex -> from) (toIndex -> to) =
+  Ply $ fromIntegral to .|. fromIntegral from `unsafeShiftL` 6
+
+-- copied
+-- https://github.com/peterbecich/chessIO/blob/0d61d8352096e4f893c13a8ff7b275b9a76d2de9/src/Game/Chess/Internal.hs#L373-L376
+-- can't use `doPly`; can't capture `error`, intended to be irrecoverable
+doPly' :: Position -> Ply -> Maybe Position
+doPly' p m
+  | m `elem` legalPlies p = Just $ unsafeDoPly p m
+  | otherwise             = Nothing
+
+checkMove
+  :: Sq -> Sq -> Position -> Maybe Position
+checkMove from to start = doPly' start mv
+  where
+    mv = move from to
+
+checkMove' :: Move -> Maybe String
+checkMove' (Move fenPosition from to) = do
+  let
+    mPosition :: Maybe Position = fromFEN fenPosition
+  case mPosition of
+    Nothing -> Nothing
+    Just position -> do
+      toFEN <$> checkMove from to position

haskell/src/Game/Chess/Board.purs

@@ -0,0 +1,40 @@
+-- File auto generated by purescript-bridge! --
+module Game.Chess.Board where
+
+import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson)
+import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson)
+import Data.Argonaut.Aeson.Options as Argonaut
+import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson)
+import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
+import Data.Generic.Rep (class Generic)
+import Data.Lens (Iso', Lens', Prism', lens, prism')
+import Data.Lens.Iso.Newtype (_Newtype)
+import Data.Lens.Record (prop)
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype)
+import Foreign.Class (class Decode, class Encode)
+import Foreign.Generic (defaultOptions, genericDecode, genericEncode)
+import Game.Chess.Internal.Square (Sq)
+import Prim (Array)
+import Type.Proxy (Proxy(Proxy))
+
+import Prelude
+
+newtype Board =
+    Board (Array Sq)
+
+instance encodeBoard :: Encode Board where
+  encode = genericEncode $ defaultOptions { unwrapSingleConstructors = false , unwrapSingleArguments = false }
+instance decodeBoard :: Decode Board where
+  decode = genericDecode $ defaultOptions { unwrapSingleConstructors = false , unwrapSingleArguments = false }
+instance encodeJsonBoard :: EncodeJson Board where
+  encodeJson = genericEncodeAeson Argonaut.defaultOptions
+instance decodeJsonBoard :: DecodeJson Board where
+  decodeJson = genericDecodeAeson Argonaut.defaultOptions
+derive instance genericBoard :: Generic Board _
+derive instance newtypeBoard :: Newtype Board _
+
+--------------------------------------------------------------------------------
+_Board :: Iso' Board (Array Sq)
+_Board = _Newtype
+--------------------------------------------------------------------------------

haskell/src/Game/Chess/Internal.purs

@@ -0,0 +1,104 @@
+-- File auto generated by purescript-bridge! --
+module Game.Chess.Internal where
+
+import Data.Argonaut.Aeson.Decode.Generic (genericDecodeAeson)
+import Data.Argonaut.Aeson.Encode.Generic (genericEncodeAeson)
+import Data.Argonaut.Aeson.Options as Argonaut
+import Data.Argonaut.Decode.Class (class DecodeJson, class DecodeJsonField, decodeJson)
+import Data.Argonaut.Encode.Class (class EncodeJson, encodeJson)
+import Data.Generic.Rep (class Generic)
+import Data.Lens (Iso', Lens', Prism', lens, prism')
+import Data.Lens.Iso.Newtype (_Newtype)
+import Data.Lens.Record (prop)
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype)
+import Foreign.Class (class Decode, class Encode)
+import Foreign.Generic (defaultOptions, genericDecode, genericEncode)
+import Type.Proxy (Proxy(Proxy))
+
+import Prelude
+
+data Color =
+    Black
+  | White
+
+instance encodeColor :: Encode Color where
+  encode = genericEncode $ defaultOptions { unwrapSingleConstructors = false , unwrapSingleArguments = false }
+instance decodeColor :: Decode Color where
+  decode = genericDecode $ defaultOptions { unwrapSingleConstructors = false , unwrapSingleArguments = false }
+instance encodeJsonColor :: EncodeJson Color where
+  encodeJson = genericEncodeAeson Argonaut.defaultOptions
+instance decodeJsonColor :: DecodeJson Color where
+  decodeJson = genericDecodeAeson Argonaut.defaultOptions
+derive instance genericColor :: Generic Color _
+
+--------------------------------------------------------------------------------
+_Black :: Prism' Color Unit
+_Black = prism' (\_ -> Black) f
+  where
+    f Black = Just unit
+    f _ = Nothing
+
+_White :: Prism' Color Unit
+_White = prism' (\_ -> White) f
+  where
+    f White = Just unit
+    f _ = Nothing
+
+--------------------------------------------------------------------------------
+data PieceType =
+    Pawn
+  | Knight
+  | Bishop
+  | Rook
+  | Queen
+  | King
+
+instance encodePieceType :: Encode PieceType where
+  encode = genericEncode $ defaultOptions { unwrapSingleConstructors = false , unwrapSingleArguments = false }
+instance decodePieceType :: Decode PieceType where
+  decode = genericDecode $ defaultOptions { unwrapSingleConstructors = false , unwrapSingleArguments = false }
+instance encodeJsonPieceType :: EncodeJson PieceType where
+  encodeJson = genericEncodeAeson Argonaut.defaultOptions
+instance decodeJsonPieceType :: DecodeJson PieceType where
+  decodeJson = genericDecodeAeson Argonaut.defaultOptions
+derive instance genericPieceType :: Generic PieceType _
+
+--------------------------------------------------------------------------------
+_Pawn :: Prism' PieceType Unit
+_Pawn = prism' (\_ -> Pawn) f
+  where
+    f Pawn = Just unit
+    f _ = Nothing
+
+_Knight :: Prism' PieceType Unit
+_Knight = prism' (\_ -> Knight) f
+  where
+    f Knight = Just unit
+    f _ = Nothing
+
+_Bishop :: Prism' PieceType Unit
+_Bishop = prism' (\_ -> Bishop) f
+  where
+    f Bishop = Just unit
+    f _ = Nothing
+
+_Rook :: Prism' PieceType Unit
+_Rook = prism' (\_ -> Rook) f
+  where
+    f Rook = Just unit
+    f _ = Nothing
+
+_Queen :: Prism' PieceType Unit
+_Queen = prism' (\_ -> Queen) f
+  where
+    f Queen = Just unit
+    f _ = Nothing
+
+_King :: Prism' PieceType Unit
+_King = prism' (\_ -> King) f
+  where
+    f King = Just unit
+    f _ = Nothing
+
+--------------------------------------------------------------------------------